Add C versions as fallback

lapack-netlib/TESTING/MATGEN/Makefile

@@ -33,6 +33,13 @@
 TOPSRCDIR = ../..
 include $(TOPSRCDIR)/make.inc
 
+ifneq ($(C_LAPACK), 1)
+.SUFFIXES:
+.SUFFIXES: .f .o
+.f.o:
+	$(FC) $(FFLAGS) -c -o $@ $<
+endif
+
 ifneq "$(or $(BUILD_SINGLE),$(BUILD_COMPLEX))" ""
 SCATGEN = slatm1.o slatm7.o slaran.o slarnd.o
 endif

lapack-netlib/TESTING/MATGEN/clagge.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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__3 = 3;
+static integer c__1 = 1;
+
+/* > \brief \b CLAGGE */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE CLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO ) */
+
+/*       INTEGER            INFO, KL, KU, LDA, M, N */
+/*       INTEGER            ISEED( 4 ) */
+/*       REAL               D( * ) */
+/*       COMPLEX            A( LDA, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > CLAGGE generates a complex general m by n matrix A, by pre- and post- */
+/* > multiplying a real diagonal matrix D with random unitary matrices: */
+/* > A = U*D*V. The lower and upper bandwidths may then be reduced to */
+/* > kl and ku by additional unitary transformations. */
+/* > \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] KL */
+/* > \verbatim */
+/* >          KL is INTEGER */
+/* >          The number of nonzero subdiagonals within the band of A. */
+/* >          0 <= KL <= M-1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KU */
+/* > \verbatim */
+/* >          KU is INTEGER */
+/* >          The number of nonzero superdiagonals within the band of A. */
+/* >          0 <= KU <= N-1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is REAL array, dimension (f2cmin(M,N)) */
+/* >          The diagonal elements of the diagonal matrix D. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] A */
+/* > \verbatim */
+/* >          A is COMPLEX array, dimension (LDA,N) */
+/* >          The generated m by n matrix A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= M. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension (4) */
+/* >          On entry, the seed of the random number generator; the array */
+/* >          elements must be between 0 and 4095, and ISEED(4) must be */
+/* >          odd. */
+/* >          On exit, the seed is updated. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is COMPLEX array, dimension (M+N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit */
+/* >          < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complex_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int clagge_(integer *m, integer *n, integer *kl, integer *ku,
+	 real *d__, complex *a, integer *lda, integer *iseed, complex *work, 
+	integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+    real r__1;
+    complex q__1;
+
+    /* Local variables */
+    integer i__, j;
+    extern /* Subroutine */ int cgerc_(integer *, integer *, complex *, 
+	    complex *, integer *, complex *, integer *, complex *, integer *),
+	     cscal_(integer *, complex *, complex *, integer *), cgemv_(char *
+	    , integer *, integer *, complex *, complex *, integer *, complex *
+	    , integer *, complex *, complex *, integer *);
+    extern real scnrm2_(integer *, complex *, integer *);
+    complex wa, wb;
+    extern /* Subroutine */ int clacgv_(integer *, complex *, integer *);
+    real wn;
+    extern /* Subroutine */ int xerbla_(char *, integer *), clarnv_(
+	    integer *, integer *, integer *, complex *);
+    complex tau;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    --d__;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --iseed;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    if (*m < 0) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*kl < 0 || *kl > *m - 1) {
+	*info = -3;
+    } else if (*ku < 0 || *ku > *n - 1) {
+	*info = -4;
+    } else if (*lda < f2cmax(1,*m)) {
+	*info = -7;
+    }
+    if (*info < 0) {
+	i__1 = -(*info);
+	xerbla_("CLAGGE", &i__1);
+	return 0;
+    }
+
+/*     initialize A to diagonal matrix */
+
+    i__1 = *n;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *m;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    i__3 = i__ + j * a_dim1;
+	    a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L10: */
+	}
+/* L20: */
+    }
+    i__1 = f2cmin(*m,*n);
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	i__2 = i__ + i__ * a_dim1;
+	i__3 = i__;
+	a[i__2].r = d__[i__3], a[i__2].i = 0.f;
+/* L30: */
+    }
+
+/*     Quick exit if the user wants a diagonal matrix */
+
+    if (*kl == 0 && *ku == 0) {
+	return 0;
+    }
+
+/*     pre- and post-multiply A by random unitary matrices */
+
+    for (i__ = f2cmin(*m,*n); i__ >= 1; --i__) {
+	if (i__ < *m) {
+
+/*           generate random reflection */
+
+	    i__1 = *m - i__ + 1;
+	    clarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+	    i__1 = *m - i__ + 1;
+	    wn = scnrm2_(&i__1, &work[1], &c__1);
+	    r__1 = wn / c_abs(&work[1]);
+	    q__1.r = r__1 * work[1].r, q__1.i = r__1 * work[1].i;
+	    wa.r = q__1.r, wa.i = q__1.i;
+	    if (wn == 0.f) {
+		tau.r = 0.f, tau.i = 0.f;
+	    } else {
+		q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i;
+		wb.r = q__1.r, wb.i = q__1.i;
+		i__1 = *m - i__;
+		c_div(&q__1, &c_b2, &wb);
+		cscal_(&i__1, &q__1, &work[2], &c__1);
+		work[1].r = 1.f, work[1].i = 0.f;
+		c_div(&q__1, &wb, &wa);
+		r__1 = q__1.r;
+		tau.r = r__1, tau.i = 0.f;
+	    }
+
+/*           multiply A(i:m,i:n) by random reflection from the left */
+
+	    i__1 = *m - i__ + 1;
+	    i__2 = *n - i__ + 1;
+	    cgemv_("Conjugate transpose", &i__1, &i__2, &c_b2, &a[i__ + i__ * 
+		    a_dim1], lda, &work[1], &c__1, &c_b1, &work[*m + 1], &
+		    c__1);
+	    i__1 = *m - i__ + 1;
+	    i__2 = *n - i__ + 1;
+	    q__1.r = -tau.r, q__1.i = -tau.i;
+	    cgerc_(&i__1, &i__2, &q__1, &work[1], &c__1, &work[*m + 1], &c__1,
+		     &a[i__ + i__ * a_dim1], lda);
+	}
+	if (i__ < *n) {
+
+/*           generate random reflection */
+
+	    i__1 = *n - i__ + 1;
+	    clarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+	    i__1 = *n - i__ + 1;
+	    wn = scnrm2_(&i__1, &work[1], &c__1);
+	    r__1 = wn / c_abs(&work[1]);
+	    q__1.r = r__1 * work[1].r, q__1.i = r__1 * work[1].i;
+	    wa.r = q__1.r, wa.i = q__1.i;
+	    if (wn == 0.f) {
+		tau.r = 0.f, tau.i = 0.f;
+	    } else {
+		q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i;
+		wb.r = q__1.r, wb.i = q__1.i;
+		i__1 = *n - i__;
+		c_div(&q__1, &c_b2, &wb);
+		cscal_(&i__1, &q__1, &work[2], &c__1);
+		work[1].r = 1.f, work[1].i = 0.f;
+		c_div(&q__1, &wb, &wa);
+		r__1 = q__1.r;
+		tau.r = r__1, tau.i = 0.f;
+	    }
+
+/*           multiply A(i:m,i:n) by random reflection from the right */
+
+	    i__1 = *m - i__ + 1;
+	    i__2 = *n - i__ + 1;
+	    cgemv_("No transpose", &i__1, &i__2, &c_b2, &a[i__ + i__ * a_dim1]
+		    , lda, &work[1], &c__1, &c_b1, &work[*n + 1], &c__1);
+	    i__1 = *m - i__ + 1;
+	    i__2 = *n - i__ + 1;
+	    q__1.r = -tau.r, q__1.i = -tau.i;
+	    cgerc_(&i__1, &i__2, &q__1, &work[*n + 1], &c__1, &work[1], &c__1,
+		     &a[i__ + i__ * a_dim1], lda);
+	}
+/* L40: */
+    }
+
+/*     Reduce number of subdiagonals to KL and number of superdiagonals */
+/*     to KU */
+
+/* Computing MAX */
+    i__2 = *m - 1 - *kl, i__3 = *n - 1 - *ku;
+    i__1 = f2cmax(i__2,i__3);
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	if (*kl <= *ku) {
+
+/*           annihilate subdiagonal elements first (necessary if KL = 0) */
+
+/* Computing MIN */
+	    i__2 = *m - 1 - *kl;
+	    if (i__ <= f2cmin(i__2,*n)) {
+
+/*              generate reflection to annihilate A(kl+i+1:m,i) */
+
+		i__2 = *m - *kl - i__ + 1;
+		wn = scnrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
+		r__1 = wn / c_abs(&a[*kl + i__ + i__ * a_dim1]);
+		i__2 = *kl + i__ + i__ * a_dim1;
+		q__1.r = r__1 * a[i__2].r, q__1.i = r__1 * a[i__2].i;
+		wa.r = q__1.r, wa.i = q__1.i;
+		if (wn == 0.f) {
+		    tau.r = 0.f, tau.i = 0.f;
+		} else {
+		    i__2 = *kl + i__ + i__ * a_dim1;
+		    q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
+		    wb.r = q__1.r, wb.i = q__1.i;
+		    i__2 = *m - *kl - i__;
+		    c_div(&q__1, &c_b2, &wb);
+		    cscal_(&i__2, &q__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
+			    c__1);
+		    i__2 = *kl + i__ + i__ * a_dim1;
+		    a[i__2].r = 1.f, a[i__2].i = 0.f;
+		    c_div(&q__1, &wb, &wa);
+		    r__1 = q__1.r;
+		    tau.r = r__1, tau.i = 0.f;
+		}
+
+/*              apply reflection to A(kl+i:m,i+1:n) from the left */
+
+		i__2 = *m - *kl - i__ + 1;
+		i__3 = *n - i__;
+		cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*kl + 
+			i__ + (i__ + 1) * a_dim1], lda, &a[*kl + i__ + i__ * 
+			a_dim1], &c__1, &c_b1, &work[1], &c__1);
+		i__2 = *m - *kl - i__ + 1;
+		i__3 = *n - i__;
+		q__1.r = -tau.r, q__1.i = -tau.i;
+		cgerc_(&i__2, &i__3, &q__1, &a[*kl + i__ + i__ * a_dim1], &
+			c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) * 
+			a_dim1], lda);
+		i__2 = *kl + i__ + i__ * a_dim1;
+		q__1.r = -wa.r, q__1.i = -wa.i;
+		a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+	    }
+
+/* Computing MIN */
+	    i__2 = *n - 1 - *ku;
+	    if (i__ <= f2cmin(i__2,*m)) {
+
+/*              generate reflection to annihilate A(i,ku+i+1:n) */
+
+		i__2 = *n - *ku - i__ + 1;
+		wn = scnrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+		r__1 = wn / c_abs(&a[i__ + (*ku + i__) * a_dim1]);
+		i__2 = i__ + (*ku + i__) * a_dim1;
+		q__1.r = r__1 * a[i__2].r, q__1.i = r__1 * a[i__2].i;
+		wa.r = q__1.r, wa.i = q__1.i;
+		if (wn == 0.f) {
+		    tau.r = 0.f, tau.i = 0.f;
+		} else {
+		    i__2 = i__ + (*ku + i__) * a_dim1;
+		    q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
+		    wb.r = q__1.r, wb.i = q__1.i;
+		    i__2 = *n - *ku - i__;
+		    c_div(&q__1, &c_b2, &wb);
+		    cscal_(&i__2, &q__1, &a[i__ + (*ku + i__ + 1) * a_dim1], 
+			    lda);
+		    i__2 = i__ + (*ku + i__) * a_dim1;
+		    a[i__2].r = 1.f, a[i__2].i = 0.f;
+		    c_div(&q__1, &wb, &wa);
+		    r__1 = q__1.r;
+		    tau.r = r__1, tau.i = 0.f;
+		}
+
+/*              apply reflection to A(i+1:m,ku+i:n) from the right */
+
+		i__2 = *n - *ku - i__ + 1;
+		clacgv_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+		i__2 = *m - i__;
+		i__3 = *n - *ku - i__ + 1;
+		cgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (*ku 
+			+ i__) * a_dim1], lda, &a[i__ + (*ku + i__) * a_dim1],
+			 lda, &c_b1, &work[1], &c__1);
+		i__2 = *m - i__;
+		i__3 = *n - *ku - i__ + 1;
+		q__1.r = -tau.r, q__1.i = -tau.i;
+		cgerc_(&i__2, &i__3, &q__1, &work[1], &c__1, &a[i__ + (*ku + 
+			i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) * 
+			a_dim1], lda);
+		i__2 = i__ + (*ku + i__) * a_dim1;
+		q__1.r = -wa.r, q__1.i = -wa.i;
+		a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+	    }
+	} else {
+
+/*           annihilate superdiagonal elements first (necessary if */
+/*           KU = 0) */
+
+/* Computing MIN */
+	    i__2 = *n - 1 - *ku;
+	    if (i__ <= f2cmin(i__2,*m)) {
+
+/*              generate reflection to annihilate A(i,ku+i+1:n) */
+
+		i__2 = *n - *ku - i__ + 1;
+		wn = scnrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+		r__1 = wn / c_abs(&a[i__ + (*ku + i__) * a_dim1]);
+		i__2 = i__ + (*ku + i__) * a_dim1;
+		q__1.r = r__1 * a[i__2].r, q__1.i = r__1 * a[i__2].i;
+		wa.r = q__1.r, wa.i = q__1.i;
+		if (wn == 0.f) {
+		    tau.r = 0.f, tau.i = 0.f;
+		} else {
+		    i__2 = i__ + (*ku + i__) * a_dim1;
+		    q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
+		    wb.r = q__1.r, wb.i = q__1.i;
+		    i__2 = *n - *ku - i__;
+		    c_div(&q__1, &c_b2, &wb);
+		    cscal_(&i__2, &q__1, &a[i__ + (*ku + i__ + 1) * a_dim1], 
+			    lda);
+		    i__2 = i__ + (*ku + i__) * a_dim1;
+		    a[i__2].r = 1.f, a[i__2].i = 0.f;
+		    c_div(&q__1, &wb, &wa);
+		    r__1 = q__1.r;
+		    tau.r = r__1, tau.i = 0.f;
+		}
+
+/*              apply reflection to A(i+1:m,ku+i:n) from the right */
+
+		i__2 = *n - *ku - i__ + 1;
+		clacgv_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+		i__2 = *m - i__;
+		i__3 = *n - *ku - i__ + 1;
+		cgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (*ku 
+			+ i__) * a_dim1], lda, &a[i__ + (*ku + i__) * a_dim1],
+			 lda, &c_b1, &work[1], &c__1);
+		i__2 = *m - i__;
+		i__3 = *n - *ku - i__ + 1;
+		q__1.r = -tau.r, q__1.i = -tau.i;
+		cgerc_(&i__2, &i__3, &q__1, &work[1], &c__1, &a[i__ + (*ku + 
+			i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) * 
+			a_dim1], lda);
+		i__2 = i__ + (*ku + i__) * a_dim1;
+		q__1.r = -wa.r, q__1.i = -wa.i;
+		a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+	    }
+
+/* Computing MIN */
+	    i__2 = *m - 1 - *kl;
+	    if (i__ <= f2cmin(i__2,*n)) {
+
+/*              generate reflection to annihilate A(kl+i+1:m,i) */
+
+		i__2 = *m - *kl - i__ + 1;
+		wn = scnrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
+		r__1 = wn / c_abs(&a[*kl + i__ + i__ * a_dim1]);
+		i__2 = *kl + i__ + i__ * a_dim1;
+		q__1.r = r__1 * a[i__2].r, q__1.i = r__1 * a[i__2].i;
+		wa.r = q__1.r, wa.i = q__1.i;
+		if (wn == 0.f) {
+		    tau.r = 0.f, tau.i = 0.f;
+		} else {
+		    i__2 = *kl + i__ + i__ * a_dim1;
+		    q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
+		    wb.r = q__1.r, wb.i = q__1.i;
+		    i__2 = *m - *kl - i__;
+		    c_div(&q__1, &c_b2, &wb);
+		    cscal_(&i__2, &q__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
+			    c__1);
+		    i__2 = *kl + i__ + i__ * a_dim1;
+		    a[i__2].r = 1.f, a[i__2].i = 0.f;
+		    c_div(&q__1, &wb, &wa);
+		    r__1 = q__1.r;
+		    tau.r = r__1, tau.i = 0.f;
+		}
+
+/*              apply reflection to A(kl+i:m,i+1:n) from the left */
+
+		i__2 = *m - *kl - i__ + 1;
+		i__3 = *n - i__;
+		cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*kl + 
+			i__ + (i__ + 1) * a_dim1], lda, &a[*kl + i__ + i__ * 
+			a_dim1], &c__1, &c_b1, &work[1], &c__1);
+		i__2 = *m - *kl - i__ + 1;
+		i__3 = *n - i__;
+		q__1.r = -tau.r, q__1.i = -tau.i;
+		cgerc_(&i__2, &i__3, &q__1, &a[*kl + i__ + i__ * a_dim1], &
+			c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) * 
+			a_dim1], lda);
+		i__2 = *kl + i__ + i__ * a_dim1;
+		q__1.r = -wa.r, q__1.i = -wa.i;
+		a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+	    }
+	}
+
+	if (i__ <= *n) {
+	    i__2 = *m;
+	    for (j = *kl + i__ + 1; j <= i__2; ++j) {
+		i__3 = j + i__ * a_dim1;
+		a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L50: */
+	    }
+	}
+
+	if (i__ <= *m) {
+	    i__2 = *n;
+	    for (j = *ku + i__ + 1; j <= i__2; ++j) {
+		i__3 = i__ + j * a_dim1;
+		a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L60: */
+	    }
+	}
+/* L70: */
+    }
+    return 0;
+
+/*     End of CLAGGE */
+
+} /* clagge_ */
+

lapack-netlib/TESTING/MATGEN/claghe.c

@@ -0,0 +1,741 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__3 = 3;
+static integer c__1 = 1;
+
+/* > \brief \b CLAGHE */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE CLAGHE( N, K, D, A, LDA, ISEED, WORK, INFO ) */
+
+/*       INTEGER            INFO, K, LDA, N */
+/*       INTEGER            ISEED( 4 ) */
+/*       REAL               D( * ) */
+/*       COMPLEX            A( LDA, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > CLAGHE generates a complex hermitian matrix A, by pre- and post- */
+/* > multiplying a real diagonal matrix D with a random unitary matrix: */
+/* > A = U*D*U'. The semi-bandwidth may then be reduced to k by additional */
+/* > unitary transformations. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] K */
+/* > \verbatim */
+/* >          K is INTEGER */
+/* >          The number of nonzero subdiagonals within the band of A. */
+/* >          0 <= K <= N-1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is REAL array, dimension (N) */
+/* >          The diagonal elements of the diagonal matrix D. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] A */
+/* > \verbatim */
+/* >          A is COMPLEX array, dimension (LDA,N) */
+/* >          The generated n by n hermitian matrix A (the full matrix is */
+/* >          stored). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension (4) */
+/* >          On entry, the seed of the random number generator; the array */
+/* >          elements must be between 0 and 4095, and ISEED(4) must be */
+/* >          odd. */
+/* >          On exit, the seed is updated. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is COMPLEX 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 complex_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int claghe_(integer *n, integer *k, real *d__, complex *a, 
+	integer *lda, integer *iseed, complex *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+    real r__1;
+    complex q__1, q__2, q__3, q__4;
+
+    /* Local variables */
+    extern /* Subroutine */ int cher2_(char *, integer *, complex *, complex *
+	    , integer *, complex *, integer *, complex *, integer *);
+    integer i__, j;
+    extern /* Subroutine */ int cgerc_(integer *, integer *, complex *, 
+	    complex *, integer *, complex *, integer *, complex *, integer *);
+    complex alpha;
+    extern /* Subroutine */ int cscal_(integer *, complex *, complex *, 
+	    integer *);
+    extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer 
+	    *, complex *, integer *);
+    extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+	    , complex *, integer *, complex *, integer *, complex *, complex *
+	    , integer *), chemv_(char *, integer *, complex *, 
+	    complex *, integer *, complex *, integer *, complex *, complex *, 
+	    integer *), caxpy_(integer *, complex *, complex *, 
+	    integer *, complex *, integer *);
+    extern real scnrm2_(integer *, complex *, integer *);
+    complex wa, wb;
+    real wn;
+    extern /* Subroutine */ int xerbla_(char *, integer *), clarnv_(
+	    integer *, integer *, integer *, complex *);
+    complex tau;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    --d__;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --iseed;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    if (*n < 0) {
+	*info = -1;
+    } else if (*k < 0 || *k > *n - 1) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    }
+    if (*info < 0) {
+	i__1 = -(*info);
+	xerbla_("CLAGHE", &i__1);
+	return 0;
+    }
+
+/*     initialize lower triangle of A to diagonal matrix */
+
+    i__1 = *n;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *n;
+	for (i__ = j + 1; i__ <= i__2; ++i__) {
+	    i__3 = i__ + j * a_dim1;
+	    a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L10: */
+	}
+/* L20: */
+    }
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	i__2 = i__ + i__ * a_dim1;
+	i__3 = i__;
+	a[i__2].r = d__[i__3], a[i__2].i = 0.f;
+/* L30: */
+    }
+
+/*     Generate lower triangle of hermitian matrix */
+
+    for (i__ = *n - 1; i__ >= 1; --i__) {
+
+/*        generate random reflection */
+
+	i__1 = *n - i__ + 1;
+	clarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+	i__1 = *n - i__ + 1;
+	wn = scnrm2_(&i__1, &work[1], &c__1);
+	r__1 = wn / c_abs(&work[1]);
+	q__1.r = r__1 * work[1].r, q__1.i = r__1 * work[1].i;
+	wa.r = q__1.r, wa.i = q__1.i;
+	if (wn == 0.f) {
+	    tau.r = 0.f, tau.i = 0.f;
+	} else {
+	    q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i;
+	    wb.r = q__1.r, wb.i = q__1.i;
+	    i__1 = *n - i__;
+	    c_div(&q__1, &c_b2, &wb);
+	    cscal_(&i__1, &q__1, &work[2], &c__1);
+	    work[1].r = 1.f, work[1].i = 0.f;
+	    c_div(&q__1, &wb, &wa);
+	    r__1 = q__1.r;
+	    tau.r = r__1, tau.i = 0.f;
+	}
+
+/*        apply random reflection to A(i:n,i:n) from the left */
+/*        and the right */
+
+/*        compute  y := tau * A * u */
+
+	i__1 = *n - i__ + 1;
+	chemv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], &
+		c__1, &c_b1, &work[*n + 1], &c__1);
+
+/*        compute  v := y - 1/2 * tau * ( y, u ) * u */
+
+	q__3.r = -.5f, q__3.i = 0.f;
+	q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i + 
+		q__3.i * tau.r;
+	i__1 = *n - i__ + 1;
+	cdotc_(&q__4, &i__1, &work[*n + 1], &c__1, &work[1], &c__1);
+	q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i 
+		+ q__2.i * q__4.r;
+	alpha.r = q__1.r, alpha.i = q__1.i;
+	i__1 = *n - i__ + 1;
+	caxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
+
+/*        apply the transformation as a rank-2 update to A(i:n,i:n) */
+
+	i__1 = *n - i__ + 1;
+	q__1.r = -1.f, q__1.i = 0.f;
+	cher2_("Lower", &i__1, &q__1, &work[1], &c__1, &work[*n + 1], &c__1, &
+		a[i__ + i__ * a_dim1], lda);
+/* L40: */
+    }
+
+/*     Reduce number of subdiagonals to K */
+
+    i__1 = *n - 1 - *k;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+
+/*        generate reflection to annihilate A(k+i+1:n,i) */
+
+	i__2 = *n - *k - i__ + 1;
+	wn = scnrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
+	r__1 = wn / c_abs(&a[*k + i__ + i__ * a_dim1]);
+	i__2 = *k + i__ + i__ * a_dim1;
+	q__1.r = r__1 * a[i__2].r, q__1.i = r__1 * a[i__2].i;
+	wa.r = q__1.r, wa.i = q__1.i;
+	if (wn == 0.f) {
+	    tau.r = 0.f, tau.i = 0.f;
+	} else {
+	    i__2 = *k + i__ + i__ * a_dim1;
+	    q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
+	    wb.r = q__1.r, wb.i = q__1.i;
+	    i__2 = *n - *k - i__;
+	    c_div(&q__1, &c_b2, &wb);
+	    cscal_(&i__2, &q__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1);
+	    i__2 = *k + i__ + i__ * a_dim1;
+	    a[i__2].r = 1.f, a[i__2].i = 0.f;
+	    c_div(&q__1, &wb, &wa);
+	    r__1 = q__1.r;
+	    tau.r = r__1, tau.i = 0.f;
+	}
+
+/*        apply reflection to A(k+i:n,i+1:k+i-1) from the left */
+
+	i__2 = *n - *k - i__ + 1;
+	i__3 = *k - 1;
+	cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + (i__ 
+		+ 1) * a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &
+		c_b1, &work[1], &c__1);
+	i__2 = *n - *k - i__ + 1;
+	i__3 = *k - 1;
+	q__1.r = -tau.r, q__1.i = -tau.i;
+	cgerc_(&i__2, &i__3, &q__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[
+		1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda);
+
+/*        apply reflection to A(k+i:n,k+i:n) from the left and the right */
+
+/*        compute  y := tau * A * u */
+
+	i__2 = *n - *k - i__ + 1;
+	chemv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda, 
+		&a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &work[1], &c__1);
+
+/*        compute  v := y - 1/2 * tau * ( y, u ) * u */
+
+	q__3.r = -.5f, q__3.i = 0.f;
+	q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i + 
+		q__3.i * tau.r;
+	i__2 = *n - *k - i__ + 1;
+	cdotc_(&q__4, &i__2, &work[1], &c__1, &a[*k + i__ + i__ * a_dim1], &
+		c__1);
+	q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i 
+		+ q__2.i * q__4.r;
+	alpha.r = q__1.r, alpha.i = q__1.i;
+	i__2 = *n - *k - i__ + 1;
+	caxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
+		c__1);
+
+/*        apply hermitian rank-2 update to A(k+i:n,k+i:n) */
+
+	i__2 = *n - *k - i__ + 1;
+	q__1.r = -1.f, q__1.i = 0.f;
+	cher2_("Lower", &i__2, &q__1, &a[*k + i__ + i__ * a_dim1], &c__1, &
+		work[1], &c__1, &a[*k + i__ + (*k + i__) * a_dim1], lda);
+
+	i__2 = *k + i__ + i__ * a_dim1;
+	q__1.r = -wa.r, q__1.i = -wa.i;
+	a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+	i__2 = *n;
+	for (j = *k + i__ + 1; j <= i__2; ++j) {
+	    i__3 = j + i__ * a_dim1;
+	    a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L50: */
+	}
+/* L60: */
+    }
+
+/*     Store full hermitian matrix */
+
+    i__1 = *n;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *n;
+	for (i__ = j + 1; i__ <= i__2; ++i__) {
+	    i__3 = j + i__ * a_dim1;
+	    r_cnjg(&q__1, &a[i__ + j * a_dim1]);
+	    a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L70: */
+	}
+/* L80: */
+    }
+    return 0;
+
+/*     End of CLAGHE */
+
+} /* claghe_ */
+

lapack-netlib/TESTING/MATGEN/clagsy.c

@@ -0,0 +1,794 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__3 = 3;
+static integer c__1 = 1;
+
+/* > \brief \b CLAGSY */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE CLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) */
+
+/*       INTEGER            INFO, K, LDA, N */
+/*       INTEGER            ISEED( 4 ) */
+/*       REAL               D( * ) */
+/*       COMPLEX            A( LDA, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > CLAGSY generates a complex symmetric matrix A, by pre- and post- */
+/* > multiplying a real diagonal matrix D with a random unitary matrix: */
+/* > A = U*D*U**T. The semi-bandwidth may then be reduced to k by */
+/* > additional unitary transformations. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] K */
+/* > \verbatim */
+/* >          K is INTEGER */
+/* >          The number of nonzero subdiagonals within the band of A. */
+/* >          0 <= K <= N-1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is REAL array, dimension (N) */
+/* >          The diagonal elements of the diagonal matrix D. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] A */
+/* > \verbatim */
+/* >          A is COMPLEX array, dimension (LDA,N) */
+/* >          The generated n by n symmetric matrix A (the full matrix is */
+/* >          stored). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension (4) */
+/* >          On entry, the seed of the random number generator; the array */
+/* >          elements must be between 0 and 4095, and ISEED(4) must be */
+/* >          odd. */
+/* >          On exit, the seed is updated. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is COMPLEX 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 complex_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int clagsy_(integer *n, integer *k, real *d__, complex *a, 
+	integer *lda, integer *iseed, complex *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, 
+	    i__9;
+    real r__1;
+    complex q__1, q__2, q__3, q__4;
+
+    /* Local variables */
+    integer i__, j;
+    extern /* Subroutine */ int cgerc_(integer *, integer *, complex *, 
+	    complex *, integer *, complex *, integer *, complex *, integer *);
+    complex alpha;
+    extern /* Subroutine */ int cscal_(integer *, complex *, complex *, 
+	    integer *);
+    extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer 
+	    *, complex *, integer *);
+    extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+	    , complex *, integer *, complex *, integer *, complex *, complex *
+	    , integer *), caxpy_(integer *, complex *, complex *, 
+	    integer *, complex *, integer *), csymv_(char *, integer *, 
+	    complex *, complex *, integer *, complex *, integer *, complex *, 
+	    complex *, integer *);
+    extern real scnrm2_(integer *, complex *, integer *);
+    integer ii, jj;
+    complex wa, wb;
+    extern /* Subroutine */ int clacgv_(integer *, complex *, integer *);
+    real wn;
+    extern /* Subroutine */ int xerbla_(char *, integer *), clarnv_(
+	    integer *, integer *, integer *, complex *);
+    complex tau;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    --d__;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --iseed;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    if (*n < 0) {
+	*info = -1;
+    } else if (*k < 0 || *k > *n - 1) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    }
+    if (*info < 0) {
+	i__1 = -(*info);
+	xerbla_("CLAGSY", &i__1);
+	return 0;
+    }
+
+/*     initialize lower triangle of A to diagonal matrix */
+
+    i__1 = *n;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *n;
+	for (i__ = j + 1; i__ <= i__2; ++i__) {
+	    i__3 = i__ + j * a_dim1;
+	    a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L10: */
+	}
+/* L20: */
+    }
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	i__2 = i__ + i__ * a_dim1;
+	i__3 = i__;
+	a[i__2].r = d__[i__3], a[i__2].i = 0.f;
+/* L30: */
+    }
+
+/*     Generate lower triangle of symmetric matrix */
+
+    for (i__ = *n - 1; i__ >= 1; --i__) {
+
+/*        generate random reflection */
+
+	i__1 = *n - i__ + 1;
+	clarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+	i__1 = *n - i__ + 1;
+	wn = scnrm2_(&i__1, &work[1], &c__1);
+	r__1 = wn / c_abs(&work[1]);
+	q__1.r = r__1 * work[1].r, q__1.i = r__1 * work[1].i;
+	wa.r = q__1.r, wa.i = q__1.i;
+	if (wn == 0.f) {
+	    tau.r = 0.f, tau.i = 0.f;
+	} else {
+	    q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i;
+	    wb.r = q__1.r, wb.i = q__1.i;
+	    i__1 = *n - i__;
+	    c_div(&q__1, &c_b2, &wb);
+	    cscal_(&i__1, &q__1, &work[2], &c__1);
+	    work[1].r = 1.f, work[1].i = 0.f;
+	    c_div(&q__1, &wb, &wa);
+	    r__1 = q__1.r;
+	    tau.r = r__1, tau.i = 0.f;
+	}
+
+/*        apply random reflection to A(i:n,i:n) from the left */
+/*        and the right */
+
+/*        compute  y := tau * A * conjg(u) */
+
+	i__1 = *n - i__ + 1;
+	clacgv_(&i__1, &work[1], &c__1);
+	i__1 = *n - i__ + 1;
+	csymv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], &
+		c__1, &c_b1, &work[*n + 1], &c__1);
+	i__1 = *n - i__ + 1;
+	clacgv_(&i__1, &work[1], &c__1);
+
+/*        compute  v := y - 1/2 * tau * ( u, y ) * u */
+
+	q__3.r = -.5f, q__3.i = 0.f;
+	q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i + 
+		q__3.i * tau.r;
+	i__1 = *n - i__ + 1;
+	cdotc_(&q__4, &i__1, &work[1], &c__1, &work[*n + 1], &c__1);
+	q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i 
+		+ q__2.i * q__4.r;
+	alpha.r = q__1.r, alpha.i = q__1.i;
+	i__1 = *n - i__ + 1;
+	caxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
+
+/*        apply the transformation as a rank-2 update to A(i:n,i:n) */
+
+/*        CALL CSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1, */
+/*        $               A( I, I ), LDA ) */
+
+	i__1 = *n;
+	for (jj = i__; jj <= i__1; ++jj) {
+	    i__2 = *n;
+	    for (ii = jj; ii <= i__2; ++ii) {
+		i__3 = ii + jj * a_dim1;
+		i__4 = ii + jj * a_dim1;
+		i__5 = ii - i__ + 1;
+		i__6 = *n + jj - i__ + 1;
+		q__3.r = work[i__5].r * work[i__6].r - work[i__5].i * work[
+			i__6].i, q__3.i = work[i__5].r * work[i__6].i + work[
+			i__5].i * work[i__6].r;
+		q__2.r = a[i__4].r - q__3.r, q__2.i = a[i__4].i - q__3.i;
+		i__7 = *n + ii - i__ + 1;
+		i__8 = jj - i__ + 1;
+		q__4.r = work[i__7].r * work[i__8].r - work[i__7].i * work[
+			i__8].i, q__4.i = work[i__7].r * work[i__8].i + work[
+			i__7].i * work[i__8].r;
+		q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
+		a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+/* L40: */
+	    }
+/* L50: */
+	}
+/* L60: */
+    }
+
+/*     Reduce number of subdiagonals to K */
+
+    i__1 = *n - 1 - *k;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+
+/*        generate reflection to annihilate A(k+i+1:n,i) */
+
+	i__2 = *n - *k - i__ + 1;
+	wn = scnrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
+	r__1 = wn / c_abs(&a[*k + i__ + i__ * a_dim1]);
+	i__2 = *k + i__ + i__ * a_dim1;
+	q__1.r = r__1 * a[i__2].r, q__1.i = r__1 * a[i__2].i;
+	wa.r = q__1.r, wa.i = q__1.i;
+	if (wn == 0.f) {
+	    tau.r = 0.f, tau.i = 0.f;
+	} else {
+	    i__2 = *k + i__ + i__ * a_dim1;
+	    q__1.r = a[i__2].r + wa.r, q__1.i = a[i__2].i + wa.i;
+	    wb.r = q__1.r, wb.i = q__1.i;
+	    i__2 = *n - *k - i__;
+	    c_div(&q__1, &c_b2, &wb);
+	    cscal_(&i__2, &q__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1);
+	    i__2 = *k + i__ + i__ * a_dim1;
+	    a[i__2].r = 1.f, a[i__2].i = 0.f;
+	    c_div(&q__1, &wb, &wa);
+	    r__1 = q__1.r;
+	    tau.r = r__1, tau.i = 0.f;
+	}
+
+/*        apply reflection to A(k+i:n,i+1:k+i-1) from the left */
+
+	i__2 = *n - *k - i__ + 1;
+	i__3 = *k - 1;
+	cgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + (i__ 
+		+ 1) * a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &
+		c_b1, &work[1], &c__1);
+	i__2 = *n - *k - i__ + 1;
+	i__3 = *k - 1;
+	q__1.r = -tau.r, q__1.i = -tau.i;
+	cgerc_(&i__2, &i__3, &q__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[
+		1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda);
+
+/*        apply reflection to A(k+i:n,k+i:n) from the left and the right */
+
+/*        compute  y := tau * A * conjg(u) */
+
+	i__2 = *n - *k - i__ + 1;
+	clacgv_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
+	i__2 = *n - *k - i__ + 1;
+	csymv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda, 
+		&a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &work[1], &c__1);
+	i__2 = *n - *k - i__ + 1;
+	clacgv_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
+
+/*        compute  v := y - 1/2 * tau * ( u, y ) * u */
+
+	q__3.r = -.5f, q__3.i = 0.f;
+	q__2.r = q__3.r * tau.r - q__3.i * tau.i, q__2.i = q__3.r * tau.i + 
+		q__3.i * tau.r;
+	i__2 = *n - *k - i__ + 1;
+	cdotc_(&q__4, &i__2, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
+		c__1);
+	q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i 
+		+ q__2.i * q__4.r;
+	alpha.r = q__1.r, alpha.i = q__1.i;
+	i__2 = *n - *k - i__ + 1;
+	caxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
+		c__1);
+
+/*        apply symmetric rank-2 update to A(k+i:n,k+i:n) */
+
+/*        CALL CSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1, */
+/*        $               A( K+I, K+I ), LDA ) */
+
+	i__2 = *n;
+	for (jj = *k + i__; jj <= i__2; ++jj) {
+	    i__3 = *n;
+	    for (ii = jj; ii <= i__3; ++ii) {
+		i__4 = ii + jj * a_dim1;
+		i__5 = ii + jj * a_dim1;
+		i__6 = ii + i__ * a_dim1;
+		i__7 = jj - *k - i__ + 1;
+		q__3.r = a[i__6].r * work[i__7].r - a[i__6].i * work[i__7].i, 
+			q__3.i = a[i__6].r * work[i__7].i + a[i__6].i * work[
+			i__7].r;
+		q__2.r = a[i__5].r - q__3.r, q__2.i = a[i__5].i - q__3.i;
+		i__8 = ii - *k - i__ + 1;
+		i__9 = jj + i__ * a_dim1;
+		q__4.r = work[i__8].r * a[i__9].r - work[i__8].i * a[i__9].i, 
+			q__4.i = work[i__8].r * a[i__9].i + work[i__8].i * a[
+			i__9].r;
+		q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
+		a[i__4].r = q__1.r, a[i__4].i = q__1.i;
+/* L70: */
+	    }
+/* L80: */
+	}
+
+	i__2 = *k + i__ + i__ * a_dim1;
+	q__1.r = -wa.r, q__1.i = -wa.i;
+	a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+	i__2 = *n;
+	for (j = *k + i__ + 1; j <= i__2; ++j) {
+	    i__3 = j + i__ * a_dim1;
+	    a[i__3].r = 0.f, a[i__3].i = 0.f;
+/* L90: */
+	}
+/* L100: */
+    }
+
+/*     Store full symmetric matrix */
+
+    i__1 = *n;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *n;
+	for (i__ = j + 1; i__ <= i__2; ++i__) {
+	    i__3 = j + i__ * a_dim1;
+	    i__4 = i__ + j * a_dim1;
+	    a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
+/* L110: */
+	}
+/* L120: */
+    }
+    return 0;
+
+/*     End of CLAGSY */
+
+} /* clagsy_ */
+

lapack-netlib/TESTING/MATGEN/clahilb.c

@@ -0,0 +1,711 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__2 = 2;
+static complex c_b6 = {0.f,0.f};
+
+/* > \brief \b CLAHILB */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE CLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, */
+/*            INFO, PATH) */
+
+/*       INTEGER N, NRHS, LDA, LDX, LDB, INFO */
+/*       REAL WORK(N) */
+/*       COMPLEX A(LDA,N), X(LDX, NRHS), B(LDB, NRHS) */
+/*       CHARACTER*3        PATH */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > CLAHILB generates an N by N scaled Hilbert matrix in A along with */
+/* > NRHS right-hand sides in B and solutions in X such that A*X=B. */
+/* > */
+/* > The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all */
+/* > entries are integers.  The right-hand sides are the first NRHS */
+/* > columns of M * the identity matrix, and the solutions are the */
+/* > first NRHS columns of the inverse Hilbert matrix. */
+/* > */
+/* > The condition number of the Hilbert matrix grows exponentially with */
+/* > its size, roughly as O(e ** (3.5*N)).  Additionally, the inverse */
+/* > Hilbert matrices beyond a relatively small dimension cannot be */
+/* > generated exactly without extra precision.  Precision is exhausted */
+/* > when the largest entry in the inverse Hilbert matrix is greater than */
+/* > 2 to the power of the number of bits in the fraction of the data type */
+/* > used plus one, which is 24 for single precision. */
+/* > */
+/* > In single, the generated solution is exact for N <= 6 and has */
+/* > small componentwise error for 7 <= N <= 11. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The dimension of the matrix A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The requested number of right-hand sides. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] A */
+/* > \verbatim */
+/* >          A is COMPLEX array, dimension (LDA, N) */
+/* >          The generated scaled Hilbert matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] X */
+/* > \verbatim */
+/* >          X is COMPLEX array, dimension (LDX, NRHS) */
+/* >          The generated exact solutions.  Currently, the first NRHS */
+/* >          columns of the inverse Hilbert matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDX */
+/* > \verbatim */
+/* >          LDX is INTEGER */
+/* >          The leading dimension of the array X.  LDX >= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB, NRHS) */
+/* >          The generated right-hand sides.  Currently, the first NRHS */
+/* >          columns of LCM(1, 2, ..., 2*N-1) * the identity matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit */
+/* >          = 1: N is too large; the data is still generated but may not */
+/* >               be not exact. */
+/* >          < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+/* > */
+/* > \param[in] PATH */
+/* > \verbatim */
+/* >          PATH is CHARACTER*3 */
+/* >          The LAPACK path name. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date November 2017 */
+
+/* > \ingroup complex_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int clahilb_(integer *n, integer *nrhs, complex *a, integer *
+	lda, complex *x, integer *ldx, complex *b, integer *ldb, real *work, 
+	integer *info, char *path)
+{
+    /* Initialized data */
+
+    static complex d1[8] = { {-1.f,0.f},{0.f,1.f},{-1.f,-1.f},{0.f,-1.f},{1.f,
+	    0.f},{-1.f,1.f},{1.f,1.f},{1.f,-1.f} };
+    static complex d2[8] = { {-1.f,0.f},{0.f,-1.f},{-1.f,1.f},{0.f,1.f},{1.f,
+	    0.f},{-1.f,-1.f},{1.f,-1.f},{1.f,1.f} };
+    static complex invd1[8] = { {-1.f,0.f},{0.f,-1.f},{-.5f,.5f},{0.f,1.f},{
+	    1.f,0.f},{-.5f,-.5f},{.5f,-.5f},{.5f,.5f} };
+    static complex invd2[8] = { {-1.f,0.f},{0.f,1.f},{-.5f,-.5f},{0.f,-1.f},{
+	    1.f,0.f},{-.5f,.5f},{.5f,.5f},{.5f,-.5f} };
+
+    /* System generated locals */
+    integer a_dim1, a_offset, x_dim1, x_offset, b_dim1, b_offset, i__1, i__2, 
+	    i__3, i__4, i__5;
+    real r__1;
+    complex q__1, q__2;
+
+    /* Local variables */
+    integer i__, j, m, r__;
+    char c2[2];
+    integer ti, tm;
+    extern /* Subroutine */ int claset_(char *, integer *, integer *, complex 
+	    *, complex *, complex *, integer *), xerbla_(char *, 
+	    integer *);
+    extern logical lsamen_(integer *, char *, char *);
+    complex tmp;
+
+
+/*  -- LAPACK test routine (version 3.8.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     November 2017 */
+
+
+/*  ===================================================================== */
+/*     NMAX_EXACT   the largest dimension where the generated data is */
+/*                  exact. */
+/*     NMAX_APPROX  the largest dimension where the generated data has */
+/*                  a small componentwise relative error. */
+/*     ??? complex uses how many bits ??? */
+
+/*     d's are generated from random permutation of those eight elements. */
+    /* Parameter adjustments */
+    --work;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    x_dim1 = *ldx;
+    x_offset = 1 + x_dim1 * 1;
+    x -= x_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+
+    /* Function Body */
+    s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/*     Test the input arguments */
+
+    *info = 0;
+    if (*n < 0 || *n > 11) {
+	*info = -1;
+    } else if (*nrhs < 0) {
+	*info = -2;
+    } else if (*lda < *n) {
+	*info = -4;
+    } else if (*ldx < *n) {
+	*info = -6;
+    } else if (*ldb < *n) {
+	*info = -8;
+    }
+    if (*info < 0) {
+	i__1 = -(*info);
+	xerbla_("CLAHILB", &i__1);
+	return 0;
+    }
+    if (*n > 6) {
+	*info = 1;
+    }
+
+/*     Compute M = the LCM of the integers [1, 2*N-1].  The largest */
+/*     reasonable N is small enough that integers suffice (up to N = 11). */
+    m = 1;
+    i__1 = (*n << 1) - 1;
+    for (i__ = 2; i__ <= i__1; ++i__) {
+	tm = m;
+	ti = i__;
+	r__ = tm % ti;
+	while(r__ != 0) {
+	    tm = ti;
+	    ti = r__;
+	    r__ = tm % ti;
+	}
+	m = m / ti * i__;
+    }
+
+/*     Generate the scaled Hilbert matrix in A */
+/*     If we are testing SY routines, take */
+/*          D1_i = D2_i, else, D1_i = D2_i* */
+    if (lsamen_(&c__2, c2, "SY")) {
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    i__2 = *n;
+	    for (i__ = 1; i__ <= i__2; ++i__) {
+		i__3 = i__ + j * a_dim1;
+		i__4 = j % 8;
+		r__1 = (real) m / (i__ + j - 1);
+		q__2.r = r__1 * d1[i__4].r, q__2.i = r__1 * d1[i__4].i;
+		i__5 = i__ % 8;
+		q__1.r = q__2.r * d1[i__5].r - q__2.i * d1[i__5].i, q__1.i = 
+			q__2.r * d1[i__5].i + q__2.i * d1[i__5].r;
+		a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+	    }
+	}
+    } else {
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    i__2 = *n;
+	    for (i__ = 1; i__ <= i__2; ++i__) {
+		i__3 = i__ + j * a_dim1;
+		i__4 = j % 8;
+		r__1 = (real) m / (i__ + j - 1);
+		q__2.r = r__1 * d1[i__4].r, q__2.i = r__1 * d1[i__4].i;
+		i__5 = i__ % 8;
+		q__1.r = q__2.r * d2[i__5].r - q__2.i * d2[i__5].i, q__1.i = 
+			q__2.r * d2[i__5].i + q__2.i * d2[i__5].r;
+		a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+	    }
+	}
+    }
+
+/*     Generate matrix B as simply the first NRHS columns of M * the */
+/*     identity. */
+    r__1 = (real) m;
+    tmp.r = r__1, tmp.i = 0.f;
+    claset_("Full", n, nrhs, &c_b6, &tmp, &b[b_offset], ldb);
+
+/*     Generate the true solutions in X.  Because B = the first NRHS */
+/*     columns of M*I, the true solutions are just the first NRHS columns */
+/*     of the inverse Hilbert matrix. */
+    work[1] = (real) (*n);
+    i__1 = *n;
+    for (j = 2; j <= i__1; ++j) {
+	work[j] = work[j - 1] / (j - 1) * (j - 1 - *n) / (j - 1) * (*n + j - 
+		1);
+    }
+/*     If we are testing SY routines, */
+/*            take D1_i = D2_i, else, D1_i = D2_i* */
+    if (lsamen_(&c__2, c2, "SY")) {
+	i__1 = *nrhs;
+	for (j = 1; j <= i__1; ++j) {
+	    i__2 = *n;
+	    for (i__ = 1; i__ <= i__2; ++i__) {
+		i__3 = i__ + j * x_dim1;
+		i__4 = j % 8;
+		r__1 = work[i__] * work[j] / (i__ + j - 1);
+		q__2.r = r__1 * invd1[i__4].r, q__2.i = r__1 * invd1[i__4].i;
+		i__5 = i__ % 8;
+		q__1.r = q__2.r * invd1[i__5].r - q__2.i * invd1[i__5].i, 
+			q__1.i = q__2.r * invd1[i__5].i + q__2.i * invd1[i__5]
+			.r;
+		x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+	    }
+	}
+    } else {
+	i__1 = *nrhs;
+	for (j = 1; j <= i__1; ++j) {
+	    i__2 = *n;
+	    for (i__ = 1; i__ <= i__2; ++i__) {
+		i__3 = i__ + j * x_dim1;
+		i__4 = j % 8;
+		r__1 = work[i__] * work[j] / (i__ + j - 1);
+		q__2.r = r__1 * invd2[i__4].r, q__2.i = r__1 * invd2[i__4].i;
+		i__5 = i__ % 8;
+		q__1.r = q__2.r * invd1[i__5].r - q__2.i * invd1[i__5].i, 
+			q__1.i = q__2.r * invd1[i__5].i + q__2.i * invd1[i__5]
+			.r;
+		x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+	    }
+	}
+    }
+    return 0;
+} /* clahilb_ */
+

lapack-netlib/TESTING/MATGEN/clahilb.f

@@ -166,13 +166,6 @@
 *
 *     d's are generated from random permutation of those eight elements.
       COMPLEX D1(8), D2(8), INVD1(8), INVD2(8)
-      DATA D1 /(-1,0),(0,1),(-1,-1),(0,-1),(1,0),(-1,1),(1,1),(1,-1)/
-      DATA D2 /(-1,0),(0,-1),(-1,1),(0,1),(1,0),(-1,-1),(1,-1),(1,1)/
-
-      DATA INVD1 /(-1,0),(0,-1),(-.5,.5),(0,1),(1,0),
-     $     (-.5,-.5),(.5,-.5),(.5,.5)/
-      DATA INVD2 /(-1,0),(0,1),(-.5,-.5),(0,-1),(1,0),
-     $     (-.5,.5),(.5,.5),(.5,-.5)/
 *     ..
 *     .. External Subroutines ..
       EXTERNAL XERBLA
@@ -181,6 +174,14 @@
       EXTERNAL CLASET, LSAMEN
       INTRINSIC REAL
       LOGICAL LSAMEN
+      
+      DATA D1 /(-1,0),(0,1),(-1,-1),(0,-1),(1,0),(-1,1),(1,1),(1,-1)/
+      DATA D2 /(-1,0),(0,-1),(-1,1),(0,1),(1,0),(-1,-1),(1,-1),(1,1)/
+
+      DATA INVD1 /(-1,0),(0,-1),(-.5,.5),(0,1),(1,0),
+     $     (-.5,-.5),(.5,-.5),(.5,.5)/
+      DATA INVD2 /(-1,0),(0,1),(-.5,-.5),(0,-1),(1,0),
+     $     (-.5,.5),(.5,.5),(.5,-.5)/
 *     ..
 *     .. Executable Statements ..
       C2 = PATH( 2: 3 )

lapack-netlib/TESTING/MATGEN/clakf2.c

@@ -0,0 +1,621 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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};
+
+/* > \brief \b CLAKF2 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE CLAKF2( M, N, A, LDA, B, D, E, Z, LDZ ) */
+
+/*       INTEGER            LDA, LDZ, M, N */
+/*       COMPLEX            A( LDA, * ), B( LDA, * ), D( LDA, * ), */
+/*      $                   E( LDA, * ), Z( LDZ, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > Form the 2*M*N by 2*M*N matrix */
+/* > */
+/* >        Z = [ kron(In, A)  -kron(B', Im) ] */
+/* >            [ kron(In, D)  -kron(E', Im) ], */
+/* > */
+/* > where In is the identity matrix of size n and X' is the transpose */
+/* > of X. kron(X, Y) is the Kronecker product between the matrices X */
+/* > and Y. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          Size of matrix, must be >= 1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          Size of matrix, must be >= 1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] A */
+/* > \verbatim */
+/* >          A is COMPLEX, dimension ( LDA, M ) */
+/* >          The matrix A in the output matrix Z. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of A, B, D, and E. ( LDA >= M+N ) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] B */
+/* > \verbatim */
+/* >          B is COMPLEX, dimension ( LDA, N ) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is COMPLEX, dimension ( LDA, M ) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] E */
+/* > \verbatim */
+/* >          E is COMPLEX, dimension ( LDA, N ) */
+/* > */
+/* >          The matrices used in forming the output matrix Z. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Z */
+/* > \verbatim */
+/* >          Z is COMPLEX, dimension ( LDZ, 2*M*N ) */
+/* >          The resultant Kronecker M*N*2 by M*N*2 matrix (see above.) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDZ */
+/* > \verbatim */
+/* >          LDZ is INTEGER */
+/* >          The leading dimension of Z. ( LDZ >= 2*M*N ) */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complex_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int clakf2_(integer *m, integer *n, complex *a, integer *lda,
+	 complex *b, complex *d__, complex *e, complex *z__, integer *ldz)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, d_dim1, d_offset, e_dim1, 
+	    e_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
+    complex q__1;
+
+    /* Local variables */
+    integer i__, j, l, ik, jk, mn;
+    extern /* Subroutine */ int claset_(char *, integer *, integer *, complex 
+	    *, complex *, complex *, integer *);
+    integer mn2;
+
+
+/*  -- 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 */
+
+
+/*  ==================================================================== */
+
+
+/*     Initialize Z */
+
+    /* Parameter adjustments */
+    e_dim1 = *lda;
+    e_offset = 1 + e_dim1 * 1;
+    e -= e_offset;
+    d_dim1 = *lda;
+    d_offset = 1 + d_dim1 * 1;
+    d__ -= d_offset;
+    b_dim1 = *lda;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    z_dim1 = *ldz;
+    z_offset = 1 + z_dim1 * 1;
+    z__ -= z_offset;
+
+    /* Function Body */
+    mn = *m * *n;
+    mn2 = mn << 1;
+    claset_("Full", &mn2, &mn2, &c_b1, &c_b1, &z__[z_offset], ldz);
+
+    ik = 1;
+    i__1 = *n;
+    for (l = 1; l <= i__1; ++l) {
+
+/*        form kron(In, A) */
+
+	i__2 = *m;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    i__3 = *m;
+	    for (j = 1; j <= i__3; ++j) {
+		i__4 = ik + i__ - 1 + (ik + j - 1) * z_dim1;
+		i__5 = i__ + j * a_dim1;
+		z__[i__4].r = a[i__5].r, z__[i__4].i = a[i__5].i;
+/* L10: */
+	    }
+/* L20: */
+	}
+
+/*        form kron(In, D) */
+
+	i__2 = *m;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    i__3 = *m;
+	    for (j = 1; j <= i__3; ++j) {
+		i__4 = ik + mn + i__ - 1 + (ik + j - 1) * z_dim1;
+		i__5 = i__ + j * d_dim1;
+		z__[i__4].r = d__[i__5].r, z__[i__4].i = d__[i__5].i;
+/* L30: */
+	    }
+/* L40: */
+	}
+
+	ik += *m;
+/* L50: */
+    }
+
+    ik = 1;
+    i__1 = *n;
+    for (l = 1; l <= i__1; ++l) {
+	jk = mn + 1;
+
+	i__2 = *n;
+	for (j = 1; j <= i__2; ++j) {
+
+/*           form -kron(B', Im) */
+
+	    i__3 = *m;
+	    for (i__ = 1; i__ <= i__3; ++i__) {
+		i__4 = ik + i__ - 1 + (jk + i__ - 1) * z_dim1;
+		i__5 = j + l * b_dim1;
+		q__1.r = -b[i__5].r, q__1.i = -b[i__5].i;
+		z__[i__4].r = q__1.r, z__[i__4].i = q__1.i;
+/* L60: */
+	    }
+
+/*           form -kron(E', Im) */
+
+	    i__3 = *m;
+	    for (i__ = 1; i__ <= i__3; ++i__) {
+		i__4 = ik + mn + i__ - 1 + (jk + i__ - 1) * z_dim1;
+		i__5 = j + l * e_dim1;
+		q__1.r = -e[i__5].r, q__1.i = -e[i__5].i;
+		z__[i__4].r = q__1.r, z__[i__4].i = q__1.i;
+/* L70: */
+	    }
+
+	    jk += *m;
+/* L80: */
+	}
+
+	ik += *m;
+/* L90: */
+    }
+
+    return 0;
+
+/*     End of CLAKF2 */
+
+} /* clakf2_ */
+

lapack-netlib/TESTING/MATGEN/clarge.c

@@ -0,0 +1,586 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__3 = 3;
+static integer c__1 = 1;
+
+/* > \brief \b CLARGE */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE CLARGE( N, A, LDA, ISEED, WORK, INFO ) */
+
+/*       INTEGER            INFO, LDA, N */
+/*       INTEGER            ISEED( 4 ) */
+/*       COMPLEX            A( LDA, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > CLARGE pre- and post-multiplies a complex general n by n matrix A */
+/* > with a random unitary matrix: A = U*D*U'. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is COMPLEX array, dimension (LDA,N) */
+/* >          On entry, the original n by n matrix A. */
+/* >          On exit, A is overwritten by U*A*U' for some random */
+/* >          unitary matrix U. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension (4) */
+/* >          On entry, the seed of the random number generator; the array */
+/* >          elements must be between 0 and 4095, and ISEED(4) must be */
+/* >          odd. */
+/* >          On exit, the seed is updated. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is COMPLEX 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 complex_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int clarge_(integer *n, complex *a, integer *lda, integer *
+	iseed, complex *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1;
+    real r__1;
+    complex q__1;
+
+    /* Local variables */
+    integer i__;
+    extern /* Subroutine */ int cgerc_(integer *, integer *, complex *, 
+	    complex *, integer *, complex *, integer *, complex *, integer *),
+	     cscal_(integer *, complex *, complex *, integer *), cgemv_(char *
+	    , integer *, integer *, complex *, complex *, integer *, complex *
+	    , integer *, complex *, complex *, integer *);
+    extern real scnrm2_(integer *, complex *, integer *);
+    complex wa, wb;
+    real wn;
+    extern /* Subroutine */ int xerbla_(char *, integer *), clarnv_(
+	    integer *, integer *, integer *, complex *);
+    complex tau;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --iseed;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    if (*n < 0) {
+	*info = -1;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -3;
+    }
+    if (*info < 0) {
+	i__1 = -(*info);
+	xerbla_("CLARGE", &i__1);
+	return 0;
+    }
+
+/*     pre- and post-multiply A by random unitary matrix */
+
+    for (i__ = *n; i__ >= 1; --i__) {
+
+/*        generate random reflection */
+
+	i__1 = *n - i__ + 1;
+	clarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+	i__1 = *n - i__ + 1;
+	wn = scnrm2_(&i__1, &work[1], &c__1);
+	r__1 = wn / c_abs(&work[1]);
+	q__1.r = r__1 * work[1].r, q__1.i = r__1 * work[1].i;
+	wa.r = q__1.r, wa.i = q__1.i;
+	if (wn == 0.f) {
+	    tau.r = 0.f, tau.i = 0.f;
+	} else {
+	    q__1.r = work[1].r + wa.r, q__1.i = work[1].i + wa.i;
+	    wb.r = q__1.r, wb.i = q__1.i;
+	    i__1 = *n - i__;
+	    c_div(&q__1, &c_b2, &wb);
+	    cscal_(&i__1, &q__1, &work[2], &c__1);
+	    work[1].r = 1.f, work[1].i = 0.f;
+	    c_div(&q__1, &wb, &wa);
+	    r__1 = q__1.r;
+	    tau.r = r__1, tau.i = 0.f;
+	}
+
+/*        multiply A(i:n,1:n) by random reflection from the left */
+
+	i__1 = *n - i__ + 1;
+	cgemv_("Conjugate transpose", &i__1, n, &c_b2, &a[i__ + a_dim1], lda, 
+		&work[1], &c__1, &c_b1, &work[*n + 1], &c__1);
+	i__1 = *n - i__ + 1;
+	q__1.r = -tau.r, q__1.i = -tau.i;
+	cgerc_(&i__1, n, &q__1, &work[1], &c__1, &work[*n + 1], &c__1, &a[i__ 
+		+ a_dim1], lda);
+
+/*        multiply A(1:n,i:n) by random reflection from the right */
+
+	i__1 = *n - i__ + 1;
+	cgemv_("No transpose", n, &i__1, &c_b2, &a[i__ * a_dim1 + 1], lda, &
+		work[1], &c__1, &c_b1, &work[*n + 1], &c__1);
+	i__1 = *n - i__ + 1;
+	q__1.r = -tau.r, q__1.i = -tau.i;
+	cgerc_(n, &i__1, &q__1, &work[*n + 1], &c__1, &work[1], &c__1, &a[i__ 
+		* a_dim1 + 1], lda);
+/* L10: */
+    }
+    return 0;
+
+/*     End of CLARGE */
+
+} /* clarge_ */
+

lapack-netlib/TESTING/MATGEN/clarnd.c

@@ -0,0 +1,540 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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)
+*/
+
+
+
+/* > \brief \b CLARND */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       COMPLEX FUNCTION CLARND( IDIST, ISEED ) */
+
+/*       INTEGER            IDIST */
+/*       INTEGER            ISEED( 4 ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > CLARND returns a random complex number from a uniform or normal */
+/* > distribution. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] IDIST */
+/* > \verbatim */
+/* >          IDIST is INTEGER */
+/* >          Specifies the distribution of the random numbers: */
+/* >          = 1:  real and imaginary parts each uniform (0,1) */
+/* >          = 2:  real and imaginary parts each uniform (-1,1) */
+/* >          = 3:  real and imaginary parts each normal (0,1) */
+/* >          = 4:  uniformly distributed on the disc abs(z) <= 1 */
+/* >          = 5:  uniformly distributed on the circle abs(z) = 1 */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension (4) */
+/* >          On entry, the seed of the random number generator; the array */
+/* >          elements must be between 0 and 4095, and ISEED(4) must be */
+/* >          odd. */
+/* >          On exit, the seed is updated. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complex_matgen */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  This routine calls the auxiliary routine SLARAN to generate a random */
+/* >  real number from a uniform (0,1) distribution. The Box-Muller method */
+/* >  is used to transform numbers from a uniform to a normal distribution. */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+///* Complex */ VOID clarnd_(complex * ret_val, integer *idist, integer *iseed)
+ complex clarnd_(integer *idist, integer *iseed)
+{
+    /* System generated locals */
+    real r__1, r__2;
+    complex q__1, q__2, q__3;
+    complex *ret_val =(complex*)malloc(sizeof(complex));
+
+    /* Local variables */
+    real t1, t2;
+    extern real slaran_(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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Generate a pair of real random numbers from a uniform (0,1) */
+/*     distribution */
+
+    /* Parameter adjustments */
+    --iseed;
+
+    /* Function Body */
+    t1 = slaran_(&iseed[1]);
+    t2 = slaran_(&iseed[1]);
+
+    if (*idist == 1) {
+
+/*        real and imaginary parts each uniform (0,1) */
+
+	q__1.r = t1, q__1.i = t2;
+	 ret_val->r = q__1.r,  ret_val->i = q__1.i;
+    } else if (*idist == 2) {
+
+/*        real and imaginary parts each uniform (-1,1) */
+
+	r__1 = t1 * 2.f - 1.f;
+	r__2 = t2 * 2.f - 1.f;
+	q__1.r = r__1, q__1.i = r__2;
+	 ret_val->r = q__1.r,  ret_val->i = q__1.i;
+    } else if (*idist == 3) {
+
+/*        real and imaginary parts each normal (0,1) */
+
+	r__1 = sqrt(log(t1) * -2.f);
+	r__2 = t2 * 6.2831853071795864769252867663f;
+	q__3.r = 0.f, q__3.i = r__2;
+	c_exp(&q__2, &q__3);
+	q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+	 ret_val->r = q__1.r,  ret_val->i = q__1.i;
+    } else if (*idist == 4) {
+
+/*        uniform distribution on the unit disc abs(z) <= 1 */
+
+	r__1 = sqrt(t1);
+	r__2 = t2 * 6.2831853071795864769252867663f;
+	q__3.r = 0.f, q__3.i = r__2;
+	c_exp(&q__2, &q__3);
+	q__1.r = r__1 * q__2.r, q__1.i = r__1 * q__2.i;
+	 ret_val->r = q__1.r,  ret_val->i = q__1.i;
+    } else if (*idist == 5) {
+
+/*        uniform distribution on the unit circle abs(z) = 1 */
+
+	r__1 = t2 * 6.2831853071795864769252867663f;
+	q__2.r = 0.f, q__2.i = r__1;
+	c_exp(&q__1, &q__2);
+	 ret_val->r = q__1.r,  ret_val->i = q__1.i;
+    }
+    return *ret_val;
+
+/*     End of CLARND */
+
+} /* clarnd_ */
+

lapack-netlib/TESTING/MATGEN/claror.c

@@ -0,0 +1,783 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__3 = 3;
+static integer c__1 = 1;
+
+/* > \brief \b CLAROR */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE CLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO ) */
+
+/*       CHARACTER          INIT, SIDE */
+/*       INTEGER            INFO, LDA, M, N */
+/*       INTEGER            ISEED( 4 ) */
+/*       COMPLEX            A( LDA, * ), X( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* >    CLAROR pre- or post-multiplies an M by N matrix A by a random */
+/* >    unitary matrix U, overwriting A. A may optionally be */
+/* >    initialized to the identity matrix before multiplying by U. */
+/* >    U is generated using the method of G.W. Stewart */
+/* >    ( SIAM J. Numer. Anal. 17, 1980, pp. 403-409 ). */
+/* >    (BLAS-2 version) */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] SIDE */
+/* > \verbatim */
+/* >          SIDE is CHARACTER*1 */
+/* >           SIDE specifies whether A is multiplied on the left or right */
+/* >           by U. */
+/* >       SIDE = 'L'   Multiply A on the left (premultiply) by U */
+/* >       SIDE = 'R'   Multiply A on the right (postmultiply) by UC>       SIDE = 'C'   Multiply A on the lef
+t by U and the right by UC>       SIDE = 'T'   Multiply A on the left by U and the right by U' */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] INIT */
+/* > \verbatim */
+/* >          INIT is CHARACTER*1 */
+/* >           INIT specifies whether or not A should be initialized to */
+/* >           the identity matrix. */
+/* >              INIT = 'I'   Initialize A to (a section of) the */
+/* >                           identity matrix before applying U. */
+/* >              INIT = 'N'   No initialization.  Apply U to the */
+/* >                           input matrix A. */
+/* > */
+/* >           INIT = 'I' may be used to generate square (i.e., unitary) */
+/* >           or rectangular orthogonal matrices (orthogonality being */
+/* >           in the sense of CDOTC): */
+/* > */
+/* >           For square matrices, M=N, and SIDE many be either 'L' or */
+/* >           'R'; the rows will be orthogonal to each other, as will the */
+/* >           columns. */
+/* >           For rectangular matrices where M < N, SIDE = 'R' will */
+/* >           produce a dense matrix whose rows will be orthogonal and */
+/* >           whose columns will not, while SIDE = 'L' will produce a */
+/* >           matrix whose rows will be orthogonal, and whose first M */
+/* >           columns will be orthogonal, the remaining columns being */
+/* >           zero. */
+/* >           For matrices where M > N, just use the previous */
+/* >           explanation, interchanging 'L' and 'R' and "rows" and */
+/* >           "columns". */
+/* > */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >           Number of rows of A. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >           Number of columns of A. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is COMPLEX array, dimension ( LDA, N ) */
+/* >           Input and output array. Overwritten by U A ( if SIDE = 'L' ) */
+/* >           or by A U ( if SIDE = 'R' ) */
+/* >           or by U A U* ( if SIDE = 'C') */
+/* >           or by U A U' ( if SIDE = 'T') on exit. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >           Leading dimension of A. Must be at least MAX ( 1, M ). */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension ( 4 ) */
+/* >           On entry ISEED specifies the seed of the random number */
+/* >           generator. The array elements should be between 0 and 4095; */
+/* >           if not they will be reduced mod 4096.  Also, ISEED(4) must */
+/* >           be odd.  The random number generator uses a linear */
+/* >           congruential sequence limited to small integers, and so */
+/* >           should produce machine independent random numbers. The */
+/* >           values of ISEED are changed on exit, and can be used in the */
+/* >           next call to CLAROR to continue the same random number */
+/* >           sequence. */
+/* >           Modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] X */
+/* > \verbatim */
+/* >          X is COMPLEX array, dimension ( 3*MAX( M, N ) ) */
+/* >           Workspace. Of length: */
+/* >               2*M + N if SIDE = 'L', */
+/* >               2*N + M if SIDE = 'R', */
+/* >               3*N     if SIDE = 'C' or 'T'. */
+/* >           Modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >           An error flag.  It is set to: */
+/* >            0  if no error. */
+/* >            1  if CLARND returned a bad random number (installation */
+/* >               problem) */
+/* >           -1  if SIDE is not L, R, C, or T. */
+/* >           -3  if M is negative. */
+/* >           -4  if N is negative or if SIDE is C or T and N is not equal */
+/* >               to M. */
+/* >           -6  if LDA is less than M. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complex_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int claror_(char *side, char *init, integer *m, integer *n, 
+	complex *a, integer *lda, integer *iseed, complex *x, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+    complex q__1, q__2;
+
+    /* Local variables */
+    integer kbeg, jcol;
+    real xabs;
+    integer irow, j;
+    extern /* Subroutine */ int cgerc_(integer *, integer *, complex *, 
+	    complex *, integer *, complex *, integer *, complex *, integer *),
+	     cscal_(integer *, complex *, complex *, integer *);
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
+	    , complex *, integer *, complex *, integer *, complex *, complex *
+	    , integer *);
+    complex csign;
+    integer ixfrm, itype, nxfrm;
+    real xnorm;
+    extern real scnrm2_(integer *, complex *, integer *);
+    extern /* Subroutine */ int clacgv_(integer *, complex *, integer *);
+    //extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+    extern complex clarnd_(integer *, integer *);
+    extern /* Subroutine */ int claset_(char *, integer *, integer *, complex 
+	    *, complex *, complex *, integer *), xerbla_(char *, 
+	    integer *);
+    real factor;
+    complex xnorms;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --iseed;
+    --x;
+
+    /* Function Body */
+    *info = 0;
+    if (*n == 0 || *m == 0) {
+	return 0;
+    }
+
+    itype = 0;
+    if (lsame_(side, "L")) {
+	itype = 1;
+    } else if (lsame_(side, "R")) {
+	itype = 2;
+    } else if (lsame_(side, "C")) {
+	itype = 3;
+    } else if (lsame_(side, "T")) {
+	itype = 4;
+    }
+
+/*     Check for argument errors. */
+
+    if (itype == 0) {
+	*info = -1;
+    } else if (*m < 0) {
+	*info = -3;
+    } else if (*n < 0 || itype == 3 && *n != *m) {
+	*info = -4;
+    } else if (*lda < *m) {
+	*info = -6;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("CLAROR", &i__1);
+	return 0;
+    }
+
+    if (itype == 1) {
+	nxfrm = *m;
+    } else {
+	nxfrm = *n;
+    }
+
+/*     Initialize A to the identity matrix if desired */
+
+    if (lsame_(init, "I")) {
+	claset_("Full", m, n, &c_b1, &c_b2, &a[a_offset], lda);
+    }
+
+/*     If no rotation possible, still multiply by */
+/*     a random complex number from the circle |x| = 1 */
+
+/*      2)      Compute Rotation by computing Householder */
+/*              Transformations H(2), H(3), ..., H(n).  Note that the */
+/*              order in which they are computed is irrelevant. */
+
+    i__1 = nxfrm;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = j;
+	x[i__2].r = 0.f, x[i__2].i = 0.f;
+/* L40: */
+    }
+
+    i__1 = nxfrm;
+    for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) {
+	kbeg = nxfrm - ixfrm + 1;
+
+/*        Generate independent normal( 0, 1 ) random numbers */
+
+	i__2 = nxfrm;
+	for (j = kbeg; j <= i__2; ++j) {
+	    i__3 = j;
+	    //clarnd_(&q__1, &c__3, &iseed[1]);
+	    q__1=clarnd_(&c__3, &iseed[1]);
+	    x[i__3].r = q__1.r, x[i__3].i = q__1.i;
+/* L50: */
+	}
+
+/*        Generate a Householder transformation from the random vector X */
+
+	xnorm = scnrm2_(&ixfrm, &x[kbeg], &c__1);
+	xabs = c_abs(&x[kbeg]);
+	if (xabs != 0.f) {
+	    i__2 = kbeg;
+	    q__1.r = x[i__2].r / xabs, q__1.i = x[i__2].i / xabs;
+	    csign.r = q__1.r, csign.i = q__1.i;
+	} else {
+	    csign.r = 1.f, csign.i = 0.f;
+	}
+	q__1.r = xnorm * csign.r, q__1.i = xnorm * csign.i;
+	xnorms.r = q__1.r, xnorms.i = q__1.i;
+	i__2 = nxfrm + kbeg;
+	q__1.r = -csign.r, q__1.i = -csign.i;
+	x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+	factor = xnorm * (xnorm + xabs);
+	if (abs(factor) < 1e-20f) {
+	    *info = 1;
+	    i__2 = -(*info);
+	    xerbla_("CLAROR", &i__2);
+	    return 0;
+	} else {
+	    factor = 1.f / factor;
+	}
+	i__2 = kbeg;
+	i__3 = kbeg;
+	q__1.r = x[i__3].r + xnorms.r, q__1.i = x[i__3].i + xnorms.i;
+	x[i__2].r = q__1.r, x[i__2].i = q__1.i;
+
+/*        Apply Householder transformation to A */
+
+	if (itype == 1 || itype == 3 || itype == 4) {
+
+/*           Apply H(k) on the left of A */
+
+	    cgemv_("C", &ixfrm, n, &c_b2, &a[kbeg + a_dim1], lda, &x[kbeg], &
+		    c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1);
+	    q__2.r = factor, q__2.i = 0.f;
+	    q__1.r = -q__2.r, q__1.i = -q__2.i;
+	    cgerc_(&ixfrm, n, &q__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], &
+		    c__1, &a[kbeg + a_dim1], lda);
+
+	}
+
+	if (itype >= 2 && itype <= 4) {
+
+/*           Apply H(k)* (or H(k)') on the right of A */
+
+	    if (itype == 4) {
+		clacgv_(&ixfrm, &x[kbeg], &c__1);
+	    }
+
+	    cgemv_("N", m, &ixfrm, &c_b2, &a[kbeg * a_dim1 + 1], lda, &x[kbeg]
+		    , &c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1);
+	    q__2.r = factor, q__2.i = 0.f;
+	    q__1.r = -q__2.r, q__1.i = -q__2.i;
+	    cgerc_(m, &ixfrm, &q__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], &
+		    c__1, &a[kbeg * a_dim1 + 1], lda);
+
+	}
+/* L60: */
+    }
+
+    //clarnd_(&q__1, &c__3, &iseed[1]);
+    q__1=clarnd_(&c__3, &iseed[1]);
+    x[1].r = q__1.r, x[1].i = q__1.i;
+    xabs = c_abs(&x[1]);
+    if (xabs != 0.f) {
+	q__1.r = x[1].r / xabs, q__1.i = x[1].i / xabs;
+	csign.r = q__1.r, csign.i = q__1.i;
+    } else {
+	csign.r = 1.f, csign.i = 0.f;
+    }
+    i__1 = nxfrm << 1;
+    x[i__1].r = csign.r, x[i__1].i = csign.i;
+
+/*     Scale the matrix A by D. */
+
+    if (itype == 1 || itype == 3 || itype == 4) {
+	i__1 = *m;
+	for (irow = 1; irow <= i__1; ++irow) {
+	    r_cnjg(&q__1, &x[nxfrm + irow]);
+	    cscal_(n, &q__1, &a[irow + a_dim1], lda);
+/* L70: */
+	}
+    }
+
+    if (itype == 2 || itype == 3) {
+	i__1 = *n;
+	for (jcol = 1; jcol <= i__1; ++jcol) {
+	    cscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1);
+/* L80: */
+	}
+    }
+
+    if (itype == 4) {
+	i__1 = *n;
+	for (jcol = 1; jcol <= i__1; ++jcol) {
+	    r_cnjg(&q__1, &x[nxfrm + jcol]);
+	    cscal_(m, &q__1, &a[jcol * a_dim1 + 1], &c__1);
+/* L90: */
+	}
+    }
+    return 0;
+
+/*     End of CLAROR */
+
+} /* claror_ */
+

lapack-netlib/TESTING/MATGEN/clarot.c

@@ -0,0 +1,771 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__4 = 4;
+static integer c__8 = 8;
+
+/* > \brief \b CLAROT */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE CLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, */
+/*                          XRIGHT ) */
+
+/*       LOGICAL            LLEFT, LRIGHT, LROWS */
+/*       INTEGER            LDA, NL */
+/*       COMPLEX            C, S, XLEFT, XRIGHT */
+/*       COMPLEX            A( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* >    CLAROT applies a (Givens) rotation to two adjacent rows or */
+/* >    columns, where one element of the first and/or last column/row */
+/* >    for use on matrices stored in some format other than GE, so */
+/* >    that elements of the matrix may be used or modified for which */
+/* >    no array element is provided. */
+/* > */
+/* >    One example is a symmetric matrix in SB format (bandwidth=4), for */
+/* >    which UPLO='L':  Two adjacent rows will have the format: */
+/* > */
+/* >    row j:     C> C> C> C> C> .  .  .  . */
+/* >    row j+1:      C> C> C> C> C> .  .  .  . */
+/* > */
+/* >    '*' indicates elements for which storage is provided, */
+/* >    '.' indicates elements for which no storage is provided, but */
+/* >    are not necessarily zero; their values are determined by */
+/* >    symmetry.  ' ' indicates elements which are necessarily zero, */
+/* >     and have no storage provided. */
+/* > */
+/* >    Those columns which have two '*'s can be handled by SROT. */
+/* >    Those columns which have no '*'s can be ignored, since as long */
+/* >    as the Givens rotations are carefully applied to preserve */
+/* >    symmetry, their values are determined. */
+/* >    Those columns which have one '*' have to be handled separately, */
+/* >    by using separate variables "p" and "q": */
+/* > */
+/* >    row j:     C> C> C> C> C> p  .  .  . */
+/* >    row j+1:   q  C> C> C> C> C> .  .  .  . */
+/* > */
+/* >    The element p would have to be set correctly, then that column */
+/* >    is rotated, setting p to its new value.  The next call to */
+/* >    CLAROT would rotate columns j and j+1, using p, and restore */
+/* >    symmetry.  The element q would start out being zero, and be */
+/* >    made non-zero by the rotation.  Later, rotations would presumably */
+/* >    be chosen to zero q out. */
+/* > */
+/* >    Typical Calling Sequences: rotating the i-th and (i+1)-st rows. */
+/* >    ------- ------- --------- */
+/* > */
+/* >      General dense matrix: */
+/* > */
+/* >              CALL CLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S, */
+/* >                      A(i,1),LDA, DUMMY, DUMMY) */
+/* > */
+/* >      General banded matrix in GB format: */
+/* > */
+/* >              j = MAX(1, i-KL ) */
+/* >              NL = MIN( N, i+KU+1 ) + 1-j */
+/* >              CALL CLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S, */
+/* >                      A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT ) */
+/* > */
+/* >              [ note that i+1-j is just MIN(i,KL+1) ] */
+/* > */
+/* >      Symmetric banded matrix in SY format, bandwidth K, */
+/* >      lower triangle only: */
+/* > */
+/* >              j = MAX(1, i-K ) */
+/* >              NL = MIN( K+1, i ) + 1 */
+/* >              CALL CLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S, */
+/* >                      A(i,j), LDA, XLEFT, XRIGHT ) */
+/* > */
+/* >      Same, but upper triangle only: */
+/* > */
+/* >              NL = MIN( K+1, N-i ) + 1 */
+/* >              CALL CLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S, */
+/* >                      A(i,i), LDA, XLEFT, XRIGHT ) */
+/* > */
+/* >      Symmetric banded matrix in SB format, bandwidth K, */
+/* >      lower triangle only: */
+/* > */
+/* >              [ same as for SY, except:] */
+/* >                  . . . . */
+/* >                      A(i+1-j,j), LDA-1, XLEFT, XRIGHT ) */
+/* > */
+/* >              [ note that i+1-j is just MIN(i,K+1) ] */
+/* > */
+/* >      Same, but upper triangle only: */
+/* >                  . . . */
+/* >                      A(K+1,i), LDA-1, XLEFT, XRIGHT ) */
+/* > */
+/* >      Rotating columns is just the transpose of rotating rows, except */
+/* >      for GB and SB: (rotating columns i and i+1) */
+/* > */
+/* >      GB: */
+/* >              j = MAX(1, i-KU ) */
+/* >              NL = MIN( N, i+KL+1 ) + 1-j */
+/* >              CALL CLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S, */
+/* >                      A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM ) */
+/* > */
+/* >              [note that KU+j+1-i is just MAX(1,KU+2-i)] */
+/* > */
+/* >      SB: (upper triangle) */
+/* > */
+/* >                   . . . . . . */
+/* >                      A(K+j+1-i,i),LDA-1, XTOP, XBOTTM ) */
+/* > */
+/* >      SB: (lower triangle) */
+/* > */
+/* >                   . . . . . . */
+/* >                      A(1,i),LDA-1, XTOP, XBOTTM ) */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \verbatim */
+/* >  LROWS  - LOGICAL */
+/* >           If .TRUE., then CLAROT will rotate two rows.  If .FALSE., */
+/* >           then it will rotate two columns. */
+/* >           Not modified. */
+/* > */
+/* >  LLEFT  - LOGICAL */
+/* >           If .TRUE., then XLEFT will be used instead of the */
+/* >           corresponding element of A for the first element in the */
+/* >           second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) */
+/* >           If .FALSE., then the corresponding element of A will be */
+/* >           used. */
+/* >           Not modified. */
+/* > */
+/* >  LRIGHT - LOGICAL */
+/* >           If .TRUE., then XRIGHT will be used instead of the */
+/* >           corresponding element of A for the last element in the */
+/* >           first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If */
+/* >           .FALSE., then the corresponding element of A will be used. */
+/* >           Not modified. */
+/* > */
+/* >  NL     - INTEGER */
+/* >           The length of the rows (if LROWS=.TRUE.) or columns (if */
+/* >           LROWS=.FALSE.) to be rotated.  If XLEFT and/or XRIGHT are */
+/* >           used, the columns/rows they are in should be included in */
+/* >           NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at */
+/* >           least 2.  The number of rows/columns to be rotated */
+/* >           exclusive of those involving XLEFT and/or XRIGHT may */
+/* >           not be negative, i.e., NL minus how many of LLEFT and */
+/* >           LRIGHT are .TRUE. must be at least zero; if not, XERBLA */
+/* >           will be called. */
+/* >           Not modified. */
+/* > */
+/* >  C, S   - COMPLEX */
+/* >           Specify the Givens rotation to be applied.  If LROWS is */
+/* >           true, then the matrix ( c  s ) */
+/* >                                 ( _  _ ) */
+/* >                                 (-s  c )  is applied from the left; */
+/* >           if false, then the transpose (not conjugated) thereof is */
+/* >           applied from the right.  Note that in contrast to the */
+/* >           output of CROTG or to most versions of CROT, both C and S */
+/* >           are complex.  For a Givens rotation, |C|**2 + |S|**2 should */
+/* >           be 1, but this is not checked. */
+/* >           Not modified. */
+/* > */
+/* >  A      - COMPLEX array. */
+/* >           The array containing the rows/columns to be rotated.  The */
+/* >           first element of A should be the upper left element to */
+/* >           be rotated. */
+/* >           Read and modified. */
+/* > */
+/* >  LDA    - INTEGER */
+/* >           The "effective" leading dimension of A.  If A contains */
+/* >           a matrix stored in GE, HE, or SY format, then this is just */
+/* >           the leading dimension of A as dimensioned in the calling */
+/* >           routine.  If A contains a matrix stored in band (GB, HB, or */
+/* >           SB) format, then this should be *one less* than the leading */
+/* >           dimension used in the calling routine.  Thus, if A were */
+/* >           dimensioned A(LDA,*) in CLAROT, then A(1,j) would be the */
+/* >           j-th element in the first of the two rows to be rotated, */
+/* >           and A(2,j) would be the j-th in the second, regardless of */
+/* >           how the array may be stored in the calling routine.  [A */
+/* >           cannot, however, actually be dimensioned thus, since for */
+/* >           band format, the row number may exceed LDA, which is not */
+/* >           legal FORTRAN.] */
+/* >           If LROWS=.TRUE., then LDA must be at least 1, otherwise */
+/* >           it must be at least NL minus the number of .TRUE. values */
+/* >           in XLEFT and XRIGHT. */
+/* >           Not modified. */
+/* > */
+/* >  XLEFT  - COMPLEX */
+/* >           If LLEFT is .TRUE., then XLEFT will be used and modified */
+/* >           instead of A(2,1) (if LROWS=.TRUE.) or A(1,2) */
+/* >           (if LROWS=.FALSE.). */
+/* >           Read and modified. */
+/* > */
+/* >  XRIGHT - COMPLEX */
+/* >           If LRIGHT is .TRUE., then XRIGHT will be used and modified */
+/* >           instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1) */
+/* >           (if LROWS=.FALSE.). */
+/* >           Read and modified. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complex_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int clarot_(logical *lrows, logical *lleft, logical *lright, 
+	integer *nl, complex *c__, complex *s, complex *a, integer *lda, 
+	complex *xleft, complex *xright)
+{
+    /* System generated locals */
+    integer i__1, i__2, i__3, i__4;
+    complex q__1, q__2, q__3, q__4, q__5, q__6;
+
+    /* Local variables */
+    integer iinc, j, inext;
+    complex tempx;
+    integer ix, iy, nt;
+    complex xt[2], yt[2];
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    integer iyt;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Set up indices, arrays for ends */
+
+    /* Parameter adjustments */
+    --a;
+
+    /* Function Body */
+    if (*lrows) {
+	iinc = *lda;
+	inext = 1;
+    } else {
+	iinc = 1;
+	inext = *lda;
+    }
+
+    if (*lleft) {
+	nt = 1;
+	ix = iinc + 1;
+	iy = *lda + 2;
+	xt[0].r = a[1].r, xt[0].i = a[1].i;
+	yt[0].r = xleft->r, yt[0].i = xleft->i;
+    } else {
+	nt = 0;
+	ix = 1;
+	iy = inext + 1;
+    }
+
+    if (*lright) {
+	iyt = inext + 1 + (*nl - 1) * iinc;
+	++nt;
+	i__1 = nt - 1;
+	xt[i__1].r = xright->r, xt[i__1].i = xright->i;
+	i__1 = nt - 1;
+	i__2 = iyt;
+	yt[i__1].r = a[i__2].r, yt[i__1].i = a[i__2].i;
+    }
+
+/*     Check for errors */
+
+    if (*nl < nt) {
+	xerbla_("CLAROT", &c__4);
+	return 0;
+    }
+    if (*lda <= 0 || ! (*lrows) && *lda < *nl - nt) {
+	xerbla_("CLAROT", &c__8);
+	return 0;
+    }
+
+/*     Rotate */
+
+/*     CROT( NL-NT, A(IX),IINC, A(IY),IINC, C, S ) with complex C, S */
+
+    i__1 = *nl - nt - 1;
+    for (j = 0; j <= i__1; ++j) {
+	i__2 = ix + j * iinc;
+	q__2.r = c__->r * a[i__2].r - c__->i * a[i__2].i, q__2.i = c__->r * a[
+		i__2].i + c__->i * a[i__2].r;
+	i__3 = iy + j * iinc;
+	q__3.r = s->r * a[i__3].r - s->i * a[i__3].i, q__3.i = s->r * a[i__3]
+		.i + s->i * a[i__3].r;
+	q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+	tempx.r = q__1.r, tempx.i = q__1.i;
+	i__2 = iy + j * iinc;
+	r_cnjg(&q__4, s);
+	q__3.r = -q__4.r, q__3.i = -q__4.i;
+	i__3 = ix + j * iinc;
+	q__2.r = q__3.r * a[i__3].r - q__3.i * a[i__3].i, q__2.i = q__3.r * a[
+		i__3].i + q__3.i * a[i__3].r;
+	r_cnjg(&q__6, c__);
+	i__4 = iy + j * iinc;
+	q__5.r = q__6.r * a[i__4].r - q__6.i * a[i__4].i, q__5.i = q__6.r * a[
+		i__4].i + q__6.i * a[i__4].r;
+	q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+	a[i__2].r = q__1.r, a[i__2].i = q__1.i;
+	i__2 = ix + j * iinc;
+	a[i__2].r = tempx.r, a[i__2].i = tempx.i;
+/* L10: */
+    }
+
+/*     CROT( NT, XT,1, YT,1, C, S ) with complex C, S */
+
+    i__1 = nt;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = j - 1;
+	q__2.r = c__->r * xt[i__2].r - c__->i * xt[i__2].i, q__2.i = c__->r * 
+		xt[i__2].i + c__->i * xt[i__2].r;
+	i__3 = j - 1;
+	q__3.r = s->r * yt[i__3].r - s->i * yt[i__3].i, q__3.i = s->r * yt[
+		i__3].i + s->i * yt[i__3].r;
+	q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+	tempx.r = q__1.r, tempx.i = q__1.i;
+	i__2 = j - 1;
+	r_cnjg(&q__4, s);
+	q__3.r = -q__4.r, q__3.i = -q__4.i;
+	i__3 = j - 1;
+	q__2.r = q__3.r * xt[i__3].r - q__3.i * xt[i__3].i, q__2.i = q__3.r * 
+		xt[i__3].i + q__3.i * xt[i__3].r;
+	r_cnjg(&q__6, c__);
+	i__4 = j - 1;
+	q__5.r = q__6.r * yt[i__4].r - q__6.i * yt[i__4].i, q__5.i = q__6.r * 
+		yt[i__4].i + q__6.i * yt[i__4].r;
+	q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i;
+	yt[i__2].r = q__1.r, yt[i__2].i = q__1.i;
+	i__2 = j - 1;
+	xt[i__2].r = tempx.r, xt[i__2].i = tempx.i;
+/* L20: */
+    }
+
+/*     Stuff values back into XLEFT, XRIGHT, etc. */
+
+    if (*lleft) {
+	a[1].r = xt[0].r, a[1].i = xt[0].i;
+	xleft->r = yt[0].r, xleft->i = yt[0].i;
+    }
+
+    if (*lright) {
+	i__1 = nt - 1;
+	xright->r = xt[i__1].r, xright->i = xt[i__1].i;
+	i__1 = iyt;
+	i__2 = nt - 1;
+	a[i__1].r = yt[i__2].r, a[i__1].i = yt[i__2].i;
+    }
+
+    return 0;
+
+/*     End of CLAROT */
+
+} /* clarot_ */
+

lapack-netlib/TESTING/MATGEN/clatm1.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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__3 = 3;
+
+/* > \brief \b CLATM1 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE CLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO ) */
+
+/*       INTEGER            IDIST, INFO, IRSIGN, MODE, N */
+/*       REAL               COND */
+/*       INTEGER            ISEED( 4 ) */
+/*       COMPLEX            D( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* >    CLATM1 computes the entries of D(1..N) as specified by */
+/* >    MODE, COND and IRSIGN. IDIST and ISEED determine the generation */
+/* >    of random numbers. CLATM1 is called by CLATMR to generate */
+/* >    random test matrices for LAPACK programs. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] MODE */
+/* > \verbatim */
+/* >          MODE is INTEGER */
+/* >           On entry describes how D is to be computed: */
+/* >           MODE = 0 means do not change D. */
+/* >           MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
+/* >           MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
+/* >           MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
+/* >           MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* >           MODE = 5 sets D to random numbers in the range */
+/* >                    ( 1/COND , 1 ) such that their logarithms */
+/* >                    are uniformly distributed. */
+/* >           MODE = 6 set D to random numbers from same distribution */
+/* >                    as the rest of the matrix. */
+/* >           MODE < 0 has the same meaning as ABS(MODE), except that */
+/* >              the order of the elements of D is reversed. */
+/* >           Thus if MODE is positive, D has entries ranging from */
+/* >              1 to 1/COND, if negative, from 1/COND to 1, */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] COND */
+/* > \verbatim */
+/* >          COND is REAL */
+/* >           On entry, used as described under MODE above. */
+/* >           If used, it must be >= 1. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IRSIGN */
+/* > \verbatim */
+/* >          IRSIGN is INTEGER */
+/* >           On entry, if MODE neither -6, 0 nor 6, determines sign of */
+/* >           entries of D */
+/* >           0 => leave entries of D unchanged */
+/* >           1 => multiply each entry of D by random complex number */
+/* >                uniformly distributed with absolute value 1 */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IDIST */
+/* > \verbatim */
+/* >          IDIST is INTEGER */
+/* >           On entry, IDIST specifies the type of distribution to be */
+/* >           used to generate a random matrix . */
+/* >           1 => real and imaginary parts each UNIFORM( 0, 1 ) */
+/* >           2 => real and imaginary parts each UNIFORM( -1, 1 ) */
+/* >           3 => real and imaginary parts each NORMAL( 0, 1 ) */
+/* >           4 => complex number uniform in DISK( 0, 1 ) */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension ( 4 ) */
+/* >           On entry ISEED specifies the seed of the random number */
+/* >           generator. The random number generator uses a */
+/* >           linear congruential sequence limited to small */
+/* >           integers, and so should produce machine independent */
+/* >           random numbers. The values of ISEED are changed on */
+/* >           exit, and can be used in the next call to CLATM1 */
+/* >           to continue the same random number sequence. */
+/* >           Changed on exit. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] D */
+/* > \verbatim */
+/* >          D is COMPLEX array, dimension ( N ) */
+/* >           Array to be computed according to MODE, COND and IRSIGN. */
+/* >           May be changed on exit if MODE is nonzero. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >           Number of entries of D. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >            0  => normal termination */
+/* >           -1  => if MODE not in range -6 to 6 */
+/* >           -2  => if MODE neither -6, 0 nor 6, and */
+/* >                  IRSIGN neither 0 nor 1 */
+/* >           -3  => if MODE neither -6, 0 nor 6 and COND less than 1 */
+/* >           -4  => if MODE equals 6 or -6 and IDIST not in range 1 to 4 */
+/* >           -7  => if N negative */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complex_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int clatm1_(integer *mode, real *cond, integer *irsign, 
+	integer *idist, integer *iseed, complex *d__, integer *n, integer *
+	info)
+{
+    /* System generated locals */
+    integer i__1, i__2, i__3;
+    real r__1;
+    doublereal d__1, d__2;
+    complex q__1, q__2;
+
+    /* Local variables */
+    real temp;
+    integer i__;
+    real alpha;
+    complex ctemp;
+    //extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+    extern complex clarnd_(integer *, integer *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    extern real slaran_(integer *);
+    extern /* Subroutine */ int clarnv_(integer *, integer *, integer *, 
+	    complex *);
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Decode and Test the input parameters. Initialize flags & seed. */
+
+    /* Parameter adjustments */
+    --d__;
+    --iseed;
+
+    /* Function Body */
+    *info = 0;
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+/*     Set INFO if an error */
+
+    if (*mode < -6 || *mode > 6) {
+	*info = -1;
+    } else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && *
+	    irsign != 1)) {
+	*info = -2;
+    } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.f) {
+	*info = -3;
+    } else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 4)) {
+	*info = -4;
+    } else if (*n < 0) {
+	*info = -7;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("CLATM1", &i__1);
+	return 0;
+    }
+
+/*     Compute D according to COND and MODE */
+
+    if (*mode != 0) {
+	switch (abs(*mode)) {
+	    case 1:  goto L10;
+	    case 2:  goto L30;
+	    case 3:  goto L50;
+	    case 4:  goto L70;
+	    case 5:  goto L90;
+	    case 6:  goto L110;
+	}
+
+/*        One large D value: */
+
+L10:
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = i__;
+	    r__1 = 1.f / *cond;
+	    d__[i__2].r = r__1, d__[i__2].i = 0.f;
+/* L20: */
+	}
+	d__[1].r = 1.f, d__[1].i = 0.f;
+	goto L120;
+
+/*        One small D value: */
+
+L30:
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = i__;
+	    d__[i__2].r = 1.f, d__[i__2].i = 0.f;
+/* L40: */
+	}
+	i__1 = *n;
+	r__1 = 1.f / *cond;
+	d__[i__1].r = r__1, d__[i__1].i = 0.f;
+	goto L120;
+
+/*        Exponentially distributed D values: */
+
+L50:
+	d__[1].r = 1.f, d__[1].i = 0.f;
+	if (*n > 1) {
+	    d__1 = (doublereal) (*cond);
+	    d__2 = (doublereal) (-1.f / (real) (*n - 1));
+	    alpha = pow_dd(&d__1, &d__2);
+	    i__1 = *n;
+	    for (i__ = 2; i__ <= i__1; ++i__) {
+		i__2 = i__;
+		i__3 = i__ - 1;
+		r__1 = pow_ri(&alpha, &i__3);
+		d__[i__2].r = r__1, d__[i__2].i = 0.f;
+/* L60: */
+	    }
+	}
+	goto L120;
+
+/*        Arithmetically distributed D values: */
+
+L70:
+	d__[1].r = 1.f, d__[1].i = 0.f;
+	if (*n > 1) {
+	    temp = 1.f / *cond;
+	    alpha = (1.f - temp) / (real) (*n - 1);
+	    i__1 = *n;
+	    for (i__ = 2; i__ <= i__1; ++i__) {
+		i__2 = i__;
+		r__1 = (real) (*n - i__) * alpha + temp;
+		d__[i__2].r = r__1, d__[i__2].i = 0.f;
+/* L80: */
+	    }
+	}
+	goto L120;
+
+/*        Randomly distributed D values on ( 1/COND , 1): */
+
+L90:
+	alpha = log(1.f / *cond);
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = i__;
+	    r__1 = exp(alpha * slaran_(&iseed[1]));
+	    d__[i__2].r = r__1, d__[i__2].i = 0.f;
+/* L100: */
+	}
+	goto L120;
+
+/*        Randomly distributed D values from IDIST */
+
+L110:
+	clarnv_(idist, &iseed[1], n, &d__[1]);
+
+L120:
+
+/*        If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */
+/*        random signs to D */
+
+	if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) {
+	    i__1 = *n;
+	    for (i__ = 1; i__ <= i__1; ++i__) {
+		//clarnd_(&q__1, &c__3, &iseed[1]);
+		q__1=clarnd_(&c__3, &iseed[1]);
+		ctemp.r = q__1.r, ctemp.i = q__1.i;
+		i__2 = i__;
+		i__3 = i__;
+		r__1 = c_abs(&ctemp);
+		q__2.r = ctemp.r / r__1, q__2.i = ctemp.i / r__1;
+		q__1.r = d__[i__3].r * q__2.r - d__[i__3].i * q__2.i, q__1.i =
+			 d__[i__3].r * q__2.i + d__[i__3].i * q__2.r;
+		d__[i__2].r = q__1.r, d__[i__2].i = q__1.i;
+/* L130: */
+	    }
+	}
+
+/*        Reverse if MODE < 0 */
+
+	if (*mode < 0) {
+	    i__1 = *n / 2;
+	    for (i__ = 1; i__ <= i__1; ++i__) {
+		i__2 = i__;
+		ctemp.r = d__[i__2].r, ctemp.i = d__[i__2].i;
+		i__2 = i__;
+		i__3 = *n + 1 - i__;
+		d__[i__2].r = d__[i__3].r, d__[i__2].i = d__[i__3].i;
+		i__2 = *n + 1 - i__;
+		d__[i__2].r = ctemp.r, d__[i__2].i = ctemp.i;
+/* L140: */
+	    }
+	}
+
+    }
+
+    return 0;
+
+/*     End of CLATM1 */
+
+} /* clatm1_ */
+

lapack-netlib/TESTING/MATGEN/clatm2.c

@@ -0,0 +1,740 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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)
+*/
+
+
+
+/* > \brief \b CLATM2 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       COMPLEX FUNCTION CLATM2( M, N, I, J, KL, KU, IDIST, ISEED, D, */
+/*                                IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) */
+
+
+/*       INTEGER            I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N */
+/*       REAL               SPARSE */
+
+
+/*       INTEGER            ISEED( 4 ), IWORK( * ) */
+/*       COMPLEX            D( * ), DL( * ), DR( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* >    CLATM2 returns the (I,J) entry of a random matrix of dimension */
+/* >    (M, N) described by the other parameters. It is called by the */
+/* >    CLATMR routine in order to build random test matrices. No error */
+/* >    checking on parameters is done, because this routine is called in */
+/* >    a tight loop by CLATMR which has already checked the parameters. */
+/* > */
+/* >    Use of CLATM2 differs from CLATM3 in the order in which the random */
+/* >    number generator is called to fill in random matrix entries. */
+/* >    With CLATM2, the generator is called to fill in the pivoted matrix */
+/* >    columnwise. With CLATM3, the generator is called to fill in the */
+/* >    matrix columnwise, after which it is pivoted. Thus, CLATM3 can */
+/* >    be used to construct random matrices which differ only in their */
+/* >    order of rows and/or columns. CLATM2 is used to construct band */
+/* >    matrices while avoiding calling the random number generator for */
+/* >    entries outside the band (and therefore generating random numbers */
+/* > */
+/* >    The matrix whose (I,J) entry is returned is constructed as */
+/* >    follows (this routine only computes one entry): */
+/* > */
+/* >      If I is outside (1..M) or J is outside (1..N), return zero */
+/* >         (this is convenient for generating matrices in band format). */
+/* > */
+/* >      Generate a matrix A with random entries of distribution IDIST. */
+/* > */
+/* >      Set the diagonal to D. */
+/* > */
+/* >      Grade the matrix, if desired, from the left (by DL) and/or */
+/* >         from the right (by DR or DL) as specified by IGRADE. */
+/* > */
+/* >      Permute, if desired, the rows and/or columns as specified by */
+/* >         IPVTNG and IWORK. */
+/* > */
+/* >      Band the matrix to have lower bandwidth KL and upper */
+/* >         bandwidth KU. */
+/* > */
+/* >      Set random entries to zero as specified by SPARSE. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >           Number of rows of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >           Number of columns of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] I */
+/* > \verbatim */
+/* >          I is INTEGER */
+/* >           Row of entry to be returned. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] J */
+/* > \verbatim */
+/* >          J is INTEGER */
+/* >           Column of entry to be returned. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KL */
+/* > \verbatim */
+/* >          KL is INTEGER */
+/* >           Lower bandwidth. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KU */
+/* > \verbatim */
+/* >          KU is INTEGER */
+/* >           Upper bandwidth. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IDIST */
+/* > \verbatim */
+/* >          IDIST is INTEGER */
+/* >           On entry, IDIST specifies the type of distribution to be */
+/* >           used to generate a random matrix . */
+/* >           1 => real and imaginary parts each UNIFORM( 0, 1 ) */
+/* >           2 => real and imaginary parts each UNIFORM( -1, 1 ) */
+/* >           3 => real and imaginary parts each NORMAL( 0, 1 ) */
+/* >           4 => complex number uniform in DISK( 0 , 1 ) */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array of dimension ( 4 ) */
+/* >           Seed for random number generator. */
+/* >           Changed on exit. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is COMPLEX array of dimension ( MIN( I , J ) ) */
+/* >           Diagonal entries of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IGRADE */
+/* > \verbatim */
+/* >          IGRADE is INTEGER */
+/* >           Specifies grading of matrix as follows: */
+/* >           0  => no grading */
+/* >           1  => matrix premultiplied by diag( DL ) */
+/* >           2  => matrix postmultiplied by diag( DR ) */
+/* >           3  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by diag( DR ) */
+/* >           4  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by inv( diag( DL ) ) */
+/* >           5  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by diag( CONJG(DL) ) */
+/* >           6  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by diag( DL ) */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] DL */
+/* > \verbatim */
+/* >          DL is COMPLEX array ( I or J, as appropriate ) */
+/* >           Left scale factors for grading matrix.  Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] DR */
+/* > \verbatim */
+/* >          DR is COMPLEX array ( I or J, as appropriate ) */
+/* >           Right scale factors for grading matrix.  Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPVTNG */
+/* > \verbatim */
+/* >          IPVTNG is INTEGER */
+/* >           On entry specifies pivoting permutations as follows: */
+/* >           0 => none. */
+/* >           1 => row pivoting. */
+/* >           2 => column pivoting. */
+/* >           3 => full pivoting, i.e., on both sides. */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array ( I or J, as appropriate ) */
+/* >           This array specifies the permutation used. The */
+/* >           row (or column) in position K was originally in */
+/* >           position IWORK( K ). */
+/* >           This differs from IWORK for CLATM3. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] SPARSE */
+/* > \verbatim */
+/* >          SPARSE is REAL */
+/* >           Value between 0. and 1. */
+/* >           On entry specifies the sparsity of the matrix */
+/* >           if sparse matrix is to be generated. */
+/* >           SPARSE should lie between 0 and 1. */
+/* >           A uniform ( 0, 1 ) random number x is generated and */
+/* >           compared to SPARSE; if x is larger the matrix entry */
+/* >           is unchanged and if x is smaller the entry is set */
+/* >           to zero. Thus on the average a fraction SPARSE of the */
+/* >           entries will be set to zero. */
+/* >           Not modified. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date June 2016 */
+
+/* > \ingroup complex_matgen */
+
+/*  ===================================================================== */
+/* Complex */ VOID clatm2_(complex * ret_val, integer *m, integer *n, integer 
+	*i__, integer *j, integer *kl, integer *ku, integer *idist, integer *
+	iseed, complex *d__, integer *igrade, complex *dl, complex *dr, 
+	integer *ipvtng, integer *iwork, real *sparse)
+{
+    /* System generated locals */
+    integer i__1, i__2;
+    complex q__1, q__2, q__3;
+
+    /* Local variables */
+    integer isub, jsub;
+    complex ctemp;
+    //extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+    extern complex clarnd_(integer *, integer *);
+    extern real slaran_(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..-- */
+/*     June 2016 */
+
+
+
+
+
+/*  ===================================================================== */
+
+
+
+
+
+
+
+
+
+/* ----------------------------------------------------------------------- */
+
+
+
+/*     Check for I and J in range */
+
+    /* Parameter adjustments */
+    --iwork;
+    --dr;
+    --dl;
+    --d__;
+    --iseed;
+
+    /* Function Body */
+    if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) {
+	 ret_val->r = 0.f,  ret_val->i = 0.f;
+	return ;
+    }
+
+/*     Check for banding */
+
+    if (*j > *i__ + *ku || *j < *i__ - *kl) {
+	 ret_val->r = 0.f,  ret_val->i = 0.f;
+	return ;
+    }
+
+/*     Check for sparsity */
+
+    if (*sparse > 0.f) {
+	if (slaran_(&iseed[1]) < *sparse) {
+	     ret_val->r = 0.f,  ret_val->i = 0.f;
+	    return ;
+	}
+    }
+
+/*     Compute subscripts depending on IPVTNG */
+
+    if (*ipvtng == 0) {
+	isub = *i__;
+	jsub = *j;
+    } else if (*ipvtng == 1) {
+	isub = iwork[*i__];
+	jsub = *j;
+    } else if (*ipvtng == 2) {
+	isub = *i__;
+	jsub = iwork[*j];
+    } else if (*ipvtng == 3) {
+	isub = iwork[*i__];
+	jsub = iwork[*j];
+    }
+
+/*     Compute entry and grade it according to IGRADE */
+
+    if (isub == jsub) {
+	i__1 = isub;
+	ctemp.r = d__[i__1].r, ctemp.i = d__[i__1].i;
+    } else {
+	//clarnd_(&q__1, idist, &iseed[1]);
+	q__1=clarnd_(idist, &iseed[1]);
+	ctemp.r = q__1.r, ctemp.i = q__1.i;
+    }
+    if (*igrade == 1) {
+	i__1 = isub;
+	q__1.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__1.i = 
+		ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+	ctemp.r = q__1.r, ctemp.i = q__1.i;
+    } else if (*igrade == 2) {
+	i__1 = jsub;
+	q__1.r = ctemp.r * dr[i__1].r - ctemp.i * dr[i__1].i, q__1.i = 
+		ctemp.r * dr[i__1].i + ctemp.i * dr[i__1].r;
+	ctemp.r = q__1.r, ctemp.i = q__1.i;
+    } else if (*igrade == 3) {
+	i__1 = isub;
+	q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i = 
+		ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+	i__2 = jsub;
+	q__1.r = q__2.r * dr[i__2].r - q__2.i * dr[i__2].i, q__1.i = q__2.r * 
+		dr[i__2].i + q__2.i * dr[i__2].r;
+	ctemp.r = q__1.r, ctemp.i = q__1.i;
+    } else if (*igrade == 4 && isub != jsub) {
+	i__1 = isub;
+	q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i = 
+		ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+	c_div(&q__1, &q__2, &dl[jsub]);
+	ctemp.r = q__1.r, ctemp.i = q__1.i;
+    } else if (*igrade == 5) {
+	i__1 = isub;
+	q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i = 
+		ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+	r_cnjg(&q__3, &dl[jsub]);
+	q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i 
+		+ q__2.i * q__3.r;
+	ctemp.r = q__1.r, ctemp.i = q__1.i;
+    } else if (*igrade == 6) {
+	i__1 = isub;
+	q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i = 
+		ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+	i__2 = jsub;
+	q__1.r = q__2.r * dl[i__2].r - q__2.i * dl[i__2].i, q__1.i = q__2.r * 
+		dl[i__2].i + q__2.i * dl[i__2].r;
+	ctemp.r = q__1.r, ctemp.i = q__1.i;
+    }
+     ret_val->r = ctemp.r,  ret_val->i = ctemp.i;
+    return ;
+
+/*     End of CLATM2 */
+
+} /* clatm2_ */
+

lapack-netlib/TESTING/MATGEN/clatm3.c

@@ -0,0 +1,758 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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)
+*/
+
+
+
+/* > \brief \b CLATM3 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       COMPLEX FUNCTION CLATM3( M, N, I, J, ISUB, JSUB, KL, KU, IDIST, */
+/*                                ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, */
+/*                                SPARSE ) */
+
+
+/*       INTEGER            I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL, */
+/*      $                   KU, M, N */
+/*       REAL               SPARSE */
+
+
+/*       INTEGER            ISEED( 4 ), IWORK( * ) */
+/*       COMPLEX            D( * ), DL( * ), DR( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* >    CLATM3 returns the (ISUB,JSUB) entry of a random matrix of */
+/* >    dimension (M, N) described by the other parameters. (ISUB,JSUB) */
+/* >    is the final position of the (I,J) entry after pivoting */
+/* >    according to IPVTNG and IWORK. CLATM3 is called by the */
+/* >    CLATMR routine in order to build random test matrices. No error */
+/* >    checking on parameters is done, because this routine is called in */
+/* >    a tight loop by CLATMR which has already checked the parameters. */
+/* > */
+/* >    Use of CLATM3 differs from CLATM2 in the order in which the random */
+/* >    number generator is called to fill in random matrix entries. */
+/* >    With CLATM2, the generator is called to fill in the pivoted matrix */
+/* >    columnwise. With CLATM3, the generator is called to fill in the */
+/* >    matrix columnwise, after which it is pivoted. Thus, CLATM3 can */
+/* >    be used to construct random matrices which differ only in their */
+/* >    order of rows and/or columns. CLATM2 is used to construct band */
+/* >    matrices while avoiding calling the random number generator for */
+/* >    entries outside the band (and therefore generating random numbers */
+/* >    in different orders for different pivot orders). */
+/* > */
+/* >    The matrix whose (ISUB,JSUB) entry is returned is constructed as */
+/* >    follows (this routine only computes one entry): */
+/* > */
+/* >      If ISUB is outside (1..M) or JSUB is outside (1..N), return zero */
+/* >         (this is convenient for generating matrices in band format). */
+/* > */
+/* >      Generate a matrix A with random entries of distribution IDIST. */
+/* > */
+/* >      Set the diagonal to D. */
+/* > */
+/* >      Grade the matrix, if desired, from the left (by DL) and/or */
+/* >         from the right (by DR or DL) as specified by IGRADE. */
+/* > */
+/* >      Permute, if desired, the rows and/or columns as specified by */
+/* >         IPVTNG and IWORK. */
+/* > */
+/* >      Band the matrix to have lower bandwidth KL and upper */
+/* >         bandwidth KU. */
+/* > */
+/* >      Set random entries to zero as specified by SPARSE. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >           Number of rows of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >           Number of columns of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] I */
+/* > \verbatim */
+/* >          I is INTEGER */
+/* >           Row of unpivoted entry to be returned. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] J */
+/* > \verbatim */
+/* >          J is INTEGER */
+/* >           Column of unpivoted entry to be returned. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISUB */
+/* > \verbatim */
+/* >          ISUB is INTEGER */
+/* >           Row of pivoted entry to be returned. Changed on exit. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] JSUB */
+/* > \verbatim */
+/* >          JSUB is INTEGER */
+/* >           Column of pivoted entry to be returned. Changed on exit. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KL */
+/* > \verbatim */
+/* >          KL is INTEGER */
+/* >           Lower bandwidth. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KU */
+/* > \verbatim */
+/* >          KU is INTEGER */
+/* >           Upper bandwidth. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IDIST */
+/* > \verbatim */
+/* >          IDIST is INTEGER */
+/* >           On entry, IDIST specifies the type of distribution to be */
+/* >           used to generate a random matrix . */
+/* >           1 => real and imaginary parts each UNIFORM( 0, 1 ) */
+/* >           2 => real and imaginary parts each UNIFORM( -1, 1 ) */
+/* >           3 => real and imaginary parts each NORMAL( 0, 1 ) */
+/* >           4 => complex number uniform in DISK( 0 , 1 ) */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array of dimension ( 4 ) */
+/* >           Seed for random number generator. */
+/* >           Changed on exit. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is COMPLEX array of dimension ( MIN( I , J ) ) */
+/* >           Diagonal entries of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IGRADE */
+/* > \verbatim */
+/* >          IGRADE is INTEGER */
+/* >           Specifies grading of matrix as follows: */
+/* >           0  => no grading */
+/* >           1  => matrix premultiplied by diag( DL ) */
+/* >           2  => matrix postmultiplied by diag( DR ) */
+/* >           3  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by diag( DR ) */
+/* >           4  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by inv( diag( DL ) ) */
+/* >           5  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by diag( CONJG(DL) ) */
+/* >           6  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by diag( DL ) */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] DL */
+/* > \verbatim */
+/* >          DL is COMPLEX array ( I or J, as appropriate ) */
+/* >           Left scale factors for grading matrix.  Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] DR */
+/* > \verbatim */
+/* >          DR is COMPLEX array ( I or J, as appropriate ) */
+/* >           Right scale factors for grading matrix.  Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPVTNG */
+/* > \verbatim */
+/* >          IPVTNG is INTEGER */
+/* >           On entry specifies pivoting permutations as follows: */
+/* >           0 => none. */
+/* >           1 => row pivoting. */
+/* >           2 => column pivoting. */
+/* >           3 => full pivoting, i.e., on both sides. */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array ( I or J, as appropriate ) */
+/* >           This array specifies the permutation used. The */
+/* >           row (or column) originally in position K is in */
+/* >           position IWORK( K ) after pivoting. */
+/* >           This differs from IWORK for CLATM2. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] SPARSE */
+/* > \verbatim */
+/* >          SPARSE is REAL between 0. and 1. */
+/* >           On entry specifies the sparsity of the matrix */
+/* >           if sparse matrix is to be generated. */
+/* >           SPARSE should lie between 0 and 1. */
+/* >           A uniform ( 0, 1 ) random number x is generated and */
+/* >           compared to SPARSE; if x is larger the matrix entry */
+/* >           is unchanged and if x is smaller the entry is set */
+/* >           to zero. Thus on the average a fraction SPARSE of the */
+/* >           entries will be set to zero. */
+/* >           Not modified. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date June 2016 */
+
+/* > \ingroup complex_matgen */
+
+/*  ===================================================================== */
+/* Complex */ VOID clatm3_(complex * ret_val, integer *m, integer *n, integer 
+	*i__, integer *j, integer *isub, integer *jsub, integer *kl, integer *
+	ku, integer *idist, integer *iseed, complex *d__, integer *igrade, 
+	complex *dl, complex *dr, integer *ipvtng, integer *iwork, real *
+	sparse)
+{
+    /* System generated locals */
+    integer i__1, i__2;
+    complex q__1, q__2, q__3;
+
+    /* Local variables */
+    complex ctemp;
+    //extern /* Complex */ VOID clarnd_(complex *, integer *, integer *);
+    extern complex clarnd_(integer *, integer *);
+    extern real slaran_(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..-- */
+/*     June 2016 */
+
+
+
+
+
+/*  ===================================================================== */
+
+
+
+
+
+
+
+
+
+/* ----------------------------------------------------------------------- */
+
+
+
+/*     Check for I and J in range */
+
+    /* Parameter adjustments */
+    --iwork;
+    --dr;
+    --dl;
+    --d__;
+    --iseed;
+
+    /* Function Body */
+    if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) {
+	*isub = *i__;
+	*jsub = *j;
+	 ret_val->r = 0.f,  ret_val->i = 0.f;
+	return ;
+    }
+
+/*     Compute subscripts depending on IPVTNG */
+
+    if (*ipvtng == 0) {
+	*isub = *i__;
+	*jsub = *j;
+    } else if (*ipvtng == 1) {
+	*isub = iwork[*i__];
+	*jsub = *j;
+    } else if (*ipvtng == 2) {
+	*isub = *i__;
+	*jsub = iwork[*j];
+    } else if (*ipvtng == 3) {
+	*isub = iwork[*i__];
+	*jsub = iwork[*j];
+    }
+
+/*     Check for banding */
+
+    if (*jsub > *isub + *ku || *jsub < *isub - *kl) {
+	 ret_val->r = 0.f,  ret_val->i = 0.f;
+	return ;
+    }
+
+/*     Check for sparsity */
+
+    if (*sparse > 0.f) {
+	if (slaran_(&iseed[1]) < *sparse) {
+	     ret_val->r = 0.f,  ret_val->i = 0.f;
+	    return ;
+	}
+    }
+
+/*     Compute entry and grade it according to IGRADE */
+
+    if (*i__ == *j) {
+	i__1 = *i__;
+	ctemp.r = d__[i__1].r, ctemp.i = d__[i__1].i;
+    } else {
+	//clarnd_(&q__1, idist, &iseed[1]);
+	q__1=clarnd_(idist, &iseed[1]);
+	ctemp.r = q__1.r, ctemp.i = q__1.i;
+    }
+    if (*igrade == 1) {
+	i__1 = *i__;
+	q__1.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__1.i = 
+		ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+	ctemp.r = q__1.r, ctemp.i = q__1.i;
+    } else if (*igrade == 2) {
+	i__1 = *j;
+	q__1.r = ctemp.r * dr[i__1].r - ctemp.i * dr[i__1].i, q__1.i = 
+		ctemp.r * dr[i__1].i + ctemp.i * dr[i__1].r;
+	ctemp.r = q__1.r, ctemp.i = q__1.i;
+    } else if (*igrade == 3) {
+	i__1 = *i__;
+	q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i = 
+		ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+	i__2 = *j;
+	q__1.r = q__2.r * dr[i__2].r - q__2.i * dr[i__2].i, q__1.i = q__2.r * 
+		dr[i__2].i + q__2.i * dr[i__2].r;
+	ctemp.r = q__1.r, ctemp.i = q__1.i;
+    } else if (*igrade == 4 && *i__ != *j) {
+	i__1 = *i__;
+	q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i = 
+		ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+	c_div(&q__1, &q__2, &dl[*j]);
+	ctemp.r = q__1.r, ctemp.i = q__1.i;
+    } else if (*igrade == 5) {
+	i__1 = *i__;
+	q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i = 
+		ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+	r_cnjg(&q__3, &dl[*j]);
+	q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i 
+		+ q__2.i * q__3.r;
+	ctemp.r = q__1.r, ctemp.i = q__1.i;
+    } else if (*igrade == 6) {
+	i__1 = *i__;
+	q__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, q__2.i = 
+		ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+	i__2 = *j;
+	q__1.r = q__2.r * dl[i__2].r - q__2.i * dl[i__2].i, q__1.i = q__2.r * 
+		dl[i__2].i + q__2.i * dl[i__2].r;
+	ctemp.r = q__1.r, ctemp.i = q__1.i;
+    }
+     ret_val->r = ctemp.r,  ret_val->i = ctemp.i;
+    return ;
+
+/*     End of CLATM3 */
+
+} /* clatm3_ */
+

lapack-netlib/TESTING/MATGEN/clatm6.c

@@ -0,0 +1,815 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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 integer c__4 = 4;
+static integer c__8 = 8;
+static integer c__24 = 24;
+
+/* > \brief \b CLATM6 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE CLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA, */
+/*                          BETA, WX, WY, S, DIF ) */
+
+/*       INTEGER            LDA, LDX, LDY, N, TYPE */
+/*       COMPLEX            ALPHA, BETA, WX, WY */
+/*       REAL               DIF( * ), S( * ) */
+/*       COMPLEX            A( LDA, * ), B( LDA, * ), X( LDX, * ), */
+/*      $                   Y( LDY, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > CLATM6 generates test matrices for the generalized eigenvalue */
+/* > problem, their corresponding right and left eigenvector matrices, */
+/* > and also reciprocal condition numbers for all eigenvalues and */
+/* > the reciprocal condition numbers of eigenvectors corresponding to */
+/* > the 1th and 5th eigenvalues. */
+/* > */
+/* > Test Matrices */
+/* > ============= */
+/* > */
+/* > Two kinds of test matrix pairs */
+/* >          (A, B) = inverse(YH) * (Da, Db) * inverse(X) */
+/* > are used in the tests: */
+/* > */
+/* > Type 1: */
+/* >    Da = 1+a   0    0    0    0    Db = 1   0   0   0   0 */
+/* >          0   2+a   0    0    0         0   1   0   0   0 */
+/* >          0    0   3+a   0    0         0   0   1   0   0 */
+/* >          0    0    0   4+a   0         0   0   0   1   0 */
+/* >          0    0    0    0   5+a ,      0   0   0   0   1 */
+/* > and Type 2: */
+/* >    Da = 1+i   0    0       0       0    Db = 1   0   0   0   0 */
+/* >          0   1-i   0       0       0         0   1   0   0   0 */
+/* >          0    0    1       0       0         0   0   1   0   0 */
+/* >          0    0    0 (1+a)+(1+b)i  0         0   0   0   1   0 */
+/* >          0    0    0       0 (1+a)-(1+b)i,   0   0   0   0   1 . */
+/* > */
+/* > In both cases the same inverse(YH) and inverse(X) are used to compute */
+/* > (A, B), giving the exact eigenvectors to (A,B) as (YH, X): */
+/* > */
+/* > YH:  =  1    0   -y    y   -y    X =  1   0  -x  -x   x */
+/* >         0    1   -y    y   -y         0   1   x  -x  -x */
+/* >         0    0    1    0    0         0   0   1   0   0 */
+/* >         0    0    0    1    0         0   0   0   1   0 */
+/* >         0    0    0    0    1,        0   0   0   0   1 , where */
+/* > */
+/* > a, b, x and y will have all values independently of each other. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] TYPE */
+/* > \verbatim */
+/* >          TYPE is INTEGER */
+/* >          Specifies the problem type (see further details). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          Size of the matrices A and B. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] A */
+/* > \verbatim */
+/* >          A is COMPLEX array, dimension (LDA, N). */
+/* >          On exit A N-by-N is initialized according to TYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of A and of B. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] B */
+/* > \verbatim */
+/* >          B is COMPLEX array, dimension (LDA, N). */
+/* >          On exit B N-by-N is initialized according to TYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] X */
+/* > \verbatim */
+/* >          X is COMPLEX array, dimension (LDX, N). */
+/* >          On exit X is the N-by-N matrix of right eigenvectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDX */
+/* > \verbatim */
+/* >          LDX is INTEGER */
+/* >          The leading dimension of X. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Y */
+/* > \verbatim */
+/* >          Y is COMPLEX array, dimension (LDY, N). */
+/* >          On exit Y is the N-by-N matrix of left eigenvectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDY */
+/* > \verbatim */
+/* >          LDY is INTEGER */
+/* >          The leading dimension of Y. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] ALPHA */
+/* > \verbatim */
+/* >          ALPHA is COMPLEX */
+/* > \endverbatim */
+/* > */
+/* > \param[in] BETA */
+/* > \verbatim */
+/* >          BETA is COMPLEX */
+/* > */
+/* >          Weighting constants for matrix A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] WX */
+/* > \verbatim */
+/* >          WX is COMPLEX */
+/* >          Constant for right eigenvector matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] WY */
+/* > \verbatim */
+/* >          WY is COMPLEX */
+/* >          Constant for left eigenvector matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] S */
+/* > \verbatim */
+/* >          S is REAL array, dimension (N) */
+/* >          S(i) is the reciprocal condition number for eigenvalue i. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] DIF */
+/* > \verbatim */
+/* >          DIF is REAL array, dimension (N) */
+/* >          DIF(i) is the reciprocal condition number for eigenvector i. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complex_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int clatm6_(integer *type__, integer *n, complex *a, integer 
+	*lda, complex *b, complex *x, integer *ldx, complex *y, integer *ldy, 
+	complex *alpha, complex *beta, complex *wx, complex *wy, real *s, 
+	real *dif)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, y_dim1, 
+	    y_offset, i__1, i__2, i__3;
+    real r__1, r__2;
+    complex q__1, q__2, q__3, q__4;
+
+    /* Local variables */
+    integer info;
+    complex work[26];
+    integer i__, j;
+    complex z__[64]	/* was [8][8] */;
+    extern /* Subroutine */ int clakf2_(integer *, integer *, complex *, 
+	    integer *, complex *, complex *, complex *, complex *, integer *);
+    real rwork[50];
+    extern /* Subroutine */ int cgesvd_(char *, char *, integer *, integer *, 
+	    complex *, integer *, real *, complex *, integer *, complex *, 
+	    integer *, complex *, integer *, real *, integer *), clacpy_(char *, integer *, integer *, complex *, 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Generate test problem ... */
+/*     (Da, Db) ... */
+
+    /* Parameter adjustments */
+    b_dim1 = *lda;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    x_dim1 = *ldx;
+    x_offset = 1 + x_dim1 * 1;
+    x -= x_offset;
+    y_dim1 = *ldy;
+    y_offset = 1 + y_dim1 * 1;
+    y -= y_offset;
+    --s;
+    --dif;
+
+    /* Function Body */
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	i__2 = *n;
+	for (j = 1; j <= i__2; ++j) {
+
+	    if (i__ == j) {
+		i__3 = i__ + i__ * a_dim1;
+		q__2.r = (real) i__, q__2.i = 0.f;
+		q__1.r = q__2.r + alpha->r, q__1.i = q__2.i + alpha->i;
+		a[i__3].r = q__1.r, a[i__3].i = q__1.i;
+		i__3 = i__ + i__ * b_dim1;
+		b[i__3].r = 1.f, b[i__3].i = 0.f;
+	    } else {
+		i__3 = i__ + j * a_dim1;
+		a[i__3].r = 0.f, a[i__3].i = 0.f;
+		i__3 = i__ + j * b_dim1;
+		b[i__3].r = 0.f, b[i__3].i = 0.f;
+	    }
+
+/* L10: */
+	}
+/* L20: */
+    }
+    if (*type__ == 2) {
+	i__1 = a_dim1 + 1;
+	a[i__1].r = 1.f, a[i__1].i = 1.f;
+	i__1 = (a_dim1 << 1) + 2;
+	r_cnjg(&q__1, &a[a_dim1 + 1]);
+	a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+	i__1 = a_dim1 * 3 + 3;
+	a[i__1].r = 1.f, a[i__1].i = 0.f;
+	i__1 = (a_dim1 << 2) + 4;
+	q__2.r = alpha->r + 1.f, q__2.i = alpha->i + 0.f;
+	r__1 = q__2.r;
+	q__3.r = beta->r + 1.f, q__3.i = beta->i + 0.f;
+	r__2 = q__3.r;
+	q__1.r = r__1, q__1.i = r__2;
+	a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+	i__1 = a_dim1 * 5 + 5;
+	r_cnjg(&q__1, &a[(a_dim1 << 2) + 4]);
+	a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+    }
+
+/*     Form X and Y */
+
+    clacpy_("F", n, n, &b[b_offset], lda, &y[y_offset], ldy);
+    i__1 = y_dim1 + 3;
+    r_cnjg(&q__2, wy);
+    q__1.r = -q__2.r, q__1.i = -q__2.i;
+    y[i__1].r = q__1.r, y[i__1].i = q__1.i;
+    i__1 = y_dim1 + 4;
+    r_cnjg(&q__1, wy);
+    y[i__1].r = q__1.r, y[i__1].i = q__1.i;
+    i__1 = y_dim1 + 5;
+    r_cnjg(&q__2, wy);
+    q__1.r = -q__2.r, q__1.i = -q__2.i;
+    y[i__1].r = q__1.r, y[i__1].i = q__1.i;
+    i__1 = (y_dim1 << 1) + 3;
+    r_cnjg(&q__2, wy);
+    q__1.r = -q__2.r, q__1.i = -q__2.i;
+    y[i__1].r = q__1.r, y[i__1].i = q__1.i;
+    i__1 = (y_dim1 << 1) + 4;
+    r_cnjg(&q__1, wy);
+    y[i__1].r = q__1.r, y[i__1].i = q__1.i;
+    i__1 = (y_dim1 << 1) + 5;
+    r_cnjg(&q__2, wy);
+    q__1.r = -q__2.r, q__1.i = -q__2.i;
+    y[i__1].r = q__1.r, y[i__1].i = q__1.i;
+
+    clacpy_("F", n, n, &b[b_offset], lda, &x[x_offset], ldx);
+    i__1 = x_dim1 * 3 + 1;
+    q__1.r = -wx->r, q__1.i = -wx->i;
+    x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+    i__1 = (x_dim1 << 2) + 1;
+    q__1.r = -wx->r, q__1.i = -wx->i;
+    x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+    i__1 = x_dim1 * 5 + 1;
+    x[i__1].r = wx->r, x[i__1].i = wx->i;
+    i__1 = x_dim1 * 3 + 2;
+    x[i__1].r = wx->r, x[i__1].i = wx->i;
+    i__1 = (x_dim1 << 2) + 2;
+    q__1.r = -wx->r, q__1.i = -wx->i;
+    x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+    i__1 = x_dim1 * 5 + 2;
+    q__1.r = -wx->r, q__1.i = -wx->i;
+    x[i__1].r = q__1.r, x[i__1].i = q__1.i;
+
+/*     Form (A, B) */
+
+    i__1 = b_dim1 * 3 + 1;
+    q__1.r = wx->r + wy->r, q__1.i = wx->i + wy->i;
+    b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+    i__1 = b_dim1 * 3 + 2;
+    q__2.r = -wx->r, q__2.i = -wx->i;
+    q__1.r = q__2.r + wy->r, q__1.i = q__2.i + wy->i;
+    b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+    i__1 = (b_dim1 << 2) + 1;
+    q__1.r = wx->r - wy->r, q__1.i = wx->i - wy->i;
+    b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+    i__1 = (b_dim1 << 2) + 2;
+    q__1.r = wx->r - wy->r, q__1.i = wx->i - wy->i;
+    b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+    i__1 = b_dim1 * 5 + 1;
+    q__2.r = -wx->r, q__2.i = -wx->i;
+    q__1.r = q__2.r + wy->r, q__1.i = q__2.i + wy->i;
+    b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+    i__1 = b_dim1 * 5 + 2;
+    q__1.r = wx->r + wy->r, q__1.i = wx->i + wy->i;
+    b[i__1].r = q__1.r, b[i__1].i = q__1.i;
+    i__1 = a_dim1 * 3 + 1;
+    i__2 = a_dim1 + 1;
+    q__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, q__2.i = wx->r * a[i__2]
+	    .i + wx->i * a[i__2].r;
+    i__3 = a_dim1 * 3 + 3;
+    q__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, q__3.i = wy->r * a[i__3]
+	    .i + wy->i * a[i__3].r;
+    q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+    a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+    i__1 = a_dim1 * 3 + 2;
+    q__3.r = -wx->r, q__3.i = -wx->i;
+    i__2 = (a_dim1 << 1) + 2;
+    q__2.r = q__3.r * a[i__2].r - q__3.i * a[i__2].i, q__2.i = q__3.r * a[
+	    i__2].i + q__3.i * a[i__2].r;
+    i__3 = a_dim1 * 3 + 3;
+    q__4.r = wy->r * a[i__3].r - wy->i * a[i__3].i, q__4.i = wy->r * a[i__3]
+	    .i + wy->i * a[i__3].r;
+    q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+    a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+    i__1 = (a_dim1 << 2) + 1;
+    i__2 = a_dim1 + 1;
+    q__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, q__2.i = wx->r * a[i__2]
+	    .i + wx->i * a[i__2].r;
+    i__3 = (a_dim1 << 2) + 4;
+    q__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, q__3.i = wy->r * a[i__3]
+	    .i + wy->i * a[i__3].r;
+    q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+    a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+    i__1 = (a_dim1 << 2) + 2;
+    i__2 = (a_dim1 << 1) + 2;
+    q__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, q__2.i = wx->r * a[i__2]
+	    .i + wx->i * a[i__2].r;
+    i__3 = (a_dim1 << 2) + 4;
+    q__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, q__3.i = wy->r * a[i__3]
+	    .i + wy->i * a[i__3].r;
+    q__1.r = q__2.r - q__3.r, q__1.i = q__2.i - q__3.i;
+    a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+    i__1 = a_dim1 * 5 + 1;
+    q__3.r = -wx->r, q__3.i = -wx->i;
+    i__2 = a_dim1 + 1;
+    q__2.r = q__3.r * a[i__2].r - q__3.i * a[i__2].i, q__2.i = q__3.r * a[
+	    i__2].i + q__3.i * a[i__2].r;
+    i__3 = a_dim1 * 5 + 5;
+    q__4.r = wy->r * a[i__3].r - wy->i * a[i__3].i, q__4.i = wy->r * a[i__3]
+	    .i + wy->i * a[i__3].r;
+    q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
+    a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+    i__1 = a_dim1 * 5 + 2;
+    i__2 = (a_dim1 << 1) + 2;
+    q__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, q__2.i = wx->r * a[i__2]
+	    .i + wx->i * a[i__2].r;
+    i__3 = a_dim1 * 5 + 5;
+    q__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, q__3.i = wy->r * a[i__3]
+	    .i + wy->i * a[i__3].r;
+    q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
+    a[i__1].r = q__1.r, a[i__1].i = q__1.i;
+
+/*     Compute condition numbers */
+
+    s[1] = 1.f / sqrt((c_abs(wy) * 3.f * c_abs(wy) + 1.f) / (c_abs(&a[a_dim1 
+	    + 1]) * c_abs(&a[a_dim1 + 1]) + 1.f));
+    s[2] = 1.f / sqrt((c_abs(wy) * 3.f * c_abs(wy) + 1.f) / (c_abs(&a[(a_dim1 
+	    << 1) + 2]) * c_abs(&a[(a_dim1 << 1) + 2]) + 1.f));
+    s[3] = 1.f / sqrt((c_abs(wx) * 2.f * c_abs(wx) + 1.f) / (c_abs(&a[a_dim1 *
+	     3 + 3]) * c_abs(&a[a_dim1 * 3 + 3]) + 1.f));
+    s[4] = 1.f / sqrt((c_abs(wx) * 2.f * c_abs(wx) + 1.f) / (c_abs(&a[(a_dim1 
+	    << 2) + 4]) * c_abs(&a[(a_dim1 << 2) + 4]) + 1.f));
+    s[5] = 1.f / sqrt((c_abs(wx) * 2.f * c_abs(wx) + 1.f) / (c_abs(&a[a_dim1 *
+	     5 + 5]) * c_abs(&a[a_dim1 * 5 + 5]) + 1.f));
+
+    clakf2_(&c__1, &c__4, &a[a_offset], lda, &a[(a_dim1 << 1) + 2], &b[
+	    b_offset], &b[(b_dim1 << 1) + 2], z__, &c__8);
+    cgesvd_("N", "N", &c__8, &c__8, z__, &c__8, rwork, work, &c__1, &work[1], 
+	    &c__1, &work[2], &c__24, &rwork[8], &info);
+    dif[1] = rwork[7];
+
+    clakf2_(&c__4, &c__1, &a[a_offset], lda, &a[a_dim1 * 5 + 5], &b[b_offset],
+	     &b[b_dim1 * 5 + 5], z__, &c__8);
+    cgesvd_("N", "N", &c__8, &c__8, z__, &c__8, rwork, work, &c__1, &work[1], 
+	    &c__1, &work[2], &c__24, &rwork[8], &info);
+    dif[5] = rwork[7];
+
+    return 0;
+
+/*     End of CLATM6 */
+
+} /* clatm6_ */
+

lapack-netlib/TESTING/MATGEN/dlagge.c

@@ -0,0 +1,847 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__3 = 3;
+static integer c__1 = 1;
+static doublereal c_b11 = 1.;
+static doublereal c_b13 = 0.;
+
+/* > \brief \b DLAGGE */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE DLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO ) */
+
+/*       INTEGER            INFO, KL, KU, LDA, M, N */
+/*       INTEGER            ISEED( 4 ) */
+/*       DOUBLE PRECISION   A( LDA, * ), D( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > DLAGGE generates a real general m by n matrix A, by pre- and post- */
+/* > multiplying a real diagonal matrix D with random orthogonal matrices: */
+/* > A = U*D*V. The lower and upper bandwidths may then be reduced to */
+/* > kl and ku by additional orthogonal transformations. */
+/* > \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] KL */
+/* > \verbatim */
+/* >          KL is INTEGER */
+/* >          The number of nonzero subdiagonals within the band of A. */
+/* >          0 <= KL <= M-1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KU */
+/* > \verbatim */
+/* >          KU is INTEGER */
+/* >          The number of nonzero superdiagonals within the band of A. */
+/* >          0 <= KU <= N-1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is DOUBLE PRECISION array, dimension (f2cmin(M,N)) */
+/* >          The diagonal elements of the diagonal matrix D. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] A */
+/* > \verbatim */
+/* >          A is DOUBLE PRECISION array, dimension (LDA,N) */
+/* >          The generated m by n matrix A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= M. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension (4) */
+/* >          On entry, the seed of the random number generator; the array */
+/* >          elements must be between 0 and 4095, and ISEED(4) must be */
+/* >          odd. */
+/* >          On exit, the seed is updated. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is DOUBLE PRECISION array, dimension (M+N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit */
+/* >          < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup double_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int dlagge_(integer *m, integer *n, integer *kl, integer *ku,
+	 doublereal *d__, doublereal *a, integer *lda, integer *iseed, 
+	doublereal *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+    doublereal d__1;
+
+    /* Local variables */
+    extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, 
+	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
+	    integer *);
+    extern doublereal dnrm2_(integer *, doublereal *, integer *);
+    integer i__, j;
+    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
+	    integer *), dgemv_(char *, integer *, integer *, doublereal *, 
+	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
+	    doublereal *, integer *);
+    doublereal wa, wb, wn;
+    extern /* Subroutine */ int xerbla_(char *, integer *), dlarnv_(
+	    integer *, integer *, integer *, doublereal *);
+    doublereal tau;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    --d__;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --iseed;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    if (*m < 0) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*kl < 0 || *kl > *m - 1) {
+	*info = -3;
+    } else if (*ku < 0 || *ku > *n - 1) {
+	*info = -4;
+    } else if (*lda < f2cmax(1,*m)) {
+	*info = -7;
+    }
+    if (*info < 0) {
+	i__1 = -(*info);
+	xerbla_("DLAGGE", &i__1);
+	return 0;
+    }
+
+/*     initialize A to diagonal matrix */
+
+    i__1 = *n;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *m;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    a[i__ + j * a_dim1] = 0.;
+/* L10: */
+	}
+/* L20: */
+    }
+    i__1 = f2cmin(*m,*n);
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	a[i__ + i__ * a_dim1] = d__[i__];
+/* L30: */
+    }
+
+/*     Quick exit if the user wants a diagonal matrix */
+
+    if (*kl == 0 && *ku == 0) {
+	return 0;
+    }
+
+/*     pre- and post-multiply A by random orthogonal matrices */
+
+    for (i__ = f2cmin(*m,*n); i__ >= 1; --i__) {
+	if (i__ < *m) {
+
+/*           generate random reflection */
+
+	    i__1 = *m - i__ + 1;
+	    dlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+	    i__1 = *m - i__ + 1;
+	    wn = dnrm2_(&i__1, &work[1], &c__1);
+	    wa = d_sign(&wn, &work[1]);
+	    if (wn == 0.) {
+		tau = 0.;
+	    } else {
+		wb = work[1] + wa;
+		i__1 = *m - i__;
+		d__1 = 1. / wb;
+		dscal_(&i__1, &d__1, &work[2], &c__1);
+		work[1] = 1.;
+		tau = wb / wa;
+	    }
+
+/*           multiply A(i:m,i:n) by random reflection from the left */
+
+	    i__1 = *m - i__ + 1;
+	    i__2 = *n - i__ + 1;
+	    dgemv_("Transpose", &i__1, &i__2, &c_b11, &a[i__ + i__ * a_dim1], 
+		    lda, &work[1], &c__1, &c_b13, &work[*m + 1], &c__1);
+	    i__1 = *m - i__ + 1;
+	    i__2 = *n - i__ + 1;
+	    d__1 = -tau;
+	    dger_(&i__1, &i__2, &d__1, &work[1], &c__1, &work[*m + 1], &c__1, 
+		    &a[i__ + i__ * a_dim1], lda);
+	}
+	if (i__ < *n) {
+
+/*           generate random reflection */
+
+	    i__1 = *n - i__ + 1;
+	    dlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+	    i__1 = *n - i__ + 1;
+	    wn = dnrm2_(&i__1, &work[1], &c__1);
+	    wa = d_sign(&wn, &work[1]);
+	    if (wn == 0.) {
+		tau = 0.;
+	    } else {
+		wb = work[1] + wa;
+		i__1 = *n - i__;
+		d__1 = 1. / wb;
+		dscal_(&i__1, &d__1, &work[2], &c__1);
+		work[1] = 1.;
+		tau = wb / wa;
+	    }
+
+/*           multiply A(i:m,i:n) by random reflection from the right */
+
+	    i__1 = *m - i__ + 1;
+	    i__2 = *n - i__ + 1;
+	    dgemv_("No transpose", &i__1, &i__2, &c_b11, &a[i__ + i__ * 
+		    a_dim1], lda, &work[1], &c__1, &c_b13, &work[*n + 1], &
+		    c__1);
+	    i__1 = *m - i__ + 1;
+	    i__2 = *n - i__ + 1;
+	    d__1 = -tau;
+	    dger_(&i__1, &i__2, &d__1, &work[*n + 1], &c__1, &work[1], &c__1, 
+		    &a[i__ + i__ * a_dim1], lda);
+	}
+/* L40: */
+    }
+
+/*     Reduce number of subdiagonals to KL and number of superdiagonals */
+/*     to KU */
+
+/* Computing MAX */
+    i__2 = *m - 1 - *kl, i__3 = *n - 1 - *ku;
+    i__1 = f2cmax(i__2,i__3);
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	if (*kl <= *ku) {
+
+/*           annihilate subdiagonal elements first (necessary if KL = 0) */
+
+/* Computing MIN */
+	    i__2 = *m - 1 - *kl;
+	    if (i__ <= f2cmin(i__2,*n)) {
+
+/*              generate reflection to annihilate A(kl+i+1:m,i) */
+
+		i__2 = *m - *kl - i__ + 1;
+		wn = dnrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
+		wa = d_sign(&wn, &a[*kl + i__ + i__ * a_dim1]);
+		if (wn == 0.) {
+		    tau = 0.;
+		} else {
+		    wb = a[*kl + i__ + i__ * a_dim1] + wa;
+		    i__2 = *m - *kl - i__;
+		    d__1 = 1. / wb;
+		    dscal_(&i__2, &d__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
+			    c__1);
+		    a[*kl + i__ + i__ * a_dim1] = 1.;
+		    tau = wb / wa;
+		}
+
+/*              apply reflection to A(kl+i:m,i+1:n) from the left */
+
+		i__2 = *m - *kl - i__ + 1;
+		i__3 = *n - i__;
+		dgemv_("Transpose", &i__2, &i__3, &c_b11, &a[*kl + i__ + (i__ 
+			+ 1) * a_dim1], lda, &a[*kl + i__ + i__ * a_dim1], &
+			c__1, &c_b13, &work[1], &c__1);
+		i__2 = *m - *kl - i__ + 1;
+		i__3 = *n - i__;
+		d__1 = -tau;
+		dger_(&i__2, &i__3, &d__1, &a[*kl + i__ + i__ * a_dim1], &
+			c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) * 
+			a_dim1], lda);
+		a[*kl + i__ + i__ * a_dim1] = -wa;
+	    }
+
+/* Computing MIN */
+	    i__2 = *n - 1 - *ku;
+	    if (i__ <= f2cmin(i__2,*m)) {
+
+/*              generate reflection to annihilate A(i,ku+i+1:n) */
+
+		i__2 = *n - *ku - i__ + 1;
+		wn = dnrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+		wa = d_sign(&wn, &a[i__ + (*ku + i__) * a_dim1]);
+		if (wn == 0.) {
+		    tau = 0.;
+		} else {
+		    wb = a[i__ + (*ku + i__) * a_dim1] + wa;
+		    i__2 = *n - *ku - i__;
+		    d__1 = 1. / wb;
+		    dscal_(&i__2, &d__1, &a[i__ + (*ku + i__ + 1) * a_dim1], 
+			    lda);
+		    a[i__ + (*ku + i__) * a_dim1] = 1.;
+		    tau = wb / wa;
+		}
+
+/*              apply reflection to A(i+1:m,ku+i:n) from the right */
+
+		i__2 = *m - i__;
+		i__3 = *n - *ku - i__ + 1;
+		dgemv_("No transpose", &i__2, &i__3, &c_b11, &a[i__ + 1 + (*
+			ku + i__) * a_dim1], lda, &a[i__ + (*ku + i__) * 
+			a_dim1], lda, &c_b13, &work[1], &c__1);
+		i__2 = *m - i__;
+		i__3 = *n - *ku - i__ + 1;
+		d__1 = -tau;
+		dger_(&i__2, &i__3, &d__1, &work[1], &c__1, &a[i__ + (*ku + 
+			i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) * 
+			a_dim1], lda);
+		a[i__ + (*ku + i__) * a_dim1] = -wa;
+	    }
+	} else {
+
+/*           annihilate superdiagonal elements first (necessary if */
+/*           KU = 0) */
+
+/* Computing MIN */
+	    i__2 = *n - 1 - *ku;
+	    if (i__ <= f2cmin(i__2,*m)) {
+
+/*              generate reflection to annihilate A(i,ku+i+1:n) */
+
+		i__2 = *n - *ku - i__ + 1;
+		wn = dnrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+		wa = d_sign(&wn, &a[i__ + (*ku + i__) * a_dim1]);
+		if (wn == 0.) {
+		    tau = 0.;
+		} else {
+		    wb = a[i__ + (*ku + i__) * a_dim1] + wa;
+		    i__2 = *n - *ku - i__;
+		    d__1 = 1. / wb;
+		    dscal_(&i__2, &d__1, &a[i__ + (*ku + i__ + 1) * a_dim1], 
+			    lda);
+		    a[i__ + (*ku + i__) * a_dim1] = 1.;
+		    tau = wb / wa;
+		}
+
+/*              apply reflection to A(i+1:m,ku+i:n) from the right */
+
+		i__2 = *m - i__;
+		i__3 = *n - *ku - i__ + 1;
+		dgemv_("No transpose", &i__2, &i__3, &c_b11, &a[i__ + 1 + (*
+			ku + i__) * a_dim1], lda, &a[i__ + (*ku + i__) * 
+			a_dim1], lda, &c_b13, &work[1], &c__1);
+		i__2 = *m - i__;
+		i__3 = *n - *ku - i__ + 1;
+		d__1 = -tau;
+		dger_(&i__2, &i__3, &d__1, &work[1], &c__1, &a[i__ + (*ku + 
+			i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) * 
+			a_dim1], lda);
+		a[i__ + (*ku + i__) * a_dim1] = -wa;
+	    }
+
+/* Computing MIN */
+	    i__2 = *m - 1 - *kl;
+	    if (i__ <= f2cmin(i__2,*n)) {
+
+/*              generate reflection to annihilate A(kl+i+1:m,i) */
+
+		i__2 = *m - *kl - i__ + 1;
+		wn = dnrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
+		wa = d_sign(&wn, &a[*kl + i__ + i__ * a_dim1]);
+		if (wn == 0.) {
+		    tau = 0.;
+		} else {
+		    wb = a[*kl + i__ + i__ * a_dim1] + wa;
+		    i__2 = *m - *kl - i__;
+		    d__1 = 1. / wb;
+		    dscal_(&i__2, &d__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
+			    c__1);
+		    a[*kl + i__ + i__ * a_dim1] = 1.;
+		    tau = wb / wa;
+		}
+
+/*              apply reflection to A(kl+i:m,i+1:n) from the left */
+
+		i__2 = *m - *kl - i__ + 1;
+		i__3 = *n - i__;
+		dgemv_("Transpose", &i__2, &i__3, &c_b11, &a[*kl + i__ + (i__ 
+			+ 1) * a_dim1], lda, &a[*kl + i__ + i__ * a_dim1], &
+			c__1, &c_b13, &work[1], &c__1);
+		i__2 = *m - *kl - i__ + 1;
+		i__3 = *n - i__;
+		d__1 = -tau;
+		dger_(&i__2, &i__3, &d__1, &a[*kl + i__ + i__ * a_dim1], &
+			c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) * 
+			a_dim1], lda);
+		a[*kl + i__ + i__ * a_dim1] = -wa;
+	    }
+	}
+
+	if (i__ <= *n) {
+	    i__2 = *m;
+	    for (j = *kl + i__ + 1; j <= i__2; ++j) {
+		a[j + i__ * a_dim1] = 0.;
+/* L50: */
+	    }
+	}
+
+	if (i__ <= *m) {
+	    i__2 = *n;
+	    for (j = *ku + i__ + 1; j <= i__2; ++j) {
+		a[i__ + j * a_dim1] = 0.;
+/* L60: */
+	    }
+	}
+/* L70: */
+    }
+    return 0;
+
+/*     End of DLAGGE */
+
+} /* dlagge_ */
+

lapack-netlib/TESTING/MATGEN/dlagsy.c

@@ -0,0 +1,706 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__3 = 3;
+static integer c__1 = 1;
+static doublereal c_b12 = 0.;
+static doublereal c_b19 = -1.;
+static doublereal c_b26 = 1.;
+
+/* > \brief \b DLAGSY */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE DLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) */
+
+/*       INTEGER            INFO, K, LDA, N */
+/*       INTEGER            ISEED( 4 ) */
+/*       DOUBLE PRECISION   A( LDA, * ), D( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > DLAGSY generates a real symmetric matrix A, by pre- and post- */
+/* > multiplying a real diagonal matrix D with a random orthogonal matrix: */
+/* > A = U*D*U'. The semi-bandwidth may then be reduced to k by additional */
+/* > orthogonal transformations. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] K */
+/* > \verbatim */
+/* >          K is INTEGER */
+/* >          The number of nonzero subdiagonals within the band of A. */
+/* >          0 <= K <= N-1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is DOUBLE PRECISION array, dimension (N) */
+/* >          The diagonal elements of the diagonal matrix D. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] A */
+/* > \verbatim */
+/* >          A is DOUBLE PRECISION array, dimension (LDA,N) */
+/* >          The generated n by n symmetric matrix A (the full matrix is */
+/* >          stored). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension (4) */
+/* >          On entry, the seed of the random number generator; the array */
+/* >          elements must be between 0 and 4095, and ISEED(4) must be */
+/* >          odd. */
+/* >          On exit, the seed is updated. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK 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 double_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int dlagsy_(integer *n, integer *k, doublereal *d__, 
+	doublereal *a, integer *lda, integer *iseed, doublereal *work, 
+	integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+    doublereal d__1;
+
+    /* Local variables */
+    extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, 
+	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
+	    integer *);
+    extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, 
+	    integer *), dnrm2_(integer *, doublereal *, integer *);
+    extern /* Subroutine */ int dsyr2_(char *, integer *, doublereal *, 
+	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
+	    integer *);
+    integer i__, j;
+    doublereal alpha;
+    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
+	    integer *), dgemv_(char *, integer *, integer *, doublereal *, 
+	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
+	    doublereal *, integer *), daxpy_(integer *, doublereal *, 
+	    doublereal *, integer *, doublereal *, integer *), dsymv_(char *, 
+	    integer *, doublereal *, doublereal *, integer *, doublereal *, 
+	    integer *, doublereal *, doublereal *, integer *);
+    doublereal wa, wb, wn;
+    extern /* Subroutine */ int xerbla_(char *, integer *), dlarnv_(
+	    integer *, integer *, integer *, doublereal *);
+    doublereal tau;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    --d__;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --iseed;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    if (*n < 0) {
+	*info = -1;
+    } else if (*k < 0 || *k > *n - 1) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    }
+    if (*info < 0) {
+	i__1 = -(*info);
+	xerbla_("DLAGSY", &i__1);
+	return 0;
+    }
+
+/*     initialize lower triangle of A to diagonal matrix */
+
+    i__1 = *n;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *n;
+	for (i__ = j + 1; i__ <= i__2; ++i__) {
+	    a[i__ + j * a_dim1] = 0.;
+/* L10: */
+	}
+/* L20: */
+    }
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	a[i__ + i__ * a_dim1] = d__[i__];
+/* L30: */
+    }
+
+/*     Generate lower triangle of symmetric matrix */
+
+    for (i__ = *n - 1; i__ >= 1; --i__) {
+
+/*        generate random reflection */
+
+	i__1 = *n - i__ + 1;
+	dlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+	i__1 = *n - i__ + 1;
+	wn = dnrm2_(&i__1, &work[1], &c__1);
+	wa = d_sign(&wn, &work[1]);
+	if (wn == 0.) {
+	    tau = 0.;
+	} else {
+	    wb = work[1] + wa;
+	    i__1 = *n - i__;
+	    d__1 = 1. / wb;
+	    dscal_(&i__1, &d__1, &work[2], &c__1);
+	    work[1] = 1.;
+	    tau = wb / wa;
+	}
+
+/*        apply random reflection to A(i:n,i:n) from the left */
+/*        and the right */
+
+/*        compute  y := tau * A * u */
+
+	i__1 = *n - i__ + 1;
+	dsymv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], &
+		c__1, &c_b12, &work[*n + 1], &c__1);
+
+/*        compute  v := y - 1/2 * tau * ( y, u ) * u */
+
+	i__1 = *n - i__ + 1;
+	alpha = tau * -.5 * ddot_(&i__1, &work[*n + 1], &c__1, &work[1], &
+		c__1);
+	i__1 = *n - i__ + 1;
+	daxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
+
+/*        apply the transformation as a rank-2 update to A(i:n,i:n) */
+
+	i__1 = *n - i__ + 1;
+	dsyr2_("Lower", &i__1, &c_b19, &work[1], &c__1, &work[*n + 1], &c__1, 
+		&a[i__ + i__ * a_dim1], lda);
+/* L40: */
+    }
+
+/*     Reduce number of subdiagonals to K */
+
+    i__1 = *n - 1 - *k;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+
+/*        generate reflection to annihilate A(k+i+1:n,i) */
+
+	i__2 = *n - *k - i__ + 1;
+	wn = dnrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
+	wa = d_sign(&wn, &a[*k + i__ + i__ * a_dim1]);
+	if (wn == 0.) {
+	    tau = 0.;
+	} else {
+	    wb = a[*k + i__ + i__ * a_dim1] + wa;
+	    i__2 = *n - *k - i__;
+	    d__1 = 1. / wb;
+	    dscal_(&i__2, &d__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1);
+	    a[*k + i__ + i__ * a_dim1] = 1.;
+	    tau = wb / wa;
+	}
+
+/*        apply reflection to A(k+i:n,i+1:k+i-1) from the left */
+
+	i__2 = *n - *k - i__ + 1;
+	i__3 = *k - 1;
+	dgemv_("Transpose", &i__2, &i__3, &c_b26, &a[*k + i__ + (i__ + 1) * 
+		a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b12, &
+		work[1], &c__1);
+	i__2 = *n - *k - i__ + 1;
+	i__3 = *k - 1;
+	d__1 = -tau;
+	dger_(&i__2, &i__3, &d__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[
+		1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda);
+
+/*        apply reflection to A(k+i:n,k+i:n) from the left and the right */
+
+/*        compute  y := tau * A * u */
+
+	i__2 = *n - *k - i__ + 1;
+	dsymv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda, 
+		&a[*k + i__ + i__ * a_dim1], &c__1, &c_b12, &work[1], &c__1);
+
+/*        compute  v := y - 1/2 * tau * ( y, u ) * u */
+
+	i__2 = *n - *k - i__ + 1;
+	alpha = tau * -.5 * ddot_(&i__2, &work[1], &c__1, &a[*k + i__ + i__ * 
+		a_dim1], &c__1);
+	i__2 = *n - *k - i__ + 1;
+	daxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
+		c__1);
+
+/*        apply symmetric rank-2 update to A(k+i:n,k+i:n) */
+
+	i__2 = *n - *k - i__ + 1;
+	dsyr2_("Lower", &i__2, &c_b19, &a[*k + i__ + i__ * a_dim1], &c__1, &
+		work[1], &c__1, &a[*k + i__ + (*k + i__) * a_dim1], lda);
+
+	a[*k + i__ + i__ * a_dim1] = -wa;
+	i__2 = *n;
+	for (j = *k + i__ + 1; j <= i__2; ++j) {
+	    a[j + i__ * a_dim1] = 0.;
+/* L50: */
+	}
+/* L60: */
+    }
+
+/*     Store full symmetric matrix */
+
+    i__1 = *n;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *n;
+	for (i__ = j + 1; i__ <= i__2; ++i__) {
+	    a[j + i__ * a_dim1] = a[i__ + j * a_dim1];
+/* L70: */
+	}
+/* L80: */
+    }
+    return 0;
+
+/*     End of DLAGSY */
+
+} /* dlagsy_ */
+

lapack-netlib/TESTING/MATGEN/dlahilb.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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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 = 0.;
+
+/* > \brief \b DLAHILB */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE DLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, INFO) */
+
+/*       INTEGER N, NRHS, LDA, LDX, LDB, INFO */
+/*       DOUBLE PRECISION A(LDA, N), X(LDX, NRHS), B(LDB, NRHS), WORK(N) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > DLAHILB generates an N by N scaled Hilbert matrix in A along with */
+/* > NRHS right-hand sides in B and solutions in X such that A*X=B. */
+/* > */
+/* > The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all */
+/* > entries are integers.  The right-hand sides are the first NRHS */
+/* > columns of M * the identity matrix, and the solutions are the */
+/* > first NRHS columns of the inverse Hilbert matrix. */
+/* > */
+/* > The condition number of the Hilbert matrix grows exponentially with */
+/* > its size, roughly as O(e ** (3.5*N)).  Additionally, the inverse */
+/* > Hilbert matrices beyond a relatively small dimension cannot be */
+/* > generated exactly without extra precision.  Precision is exhausted */
+/* > when the largest entry in the inverse Hilbert matrix is greater than */
+/* > 2 to the power of the number of bits in the fraction of the data type */
+/* > used plus one, which is 24 for single precision. */
+/* > */
+/* > In single, the generated solution is exact for N <= 6 and has */
+/* > small componentwise error for 7 <= N <= 11. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The dimension of the matrix A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The requested number of right-hand sides. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] A */
+/* > \verbatim */
+/* >          A is DOUBLE PRECISION array, dimension (LDA, N) */
+/* >          The generated scaled Hilbert matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] X */
+/* > \verbatim */
+/* >          X is DOUBLE PRECISION array, dimension (LDX, NRHS) */
+/* >          The generated exact solutions.  Currently, the first NRHS */
+/* >          columns of the inverse Hilbert matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDX */
+/* > \verbatim */
+/* >          LDX is INTEGER */
+/* >          The leading dimension of the array X.  LDX >= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] B */
+/* > \verbatim */
+/* >          B is DOUBLE PRECISION array, dimension (LDB, NRHS) */
+/* >          The generated right-hand sides.  Currently, the first NRHS */
+/* >          columns of LCM(1, 2, ..., 2*N-1) * the identity matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is DOUBLE PRECISION array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit */
+/* >          = 1: N is too large; the data is still generated but may not */
+/* >               be not exact. */
+/* >          < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date November 2017 */
+
+/* > \ingroup double_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int dlahilb_(integer *n, integer *nrhs, doublereal *a, 
+	integer *lda, doublereal *x, integer *ldx, doublereal *b, integer *
+	ldb, doublereal *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, x_dim1, x_offset, b_dim1, b_offset, i__1, i__2;
+    doublereal d__1;
+
+    /* Local variables */
+    integer i__, j, m, r__, ti, tm;
+    extern /* Subroutine */ int dlaset_(char *, integer *, integer *, 
+	    doublereal *, doublereal *, doublereal *, integer *), 
+	    xerbla_(char *, integer *);
+
+
+/*  -- LAPACK test routine (version 3.8.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     November 2017 */
+
+
+/*  ===================================================================== */
+/*     NMAX_EXACT   the largest dimension where the generated data is */
+/*                  exact. */
+/*     NMAX_APPROX  the largest dimension where the generated data has */
+/*                  a small componentwise relative error. */
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    --work;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    x_dim1 = *ldx;
+    x_offset = 1 + x_dim1 * 1;
+    x -= x_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+
+    /* Function Body */
+    *info = 0;
+    if (*n < 0 || *n > 11) {
+	*info = -1;
+    } else if (*nrhs < 0) {
+	*info = -2;
+    } else if (*lda < *n) {
+	*info = -4;
+    } else if (*ldx < *n) {
+	*info = -6;
+    } else if (*ldb < *n) {
+	*info = -8;
+    }
+    if (*info < 0) {
+	i__1 = -(*info);
+	xerbla_("DLAHILB", &i__1);
+	return 0;
+    }
+    if (*n > 6) {
+	*info = 1;
+    }
+
+/*     Compute M = the LCM of the integers [1, 2*N-1].  The largest */
+/*     reasonable N is small enough that integers suffice (up to N = 11). */
+    m = 1;
+    i__1 = (*n << 1) - 1;
+    for (i__ = 2; i__ <= i__1; ++i__) {
+	tm = m;
+	ti = i__;
+	r__ = tm % ti;
+	while(r__ != 0) {
+	    tm = ti;
+	    ti = r__;
+	    r__ = tm % ti;
+	}
+	m = m / ti * i__;
+    }
+
+/*     Generate the scaled Hilbert matrix in A */
+    i__1 = *n;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *n;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    a[i__ + j * a_dim1] = (doublereal) m / (i__ + j - 1);
+	}
+    }
+
+/*     Generate matrix B as simply the first NRHS columns of M * the */
+/*     identity. */
+    d__1 = (doublereal) m;
+    dlaset_("Full", n, nrhs, &c_b4, &d__1, &b[b_offset], ldb);
+/*     Generate the true solutions in X.  Because B = the first NRHS */
+/*     columns of M*I, the true solutions are just the first NRHS columns */
+/*     of the inverse Hilbert matrix. */
+    work[1] = (doublereal) (*n);
+    i__1 = *n;
+    for (j = 2; j <= i__1; ++j) {
+	work[j] = work[j - 1] / (j - 1) * (j - 1 - *n) / (j - 1) * (*n + j - 
+		1);
+    }
+
+    i__1 = *nrhs;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *n;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    x[i__ + j * x_dim1] = work[i__] * work[j] / (i__ + j - 1);
+	}
+    }
+
+    return 0;
+} /* dlahilb_ */
+

lapack-netlib/TESTING/MATGEN/dlakf2.c

@@ -0,0 +1,615 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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_b3 = 0.;
+
+/* > \brief \b DLAKF2 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE DLAKF2( M, N, A, LDA, B, D, E, Z, LDZ ) */
+
+/*       INTEGER            LDA, LDZ, M, N */
+/*       DOUBLE PRECISION   A( LDA, * ), B( LDA, * ), D( LDA, * ), */
+/*      $                   E( LDA, * ), Z( LDZ, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > Form the 2*M*N by 2*M*N matrix */
+/* > */
+/* >        Z = [ kron(In, A)  -kron(B', Im) ] */
+/* >            [ kron(In, D)  -kron(E', Im) ], */
+/* > */
+/* > where In is the identity matrix of size n and X' is the transpose */
+/* > of X. kron(X, Y) is the Kronecker product between the matrices X */
+/* > and Y. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          Size of matrix, must be >= 1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          Size of matrix, must be >= 1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] A */
+/* > \verbatim */
+/* >          A is DOUBLE PRECISION, dimension ( LDA, M ) */
+/* >          The matrix A in the output matrix Z. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of A, B, D, and E. ( LDA >= M+N ) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] B */
+/* > \verbatim */
+/* >          B is DOUBLE PRECISION, dimension ( LDA, N ) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is DOUBLE PRECISION, dimension ( LDA, M ) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] E */
+/* > \verbatim */
+/* >          E is DOUBLE PRECISION, dimension ( LDA, N ) */
+/* > */
+/* >          The matrices used in forming the output matrix Z. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Z */
+/* > \verbatim */
+/* >          Z is DOUBLE PRECISION, dimension ( LDZ, 2*M*N ) */
+/* >          The resultant Kronecker M*N*2 by M*N*2 matrix (see above.) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDZ */
+/* > \verbatim */
+/* >          LDZ is INTEGER */
+/* >          The leading dimension of Z. ( LDZ >= 2*M*N ) */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup double_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int dlakf2_(integer *m, integer *n, doublereal *a, integer *
+	lda, doublereal *b, doublereal *d__, doublereal *e, doublereal *z__, 
+	integer *ldz)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, d_dim1, d_offset, e_dim1, 
+	    e_offset, z_dim1, z_offset, i__1, i__2, i__3;
+
+    /* Local variables */
+    integer i__, j, l, ik, jk, mn;
+    extern /* Subroutine */ int dlaset_(char *, integer *, integer *, 
+	    doublereal *, doublereal *, doublereal *, integer *);
+    integer mn2;
+
+
+/*  -- 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 */
+
+
+/*  ==================================================================== */
+
+
+/*     Initialize Z */
+
+    /* Parameter adjustments */
+    e_dim1 = *lda;
+    e_offset = 1 + e_dim1 * 1;
+    e -= e_offset;
+    d_dim1 = *lda;
+    d_offset = 1 + d_dim1 * 1;
+    d__ -= d_offset;
+    b_dim1 = *lda;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    z_dim1 = *ldz;
+    z_offset = 1 + z_dim1 * 1;
+    z__ -= z_offset;
+
+    /* Function Body */
+    mn = *m * *n;
+    mn2 = mn << 1;
+    dlaset_("Full", &mn2, &mn2, &c_b3, &c_b3, &z__[z_offset], ldz);
+
+    ik = 1;
+    i__1 = *n;
+    for (l = 1; l <= i__1; ++l) {
+
+/*        form kron(In, A) */
+
+	i__2 = *m;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    i__3 = *m;
+	    for (j = 1; j <= i__3; ++j) {
+		z__[ik + i__ - 1 + (ik + j - 1) * z_dim1] = a[i__ + j * 
+			a_dim1];
+/* L10: */
+	    }
+/* L20: */
+	}
+
+/*        form kron(In, D) */
+
+	i__2 = *m;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    i__3 = *m;
+	    for (j = 1; j <= i__3; ++j) {
+		z__[ik + mn + i__ - 1 + (ik + j - 1) * z_dim1] = d__[i__ + j *
+			 d_dim1];
+/* L30: */
+	    }
+/* L40: */
+	}
+
+	ik += *m;
+/* L50: */
+    }
+
+    ik = 1;
+    i__1 = *n;
+    for (l = 1; l <= i__1; ++l) {
+	jk = mn + 1;
+
+	i__2 = *n;
+	for (j = 1; j <= i__2; ++j) {
+
+/*           form -kron(B', Im) */
+
+	    i__3 = *m;
+	    for (i__ = 1; i__ <= i__3; ++i__) {
+		z__[ik + i__ - 1 + (jk + i__ - 1) * z_dim1] = -b[j + l * 
+			b_dim1];
+/* L60: */
+	    }
+
+/*           form -kron(E', Im) */
+
+	    i__3 = *m;
+	    for (i__ = 1; i__ <= i__3; ++i__) {
+		z__[ik + mn + i__ - 1 + (jk + i__ - 1) * z_dim1] = -e[j + l * 
+			e_dim1];
+/* L70: */
+	    }
+
+	    jk += *m;
+/* L80: */
+	}
+
+	ik += *m;
+/* L90: */
+    }
+
+    return 0;
+
+/*     End of DLAKF2 */
+
+} /* dlakf2_ */
+

lapack-netlib/TESTING/MATGEN/dlaran.c

@@ -0,0 +1,526 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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)
+*/
+
+
+
+/* > \brief \b DLARAN */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       DOUBLE PRECISION FUNCTION DLARAN( ISEED ) */
+
+/*       INTEGER            ISEED( 4 ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > DLARAN returns a random real number from a uniform (0,1) */
+/* > distribution. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension (4) */
+/* >          On entry, the seed of the random number generator; the array */
+/* >          elements must be between 0 and 4095, and ISEED(4) must be */
+/* >          odd. */
+/* >          On exit, the seed is updated. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup list_temp */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  This routine uses a multiplicative congruential method with modulus */
+/* >  2**48 and multiplier 33952834046453 (see G.S.Fishman, */
+/* >  'Multiplicative congruential random number generators with modulus */
+/* >  2**b: an exhaustive analysis for b = 32 and a partial analysis for */
+/* >  b = 48', Math. Comp. 189, pp 331-344, 1990). */
+/* > */
+/* >  48-bit integers are stored in 4 integer array elements with 12 bits */
+/* >  per element. Hence the routine is portable across machines with */
+/* >  integers of 32 bits or more. */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+doublereal dlaran_(integer *iseed)
+{
+    /* System generated locals */
+    doublereal ret_val;
+
+    /* Local variables */
+    doublereal rndout;
+    integer it1, it2, it3, it4;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+    /* Parameter adjustments */
+    --iseed;
+
+    /* Function Body */
+L10:
+
+/*     multiply the seed by the multiplier modulo 2**48 */
+
+    it4 = iseed[4] * 2549;
+    it3 = it4 / 4096;
+    it4 -= it3 << 12;
+    it3 = it3 + iseed[3] * 2549 + iseed[4] * 2508;
+    it2 = it3 / 4096;
+    it3 -= it2 << 12;
+    it2 = it2 + iseed[2] * 2549 + iseed[3] * 2508 + iseed[4] * 322;
+    it1 = it2 / 4096;
+    it2 -= it1 << 12;
+    it1 = it1 + iseed[1] * 2549 + iseed[2] * 2508 + iseed[3] * 322 + iseed[4] 
+	    * 494;
+    it1 %= 4096;
+
+/*     return updated seed */
+
+    iseed[1] = it1;
+    iseed[2] = it2;
+    iseed[3] = it3;
+    iseed[4] = it4;
+
+/*     convert 48-bit integer to a real number in the interval (0,1) */
+
+    rndout = ((doublereal) it1 + ((doublereal) it2 + ((doublereal) it3 + (
+	    doublereal) it4 * 2.44140625e-4) * 2.44140625e-4) * 2.44140625e-4)
+	     * 2.44140625e-4;
+
+    if (rndout == 1.) {
+/*        If a real number has n bits of precision, and the first */
+/*        n bits of the 48-bit integer above happen to be all 1 (which */
+/*        will occur about once every 2**n calls), then DLARAN will */
+/*        be rounded to exactly 1.0. */
+/*        Since DLARAN is not supposed to return exactly 0.0 or 1.0 */
+/*        (and some callers of DLARAN, such as CLARND, depend on that), */
+/*        the statistically correct thing to do in this situation is */
+/*        simply to iterate again. */
+/*        N.B. the case DLARAN = 0.0 should not be possible. */
+
+	goto L10;
+    }
+
+    ret_val = rndout;
+    return ret_val;
+
+/*     End of DLARAN */
+
+} /* dlaran_ */
+

lapack-netlib/TESTING/MATGEN/dlarge.c

@@ -0,0 +1,581 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__3 = 3;
+static integer c__1 = 1;
+static doublereal c_b8 = 1.;
+static doublereal c_b10 = 0.;
+
+/* > \brief \b DLARGE */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE DLARGE( N, A, LDA, ISEED, WORK, INFO ) */
+
+/*       INTEGER            INFO, LDA, N */
+/*       INTEGER            ISEED( 4 ) */
+/*       DOUBLE PRECISION   A( LDA, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > DLARGE pre- and post-multiplies a real general n by n matrix A */
+/* > with a random orthogonal matrix: A = U*D*U'. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is DOUBLE PRECISION array, dimension (LDA,N) */
+/* >          On entry, the original n by n matrix A. */
+/* >          On exit, A is overwritten by U*A*U' for some random */
+/* >          orthogonal matrix U. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension (4) */
+/* >          On entry, the seed of the random number generator; the array */
+/* >          elements must be between 0 and 4095, and ISEED(4) must be */
+/* >          odd. */
+/* >          On exit, the seed is updated. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK 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 double_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int dlarge_(integer *n, doublereal *a, integer *lda, integer 
+	*iseed, doublereal *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1;
+    doublereal d__1;
+
+    /* Local variables */
+    extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, 
+	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
+	    integer *);
+    extern doublereal dnrm2_(integer *, doublereal *, integer *);
+    integer i__;
+    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
+	    integer *), dgemv_(char *, integer *, integer *, doublereal *, 
+	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
+	    doublereal *, integer *);
+    doublereal wa, wb, wn;
+    extern /* Subroutine */ int xerbla_(char *, integer *), dlarnv_(
+	    integer *, integer *, integer *, doublereal *);
+    doublereal tau;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --iseed;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    if (*n < 0) {
+	*info = -1;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -3;
+    }
+    if (*info < 0) {
+	i__1 = -(*info);
+	xerbla_("DLARGE", &i__1);
+	return 0;
+    }
+
+/*     pre- and post-multiply A by random orthogonal matrix */
+
+    for (i__ = *n; i__ >= 1; --i__) {
+
+/*        generate random reflection */
+
+	i__1 = *n - i__ + 1;
+	dlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+	i__1 = *n - i__ + 1;
+	wn = dnrm2_(&i__1, &work[1], &c__1);
+	wa = d_sign(&wn, &work[1]);
+	if (wn == 0.) {
+	    tau = 0.;
+	} else {
+	    wb = work[1] + wa;
+	    i__1 = *n - i__;
+	    d__1 = 1. / wb;
+	    dscal_(&i__1, &d__1, &work[2], &c__1);
+	    work[1] = 1.;
+	    tau = wb / wa;
+	}
+
+/*        multiply A(i:n,1:n) by random reflection from the left */
+
+	i__1 = *n - i__ + 1;
+	dgemv_("Transpose", &i__1, n, &c_b8, &a[i__ + a_dim1], lda, &work[1], 
+		&c__1, &c_b10, &work[*n + 1], &c__1);
+	i__1 = *n - i__ + 1;
+	d__1 = -tau;
+	dger_(&i__1, n, &d__1, &work[1], &c__1, &work[*n + 1], &c__1, &a[i__ 
+		+ a_dim1], lda);
+
+/*        multiply A(1:n,i:n) by random reflection from the right */
+
+	i__1 = *n - i__ + 1;
+	dgemv_("No transpose", n, &i__1, &c_b8, &a[i__ * a_dim1 + 1], lda, &
+		work[1], &c__1, &c_b10, &work[*n + 1], &c__1);
+	i__1 = *n - i__ + 1;
+	d__1 = -tau;
+	dger_(n, &i__1, &d__1, &work[*n + 1], &c__1, &work[1], &c__1, &a[i__ *
+		 a_dim1 + 1], lda);
+/* L10: */
+    }
+    return 0;
+
+/*     End of DLARGE */
+
+} /* dlarge_ */
+

lapack-netlib/TESTING/MATGEN/dlarnd.c

@@ -0,0 +1,508 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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)
+*/
+
+
+
+/* > \brief \b DLARND */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       DOUBLE PRECISION FUNCTION DLARND( IDIST, ISEED ) */
+
+/*       INTEGER            IDIST */
+/*       INTEGER            ISEED( 4 ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > DLARND returns a random real number from a uniform or normal */
+/* > distribution. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] IDIST */
+/* > \verbatim */
+/* >          IDIST is INTEGER */
+/* >          Specifies the distribution of the random numbers: */
+/* >          = 1:  uniform (0,1) */
+/* >          = 2:  uniform (-1,1) */
+/* >          = 3:  normal (0,1) */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension (4) */
+/* >          On entry, the seed of the random number generator; the array */
+/* >          elements must be between 0 and 4095, and ISEED(4) must be */
+/* >          odd. */
+/* >          On exit, the seed is updated. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup double_matgen */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  This routine calls the auxiliary routine DLARAN to generate a random */
+/* >  real number from a uniform (0,1) distribution. The Box-Muller method */
+/* >  is used to transform numbers from a uniform to a normal distribution. */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+doublereal dlarnd_(integer *idist, integer *iseed)
+{
+    /* System generated locals */
+    doublereal ret_val;
+
+    /* Local variables */
+    doublereal t1, t2;
+    extern doublereal dlaran_(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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Generate a real random number from a uniform (0,1) distribution */
+
+    /* Parameter adjustments */
+    --iseed;
+
+    /* Function Body */
+    t1 = dlaran_(&iseed[1]);
+
+    if (*idist == 1) {
+
+/*        uniform (0,1) */
+
+	ret_val = t1;
+    } else if (*idist == 2) {
+
+/*        uniform (-1,1) */
+
+	ret_val = t1 * 2. - 1.;
+    } else if (*idist == 3) {
+
+/*        normal (0,1) */
+
+	t2 = dlaran_(&iseed[1]);
+	ret_val = sqrt(log(t1) * -2.) * cos(t2 * 
+		6.2831853071795864769252867663);
+    }
+    return ret_val;
+
+/*     End of DLARND */
+
+} /* dlarnd_ */
+

lapack-netlib/TESTING/MATGEN/dlaror.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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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_b9 = 0.;
+static doublereal c_b10 = 1.;
+static integer c__3 = 3;
+static integer c__1 = 1;
+
+/* > \brief \b DLAROR */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE DLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO ) */
+
+/*       CHARACTER          INIT, SIDE */
+/*       INTEGER            INFO, LDA, M, N */
+/*       INTEGER            ISEED( 4 ) */
+/*       DOUBLE PRECISION   A( LDA, * ), X( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > DLAROR pre- or post-multiplies an M by N matrix A by a random */
+/* > orthogonal matrix U, overwriting A.  A may optionally be initialized */
+/* > to the identity matrix before multiplying by U.  U is generated using */
+/* > the method of G.W. Stewart (SIAM J. Numer. Anal. 17, 1980, 403-409). */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] SIDE */
+/* > \verbatim */
+/* >          SIDE is CHARACTER*1 */
+/* >          Specifies whether A is multiplied on the left or right by U. */
+/* >          = 'L':         Multiply A on the left (premultiply) by U */
+/* >          = 'R':         Multiply A on the right (postmultiply) by U' */
+/* >          = 'C' or 'T':  Multiply A on the left by U and the right */
+/* >                          by U' (Here, U' means U-transpose.) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] INIT */
+/* > \verbatim */
+/* >          INIT is CHARACTER*1 */
+/* >          Specifies whether or not A should be initialized to the */
+/* >          identity matrix. */
+/* >          = 'I':  Initialize A to (a section of) the identity matrix */
+/* >                   before applying U. */
+/* >          = 'N':  No initialization.  Apply U to the input matrix A. */
+/* > */
+/* >          INIT = 'I' may be used to generate square or rectangular */
+/* >          orthogonal matrices: */
+/* > */
+/* >          For M = N and SIDE = 'L' or 'R', the rows will be orthogonal */
+/* >          to each other, as will the columns. */
+/* > */
+/* >          If M < N, SIDE = 'R' produces a dense matrix whose rows are */
+/* >          orthogonal and whose columns are not, while SIDE = 'L' */
+/* >          produces a matrix whose rows are orthogonal, and whose first */
+/* >          M columns are orthogonal, and whose remaining columns are */
+/* >          zero. */
+/* > */
+/* >          If M > N, SIDE = 'L' produces a dense matrix whose columns */
+/* >          are orthogonal and whose rows are not, while SIDE = 'R' */
+/* >          produces a matrix whose columns are orthogonal, and whose */
+/* >          first M rows are orthogonal, and whose remaining rows are */
+/* >          zero. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is DOUBLE PRECISION array, dimension (LDA, N) */
+/* >          On entry, the array A. */
+/* >          On exit, overwritten by U A ( if SIDE = 'L' ), */
+/* >           or by A U ( if SIDE = 'R' ), */
+/* >           or by U A U' ( if SIDE = 'C' or 'T'). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension (4) */
+/* >          On entry ISEED specifies the seed of the random number */
+/* >          generator. The array elements should be between 0 and 4095; */
+/* >          if not they will be reduced mod 4096.  Also, ISEED(4) must */
+/* >          be odd.  The random number generator uses a linear */
+/* >          congruential sequence limited to small integers, and so */
+/* >          should produce machine independent random numbers. The */
+/* >          values of ISEED are changed on exit, and can be used in the */
+/* >          next call to DLAROR to continue the same random number */
+/* >          sequence. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] X */
+/* > \verbatim */
+/* >          X is DOUBLE PRECISION array, dimension (3*MAX( M, N )) */
+/* >          Workspace of length */
+/* >              2*M + N if SIDE = 'L', */
+/* >              2*N + M if SIDE = 'R', */
+/* >              3*N     if SIDE = 'C' or 'T'. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          An error flag.  It is set to: */
+/* >          = 0:  normal return */
+/* >          < 0:  if INFO = -k, the k-th argument had an illegal value */
+/* >          = 1:  if the random numbers generated by DLARND are bad. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup double_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int dlaror_(char *side, char *init, integer *m, integer *n, 
+	doublereal *a, integer *lda, integer *iseed, doublereal *x, integer *
+	info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+    doublereal d__1;
+
+    /* Local variables */
+    integer kbeg;
+    extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, 
+	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
+	    integer *);
+    integer jcol, irow;
+    extern doublereal dnrm2_(integer *, doublereal *, integer *);
+    integer j;
+    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
+	    integer *);
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int dgemv_(char *, integer *, integer *, 
+	    doublereal *, doublereal *, integer *, doublereal *, integer *, 
+	    doublereal *, doublereal *, integer *);
+    integer ixfrm, itype, nxfrm;
+    doublereal xnorm;
+    extern doublereal dlarnd_(integer *, integer *);
+    extern /* Subroutine */ int dlaset_(char *, integer *, integer *, 
+	    doublereal *, doublereal *, doublereal *, integer *), 
+	    xerbla_(char *, integer *);
+    doublereal factor, xnorms;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --iseed;
+    --x;
+
+    /* Function Body */
+    *info = 0;
+    if (*n == 0 || *m == 0) {
+	return 0;
+    }
+
+    itype = 0;
+    if (lsame_(side, "L")) {
+	itype = 1;
+    } else if (lsame_(side, "R")) {
+	itype = 2;
+    } else if (lsame_(side, "C") || lsame_(side, "T")) {
+	itype = 3;
+    }
+
+/*     Check for argument errors. */
+
+    if (itype == 0) {
+	*info = -1;
+    } else if (*m < 0) {
+	*info = -3;
+    } else if (*n < 0 || itype == 3 && *n != *m) {
+	*info = -4;
+    } else if (*lda < *m) {
+	*info = -6;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("DLAROR", &i__1);
+	return 0;
+    }
+
+    if (itype == 1) {
+	nxfrm = *m;
+    } else {
+	nxfrm = *n;
+    }
+
+/*     Initialize A to the identity matrix if desired */
+
+    if (lsame_(init, "I")) {
+	dlaset_("Full", m, n, &c_b9, &c_b10, &a[a_offset], lda);
+    }
+
+/*     If no rotation possible, multiply by random +/-1 */
+
+/*     Compute rotation by computing Householder transformations */
+/*     H(2), H(3), ..., H(nhouse) */
+
+    i__1 = nxfrm;
+    for (j = 1; j <= i__1; ++j) {
+	x[j] = 0.;
+/* L10: */
+    }
+
+    i__1 = nxfrm;
+    for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) {
+	kbeg = nxfrm - ixfrm + 1;
+
+/*        Generate independent normal( 0, 1 ) random numbers */
+
+	i__2 = nxfrm;
+	for (j = kbeg; j <= i__2; ++j) {
+	    x[j] = dlarnd_(&c__3, &iseed[1]);
+/* L20: */
+	}
+
+/*        Generate a Householder transformation from the random vector X */
+
+	xnorm = dnrm2_(&ixfrm, &x[kbeg], &c__1);
+	xnorms = d_sign(&xnorm, &x[kbeg]);
+	d__1 = -x[kbeg];
+	x[kbeg + nxfrm] = d_sign(&c_b10, &d__1);
+	factor = xnorms * (xnorms + x[kbeg]);
+	if (abs(factor) < 1e-20) {
+	    *info = 1;
+	    xerbla_("DLAROR", info);
+	    return 0;
+	} else {
+	    factor = 1. / factor;
+	}
+	x[kbeg] += xnorms;
+
+/*        Apply Householder transformation to A */
+
+	if (itype == 1 || itype == 3) {
+
+/*           Apply H(k) from the left. */
+
+	    dgemv_("T", &ixfrm, n, &c_b10, &a[kbeg + a_dim1], lda, &x[kbeg], &
+		    c__1, &c_b9, &x[(nxfrm << 1) + 1], &c__1);
+	    d__1 = -factor;
+	    dger_(&ixfrm, n, &d__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], &
+		    c__1, &a[kbeg + a_dim1], lda);
+
+	}
+
+	if (itype == 2 || itype == 3) {
+
+/*           Apply H(k) from the right. */
+
+	    dgemv_("N", m, &ixfrm, &c_b10, &a[kbeg * a_dim1 + 1], lda, &x[
+		    kbeg], &c__1, &c_b9, &x[(nxfrm << 1) + 1], &c__1);
+	    d__1 = -factor;
+	    dger_(m, &ixfrm, &d__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], &
+		    c__1, &a[kbeg * a_dim1 + 1], lda);
+
+	}
+/* L30: */
+    }
+
+    d__1 = dlarnd_(&c__3, &iseed[1]);
+    x[nxfrm * 2] = d_sign(&c_b10, &d__1);
+
+/*     Scale the matrix A by D. */
+
+    if (itype == 1 || itype == 3) {
+	i__1 = *m;
+	for (irow = 1; irow <= i__1; ++irow) {
+	    dscal_(n, &x[nxfrm + irow], &a[irow + a_dim1], lda);
+/* L40: */
+	}
+    }
+
+    if (itype == 2 || itype == 3) {
+	i__1 = *n;
+	for (jcol = 1; jcol <= i__1; ++jcol) {
+	    dscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1);
+/* L50: */
+	}
+    }
+    return 0;
+
+/*     End of DLAROR */
+
+} /* dlaror_ */
+

lapack-netlib/TESTING/MATGEN/dlarot.c

@@ -0,0 +1,709 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__4 = 4;
+static integer c__8 = 8;
+static integer c__1 = 1;
+
+/* > \brief \b DLAROT */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE DLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, */
+/*                          XRIGHT ) */
+
+/*       LOGICAL            LLEFT, LRIGHT, LROWS */
+/*       INTEGER            LDA, NL */
+/*       DOUBLE PRECISION   C, S, XLEFT, XRIGHT */
+/*       DOUBLE PRECISION   A( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* >    DLAROT applies a (Givens) rotation to two adjacent rows or */
+/* >    columns, where one element of the first and/or last column/row */
+/* >    for use on matrices stored in some format other than GE, so */
+/* >    that elements of the matrix may be used or modified for which */
+/* >    no array element is provided. */
+/* > */
+/* >    One example is a symmetric matrix in SB format (bandwidth=4), for */
+/* >    which UPLO='L':  Two adjacent rows will have the format: */
+/* > */
+/* >    row j:     C> C> C> C> C> .  .  .  . */
+/* >    row j+1:      C> C> C> C> C> .  .  .  . */
+/* > */
+/* >    '*' indicates elements for which storage is provided, */
+/* >    '.' indicates elements for which no storage is provided, but */
+/* >    are not necessarily zero; their values are determined by */
+/* >    symmetry.  ' ' indicates elements which are necessarily zero, */
+/* >     and have no storage provided. */
+/* > */
+/* >    Those columns which have two '*'s can be handled by DROT. */
+/* >    Those columns which have no '*'s can be ignored, since as long */
+/* >    as the Givens rotations are carefully applied to preserve */
+/* >    symmetry, their values are determined. */
+/* >    Those columns which have one '*' have to be handled separately, */
+/* >    by using separate variables "p" and "q": */
+/* > */
+/* >    row j:     C> C> C> C> C> p  .  .  . */
+/* >    row j+1:   q  C> C> C> C> C> .  .  .  . */
+/* > */
+/* >    The element p would have to be set correctly, then that column */
+/* >    is rotated, setting p to its new value.  The next call to */
+/* >    DLAROT would rotate columns j and j+1, using p, and restore */
+/* >    symmetry.  The element q would start out being zero, and be */
+/* >    made non-zero by the rotation.  Later, rotations would presumably */
+/* >    be chosen to zero q out. */
+/* > */
+/* >    Typical Calling Sequences: rotating the i-th and (i+1)-st rows. */
+/* >    ------- ------- --------- */
+/* > */
+/* >      General dense matrix: */
+/* > */
+/* >              CALL DLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S, */
+/* >                      A(i,1),LDA, DUMMY, DUMMY) */
+/* > */
+/* >      General banded matrix in GB format: */
+/* > */
+/* >              j = MAX(1, i-KL ) */
+/* >              NL = MIN( N, i+KU+1 ) + 1-j */
+/* >              CALL DLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S, */
+/* >                      A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT ) */
+/* > */
+/* >              [ note that i+1-j is just MIN(i,KL+1) ] */
+/* > */
+/* >      Symmetric banded matrix in SY format, bandwidth K, */
+/* >      lower triangle only: */
+/* > */
+/* >              j = MAX(1, i-K ) */
+/* >              NL = MIN( K+1, i ) + 1 */
+/* >              CALL DLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S, */
+/* >                      A(i,j), LDA, XLEFT, XRIGHT ) */
+/* > */
+/* >      Same, but upper triangle only: */
+/* > */
+/* >              NL = MIN( K+1, N-i ) + 1 */
+/* >              CALL DLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S, */
+/* >                      A(i,i), LDA, XLEFT, XRIGHT ) */
+/* > */
+/* >      Symmetric banded matrix in SB format, bandwidth K, */
+/* >      lower triangle only: */
+/* > */
+/* >              [ same as for SY, except:] */
+/* >                  . . . . */
+/* >                      A(i+1-j,j), LDA-1, XLEFT, XRIGHT ) */
+/* > */
+/* >              [ note that i+1-j is just MIN(i,K+1) ] */
+/* > */
+/* >      Same, but upper triangle only: */
+/* >                   . . . */
+/* >                      A(K+1,i), LDA-1, XLEFT, XRIGHT ) */
+/* > */
+/* >      Rotating columns is just the transpose of rotating rows, except */
+/* >      for GB and SB: (rotating columns i and i+1) */
+/* > */
+/* >      GB: */
+/* >              j = MAX(1, i-KU ) */
+/* >              NL = MIN( N, i+KL+1 ) + 1-j */
+/* >              CALL DLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S, */
+/* >                      A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM ) */
+/* > */
+/* >              [note that KU+j+1-i is just MAX(1,KU+2-i)] */
+/* > */
+/* >      SB: (upper triangle) */
+/* > */
+/* >                   . . . . . . */
+/* >                      A(K+j+1-i,i),LDA-1, XTOP, XBOTTM ) */
+/* > */
+/* >      SB: (lower triangle) */
+/* > */
+/* >                   . . . . . . */
+/* >                      A(1,i),LDA-1, XTOP, XBOTTM ) */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \verbatim */
+/* >  LROWS  - LOGICAL */
+/* >           If .TRUE., then DLAROT will rotate two rows.  If .FALSE., */
+/* >           then it will rotate two columns. */
+/* >           Not modified. */
+/* > */
+/* >  LLEFT  - LOGICAL */
+/* >           If .TRUE., then XLEFT will be used instead of the */
+/* >           corresponding element of A for the first element in the */
+/* >           second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) */
+/* >           If .FALSE., then the corresponding element of A will be */
+/* >           used. */
+/* >           Not modified. */
+/* > */
+/* >  LRIGHT - LOGICAL */
+/* >           If .TRUE., then XRIGHT will be used instead of the */
+/* >           corresponding element of A for the last element in the */
+/* >           first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If */
+/* >           .FALSE., then the corresponding element of A will be used. */
+/* >           Not modified. */
+/* > */
+/* >  NL     - INTEGER */
+/* >           The length of the rows (if LROWS=.TRUE.) or columns (if */
+/* >           LROWS=.FALSE.) to be rotated.  If XLEFT and/or XRIGHT are */
+/* >           used, the columns/rows they are in should be included in */
+/* >           NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at */
+/* >           least 2.  The number of rows/columns to be rotated */
+/* >           exclusive of those involving XLEFT and/or XRIGHT may */
+/* >           not be negative, i.e., NL minus how many of LLEFT and */
+/* >           LRIGHT are .TRUE. must be at least zero; if not, XERBLA */
+/* >           will be called. */
+/* >           Not modified. */
+/* > */
+/* >  C, S   - DOUBLE PRECISION */
+/* >           Specify the Givens rotation to be applied.  If LROWS is */
+/* >           true, then the matrix ( c  s ) */
+/* >                                 (-s  c )  is applied from the left; */
+/* >           if false, then the transpose thereof is applied from the */
+/* >           right.  For a Givens rotation, C**2 + S**2 should be 1, */
+/* >           but this is not checked. */
+/* >           Not modified. */
+/* > */
+/* >  A      - DOUBLE PRECISION array. */
+/* >           The array containing the rows/columns to be rotated.  The */
+/* >           first element of A should be the upper left element to */
+/* >           be rotated. */
+/* >           Read and modified. */
+/* > */
+/* >  LDA    - INTEGER */
+/* >           The "effective" leading dimension of A.  If A contains */
+/* >           a matrix stored in GE or SY format, then this is just */
+/* >           the leading dimension of A as dimensioned in the calling */
+/* >           routine.  If A contains a matrix stored in band (GB or SB) */
+/* >           format, then this should be *one less* than the leading */
+/* >           dimension used in the calling routine.  Thus, if */
+/* >           A were dimensioned A(LDA,*) in DLAROT, then A(1,j) would */
+/* >           be the j-th element in the first of the two rows */
+/* >           to be rotated, and A(2,j) would be the j-th in the second, */
+/* >           regardless of how the array may be stored in the calling */
+/* >           routine.  [A cannot, however, actually be dimensioned thus, */
+/* >           since for band format, the row number may exceed LDA, which */
+/* >           is not legal FORTRAN.] */
+/* >           If LROWS=.TRUE., then LDA must be at least 1, otherwise */
+/* >           it must be at least NL minus the number of .TRUE. values */
+/* >           in XLEFT and XRIGHT. */
+/* >           Not modified. */
+/* > */
+/* >  XLEFT  - DOUBLE PRECISION */
+/* >           If LLEFT is .TRUE., then XLEFT will be used and modified */
+/* >           instead of A(2,1) (if LROWS=.TRUE.) or A(1,2) */
+/* >           (if LROWS=.FALSE.). */
+/* >           Read and modified. */
+/* > */
+/* >  XRIGHT - DOUBLE PRECISION */
+/* >           If LRIGHT is .TRUE., then XRIGHT will be used and modified */
+/* >           instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1) */
+/* >           (if LROWS=.FALSE.). */
+/* >           Read and modified. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup double_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int dlarot_(logical *lrows, logical *lleft, logical *lright, 
+	integer *nl, doublereal *c__, doublereal *s, doublereal *a, integer *
+	lda, doublereal *xleft, doublereal *xright)
+{
+    /* System generated locals */
+    integer i__1;
+
+    /* Local variables */
+    integer iinc;
+    extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, 
+	    doublereal *, integer *, doublereal *, doublereal *);
+    integer inext, ix, iy, nt;
+    doublereal xt[2], yt[2];
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    integer iyt;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Set up indices, arrays for ends */
+
+    /* Parameter adjustments */
+    --a;
+
+    /* Function Body */
+    if (*lrows) {
+	iinc = *lda;
+	inext = 1;
+    } else {
+	iinc = 1;
+	inext = *lda;
+    }
+
+    if (*lleft) {
+	nt = 1;
+	ix = iinc + 1;
+	iy = *lda + 2;
+	xt[0] = a[1];
+	yt[0] = *xleft;
+    } else {
+	nt = 0;
+	ix = 1;
+	iy = inext + 1;
+    }
+
+    if (*lright) {
+	iyt = inext + 1 + (*nl - 1) * iinc;
+	++nt;
+	xt[nt - 1] = *xright;
+	yt[nt - 1] = a[iyt];
+    }
+
+/*     Check for errors */
+
+    if (*nl < nt) {
+	xerbla_("DLAROT", &c__4);
+	return 0;
+    }
+    if (*lda <= 0 || ! (*lrows) && *lda < *nl - nt) {
+	xerbla_("DLAROT", &c__8);
+	return 0;
+    }
+
+/*     Rotate */
+
+    i__1 = *nl - nt;
+    drot_(&i__1, &a[ix], &iinc, &a[iy], &iinc, c__, s);
+    drot_(&nt, xt, &c__1, yt, &c__1, c__, s);
+
+/*     Stuff values back into XLEFT, XRIGHT, etc. */
+
+    if (*lleft) {
+	a[1] = xt[0];
+	*xleft = yt[0];
+    }
+
+    if (*lright) {
+	*xright = xt[nt - 1];
+	a[iyt] = yt[nt - 1];
+    }
+
+    return 0;
+
+/*     End of DLAROT */
+
+} /* dlarot_ */
+

lapack-netlib/TESTING/MATGEN/dlatm1.c

@@ -0,0 +1,698 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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)
+*/
+
+
+
+/* > \brief \b DLATM1 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE DLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO ) */
+
+/*       INTEGER            IDIST, INFO, IRSIGN, MODE, N */
+/*       DOUBLE PRECISION   COND */
+/*       INTEGER            ISEED( 4 ) */
+/*       DOUBLE PRECISION   D( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* >    DLATM1 computes the entries of D(1..N) as specified by */
+/* >    MODE, COND and IRSIGN. IDIST and ISEED determine the generation */
+/* >    of random numbers. DLATM1 is called by DLATMR to generate */
+/* >    random test matrices for LAPACK programs. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] MODE */
+/* > \verbatim */
+/* >          MODE is INTEGER */
+/* >           On entry describes how D is to be computed: */
+/* >           MODE = 0 means do not change D. */
+/* >           MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
+/* >           MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
+/* >           MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
+/* >           MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* >           MODE = 5 sets D to random numbers in the range */
+/* >                    ( 1/COND , 1 ) such that their logarithms */
+/* >                    are uniformly distributed. */
+/* >           MODE = 6 set D to random numbers from same distribution */
+/* >                    as the rest of the matrix. */
+/* >           MODE < 0 has the same meaning as ABS(MODE), except that */
+/* >              the order of the elements of D is reversed. */
+/* >           Thus if MODE is positive, D has entries ranging from */
+/* >              1 to 1/COND, if negative, from 1/COND to 1, */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] COND */
+/* > \verbatim */
+/* >          COND is DOUBLE PRECISION */
+/* >           On entry, used as described under MODE above. */
+/* >           If used, it must be >= 1. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IRSIGN */
+/* > \verbatim */
+/* >          IRSIGN is INTEGER */
+/* >           On entry, if MODE neither -6, 0 nor 6, determines sign of */
+/* >           entries of D */
+/* >           0 => leave entries of D unchanged */
+/* >           1 => multiply each entry of D by 1 or -1 with probability .5 */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IDIST */
+/* > \verbatim */
+/* >          IDIST is INTEGER */
+/* >           On entry, IDIST specifies the type of distribution to be */
+/* >           used to generate a random matrix . */
+/* >           1 => UNIFORM( 0, 1 ) */
+/* >           2 => UNIFORM( -1, 1 ) */
+/* >           3 => NORMAL( 0, 1 ) */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension ( 4 ) */
+/* >           On entry ISEED specifies the seed of the random number */
+/* >           generator. The random number generator uses a */
+/* >           linear congruential sequence limited to small */
+/* >           integers, and so should produce machine independent */
+/* >           random numbers. The values of ISEED are changed on */
+/* >           exit, and can be used in the next call to DLATM1 */
+/* >           to continue the same random number sequence. */
+/* >           Changed on exit. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] D */
+/* > \verbatim */
+/* >          D is DOUBLE PRECISION array, dimension ( N ) */
+/* >           Array to be computed according to MODE, COND and IRSIGN. */
+/* >           May be changed on exit if MODE is nonzero. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >           Number of entries of D. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >            0  => normal termination */
+/* >           -1  => if MODE not in range -6 to 6 */
+/* >           -2  => if MODE neither -6, 0 nor 6, and */
+/* >                  IRSIGN neither 0 nor 1 */
+/* >           -3  => if MODE neither -6, 0 nor 6 and COND less than 1 */
+/* >           -4  => if MODE equals 6 or -6 and IDIST not in range 1 to 3 */
+/* >           -7  => if N negative */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup double_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int dlatm1_(integer *mode, doublereal *cond, integer *irsign,
+	 integer *idist, integer *iseed, doublereal *d__, integer *n, integer 
+	*info)
+{
+    /* System generated locals */
+    integer i__1, i__2;
+    doublereal d__1;
+
+    /* Local variables */
+    doublereal temp;
+    integer i__;
+    doublereal alpha;
+    extern doublereal dlaran_(integer *);
+    extern /* Subroutine */ int xerbla_(char *, integer *), dlarnv_(
+	    integer *, integer *, 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Decode and Test the input parameters. Initialize flags & seed. */
+
+    /* Parameter adjustments */
+    --d__;
+    --iseed;
+
+    /* Function Body */
+    *info = 0;
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+/*     Set INFO if an error */
+
+    if (*mode < -6 || *mode > 6) {
+	*info = -1;
+    } else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && *
+	    irsign != 1)) {
+	*info = -2;
+    } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.) {
+	*info = -3;
+    } else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 3)) {
+	*info = -4;
+    } else if (*n < 0) {
+	*info = -7;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("DLATM1", &i__1);
+	return 0;
+    }
+
+/*     Compute D according to COND and MODE */
+
+    if (*mode != 0) {
+	switch (abs(*mode)) {
+	    case 1:  goto L10;
+	    case 2:  goto L30;
+	    case 3:  goto L50;
+	    case 4:  goto L70;
+	    case 5:  goto L90;
+	    case 6:  goto L110;
+	}
+
+/*        One large D value: */
+
+L10:
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    d__[i__] = 1. / *cond;
+/* L20: */
+	}
+	d__[1] = 1.;
+	goto L120;
+
+/*        One small D value: */
+
+L30:
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    d__[i__] = 1.;
+/* L40: */
+	}
+	d__[*n] = 1. / *cond;
+	goto L120;
+
+/*        Exponentially distributed D values: */
+
+L50:
+	d__[1] = 1.;
+	if (*n > 1) {
+	    d__1 = -1. / (doublereal) (*n - 1);
+	    alpha = pow_dd(cond, &d__1);
+	    i__1 = *n;
+	    for (i__ = 2; i__ <= i__1; ++i__) {
+		i__2 = i__ - 1;
+		d__[i__] = pow_di(&alpha, &i__2);
+/* L60: */
+	    }
+	}
+	goto L120;
+
+/*        Arithmetically distributed D values: */
+
+L70:
+	d__[1] = 1.;
+	if (*n > 1) {
+	    temp = 1. / *cond;
+	    alpha = (1. - temp) / (doublereal) (*n - 1);
+	    i__1 = *n;
+	    for (i__ = 2; i__ <= i__1; ++i__) {
+		d__[i__] = (doublereal) (*n - i__) * alpha + temp;
+/* L80: */
+	    }
+	}
+	goto L120;
+
+/*        Randomly distributed D values on ( 1/COND , 1): */
+
+L90:
+	alpha = log(1. / *cond);
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    d__[i__] = exp(alpha * dlaran_(&iseed[1]));
+/* L100: */
+	}
+	goto L120;
+
+/*        Randomly distributed D values from IDIST */
+
+L110:
+	dlarnv_(idist, &iseed[1], n, &d__[1]);
+
+L120:
+
+/*        If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */
+/*        random signs to D */
+
+	if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) {
+	    i__1 = *n;
+	    for (i__ = 1; i__ <= i__1; ++i__) {
+		temp = dlaran_(&iseed[1]);
+		if (temp > .5) {
+		    d__[i__] = -d__[i__];
+		}
+/* L130: */
+	    }
+	}
+
+/*        Reverse if MODE < 0 */
+
+	if (*mode < 0) {
+	    i__1 = *n / 2;
+	    for (i__ = 1; i__ <= i__1; ++i__) {
+		temp = d__[i__];
+		d__[i__] = d__[*n + 1 - i__];
+		d__[*n + 1 - i__] = temp;
+/* L140: */
+	    }
+	}
+
+    }
+
+    return 0;
+
+/*     End of DLATM1 */
+
+} /* dlatm1_ */
+

lapack-netlib/TESTING/MATGEN/dlatm2.c

@@ -0,0 +1,698 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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)
+*/
+
+
+
+/* > \brief \b DLATM2 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       DOUBLE PRECISION FUNCTION DLATM2( M, N, I, J, KL, KU, IDIST, */
+/*                        ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) */
+
+
+/*       INTEGER            I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N */
+/*       DOUBLE PRECISION   SPARSE */
+
+
+/*       INTEGER            ISEED( 4 ), IWORK( * ) */
+/*       DOUBLE PRECISION   D( * ), DL( * ), DR( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* >    DLATM2 returns the (I,J) entry of a random matrix of dimension */
+/* >    (M, N) described by the other parameters. It is called by the */
+/* >    DLATMR routine in order to build random test matrices. No error */
+/* >    checking on parameters is done, because this routine is called in */
+/* >    a tight loop by DLATMR which has already checked the parameters. */
+/* > */
+/* >    Use of DLATM2 differs from SLATM3 in the order in which the random */
+/* >    number generator is called to fill in random matrix entries. */
+/* >    With DLATM2, the generator is called to fill in the pivoted matrix */
+/* >    columnwise. With DLATM3, the generator is called to fill in the */
+/* >    matrix columnwise, after which it is pivoted. Thus, DLATM3 can */
+/* >    be used to construct random matrices which differ only in their */
+/* >    order of rows and/or columns. DLATM2 is used to construct band */
+/* >    matrices while avoiding calling the random number generator for */
+/* >    entries outside the band (and therefore generating random numbers */
+/* > */
+/* >    The matrix whose (I,J) entry is returned is constructed as */
+/* >    follows (this routine only computes one entry): */
+/* > */
+/* >      If I is outside (1..M) or J is outside (1..N), return zero */
+/* >         (this is convenient for generating matrices in band format). */
+/* > */
+/* >      Generate a matrix A with random entries of distribution IDIST. */
+/* > */
+/* >      Set the diagonal to D. */
+/* > */
+/* >      Grade the matrix, if desired, from the left (by DL) and/or */
+/* >         from the right (by DR or DL) as specified by IGRADE. */
+/* > */
+/* >      Permute, if desired, the rows and/or columns as specified by */
+/* >         IPVTNG and IWORK. */
+/* > */
+/* >      Band the matrix to have lower bandwidth KL and upper */
+/* >         bandwidth KU. */
+/* > */
+/* >      Set random entries to zero as specified by SPARSE. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >           Number of rows of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >           Number of columns of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] I */
+/* > \verbatim */
+/* >          I is INTEGER */
+/* >           Row of entry to be returned. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] J */
+/* > \verbatim */
+/* >          J is INTEGER */
+/* >           Column of entry to be returned. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KL */
+/* > \verbatim */
+/* >          KL is INTEGER */
+/* >           Lower bandwidth. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KU */
+/* > \verbatim */
+/* >          KU is INTEGER */
+/* >           Upper bandwidth. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IDIST */
+/* > \verbatim */
+/* >          IDIST is INTEGER */
+/* >           On entry, IDIST specifies the type of distribution to be */
+/* >           used to generate a random matrix . */
+/* >           1 => UNIFORM( 0, 1 ) */
+/* >           2 => UNIFORM( -1, 1 ) */
+/* >           3 => NORMAL( 0, 1 ) */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array of dimension ( 4 ) */
+/* >           Seed for random number generator. */
+/* >           Changed on exit. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is DOUBLE PRECISION array of dimension ( MIN( I , J ) ) */
+/* >           Diagonal entries of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IGRADE */
+/* > \verbatim */
+/* >          IGRADE is INTEGER */
+/* >           Specifies grading of matrix as follows: */
+/* >           0  => no grading */
+/* >           1  => matrix premultiplied by diag( DL ) */
+/* >           2  => matrix postmultiplied by diag( DR ) */
+/* >           3  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by diag( DR ) */
+/* >           4  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by inv( diag( DL ) ) */
+/* >           5  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by diag( DL ) */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] DL */
+/* > \verbatim */
+/* >          DL is DOUBLE PRECISION array ( I or J, as appropriate ) */
+/* >           Left scale factors for grading matrix.  Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] DR */
+/* > \verbatim */
+/* >          DR is DOUBLE PRECISION array ( I or J, as appropriate ) */
+/* >           Right scale factors for grading matrix.  Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPVTNG */
+/* > \verbatim */
+/* >          IPVTNG is INTEGER */
+/* >           On entry specifies pivoting permutations as follows: */
+/* >           0 => none. */
+/* >           1 => row pivoting. */
+/* >           2 => column pivoting. */
+/* >           3 => full pivoting, i.e., on both sides. */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array ( I or J, as appropriate ) */
+/* >           This array specifies the permutation used. The */
+/* >           row (or column) in position K was originally in */
+/* >           position IWORK( K ). */
+/* >           This differs from IWORK for DLATM3. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] SPARSE */
+/* > \verbatim */
+/* >          SPARSE is DOUBLE PRECISION between 0. and 1. */
+/* >           On entry specifies the sparsity of the matrix */
+/* >           if sparse matrix is to be generated. */
+/* >           SPARSE should lie between 0 and 1. */
+/* >           A uniform ( 0, 1 ) random number x is generated and */
+/* >           compared to SPARSE; if x is larger the matrix entry */
+/* >           is unchanged and if x is smaller the entry is set */
+/* >           to zero. Thus on the average a fraction SPARSE of the */
+/* >           entries will be set to zero. */
+/* >           Not modified. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date June 2016 */
+
+/* > \ingroup double_matgen */
+
+/*  ===================================================================== */
+doublereal dlatm2_(integer *m, integer *n, integer *i__, integer *j, integer *
+	kl, integer *ku, integer *idist, integer *iseed, doublereal *d__, 
+	integer *igrade, doublereal *dl, doublereal *dr, integer *ipvtng, 
+	integer *iwork, doublereal *sparse)
+{
+    /* System generated locals */
+    doublereal ret_val;
+
+    /* Local variables */
+    integer isub, jsub;
+    doublereal temp;
+    extern doublereal dlaran_(integer *), dlarnd_(integer *, 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..-- */
+/*     June 2016 */
+
+
+
+
+
+/*  ===================================================================== */
+
+
+
+
+
+
+
+/* ----------------------------------------------------------------------- */
+
+
+
+/*     Check for I and J in range */
+
+    /* Parameter adjustments */
+    --iwork;
+    --dr;
+    --dl;
+    --d__;
+    --iseed;
+
+    /* Function Body */
+    if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) {
+	ret_val = 0.;
+	return ret_val;
+    }
+
+/*     Check for banding */
+
+    if (*j > *i__ + *ku || *j < *i__ - *kl) {
+	ret_val = 0.;
+	return ret_val;
+    }
+
+/*     Check for sparsity */
+
+    if (*sparse > 0.) {
+	if (dlaran_(&iseed[1]) < *sparse) {
+	    ret_val = 0.;
+	    return ret_val;
+	}
+    }
+
+/*     Compute subscripts depending on IPVTNG */
+
+    if (*ipvtng == 0) {
+	isub = *i__;
+	jsub = *j;
+    } else if (*ipvtng == 1) {
+	isub = iwork[*i__];
+	jsub = *j;
+    } else if (*ipvtng == 2) {
+	isub = *i__;
+	jsub = iwork[*j];
+    } else if (*ipvtng == 3) {
+	isub = iwork[*i__];
+	jsub = iwork[*j];
+    }
+
+/*     Compute entry and grade it according to IGRADE */
+
+    if (isub == jsub) {
+	temp = d__[isub];
+    } else {
+	temp = dlarnd_(idist, &iseed[1]);
+    }
+    if (*igrade == 1) {
+	temp *= dl[isub];
+    } else if (*igrade == 2) {
+	temp *= dr[jsub];
+    } else if (*igrade == 3) {
+	temp = temp * dl[isub] * dr[jsub];
+    } else if (*igrade == 4 && isub != jsub) {
+	temp = temp * dl[isub] / dl[jsub];
+    } else if (*igrade == 5) {
+	temp = temp * dl[isub] * dl[jsub];
+    }
+    ret_val = temp;
+    return ret_val;
+
+/*     End of DLATM2 */
+
+} /* dlatm2_ */
+

lapack-netlib/TESTING/MATGEN/dlatm3.c

@@ -0,0 +1,716 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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)
+*/
+
+
+
+/* > \brief \b DLATM3 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       DOUBLE PRECISION FUNCTION DLATM3( M, N, I, J, ISUB, JSUB, KL, KU, */
+/*                        IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, */
+/*                        SPARSE ) */
+
+
+/*       INTEGER            I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL, */
+/*      $                   KU, M, N */
+/*       DOUBLE PRECISION   SPARSE */
+
+
+/*       INTEGER            ISEED( 4 ), IWORK( * ) */
+/*       DOUBLE PRECISION   D( * ), DL( * ), DR( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* >    DLATM3 returns the (ISUB,JSUB) entry of a random matrix of */
+/* >    dimension (M, N) described by the other parameters. (ISUB,JSUB) */
+/* >    is the final position of the (I,J) entry after pivoting */
+/* >    according to IPVTNG and IWORK. DLATM3 is called by the */
+/* >    DLATMR routine in order to build random test matrices. No error */
+/* >    checking on parameters is done, because this routine is called in */
+/* >    a tight loop by DLATMR which has already checked the parameters. */
+/* > */
+/* >    Use of DLATM3 differs from SLATM2 in the order in which the random */
+/* >    number generator is called to fill in random matrix entries. */
+/* >    With DLATM2, the generator is called to fill in the pivoted matrix */
+/* >    columnwise. With DLATM3, the generator is called to fill in the */
+/* >    matrix columnwise, after which it is pivoted. Thus, DLATM3 can */
+/* >    be used to construct random matrices which differ only in their */
+/* >    order of rows and/or columns. DLATM2 is used to construct band */
+/* >    matrices while avoiding calling the random number generator for */
+/* >    entries outside the band (and therefore generating random numbers */
+/* >    in different orders for different pivot orders). */
+/* > */
+/* >    The matrix whose (ISUB,JSUB) entry is returned is constructed as */
+/* >    follows (this routine only computes one entry): */
+/* > */
+/* >      If ISUB is outside (1..M) or JSUB is outside (1..N), return zero */
+/* >         (this is convenient for generating matrices in band format). */
+/* > */
+/* >      Generate a matrix A with random entries of distribution IDIST. */
+/* > */
+/* >      Set the diagonal to D. */
+/* > */
+/* >      Grade the matrix, if desired, from the left (by DL) and/or */
+/* >         from the right (by DR or DL) as specified by IGRADE. */
+/* > */
+/* >      Permute, if desired, the rows and/or columns as specified by */
+/* >         IPVTNG and IWORK. */
+/* > */
+/* >      Band the matrix to have lower bandwidth KL and upper */
+/* >         bandwidth KU. */
+/* > */
+/* >      Set random entries to zero as specified by SPARSE. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >           Number of rows of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >           Number of columns of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] I */
+/* > \verbatim */
+/* >          I is INTEGER */
+/* >           Row of unpivoted entry to be returned. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] J */
+/* > \verbatim */
+/* >          J is INTEGER */
+/* >           Column of unpivoted entry to be returned. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISUB */
+/* > \verbatim */
+/* >          ISUB is INTEGER */
+/* >           Row of pivoted entry to be returned. Changed on exit. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] JSUB */
+/* > \verbatim */
+/* >          JSUB is INTEGER */
+/* >           Column of pivoted entry to be returned. Changed on exit. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KL */
+/* > \verbatim */
+/* >          KL is INTEGER */
+/* >           Lower bandwidth. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KU */
+/* > \verbatim */
+/* >          KU is INTEGER */
+/* >           Upper bandwidth. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IDIST */
+/* > \verbatim */
+/* >          IDIST is INTEGER */
+/* >           On entry, IDIST specifies the type of distribution to be */
+/* >           used to generate a random matrix . */
+/* >           1 => UNIFORM( 0, 1 ) */
+/* >           2 => UNIFORM( -1, 1 ) */
+/* >           3 => NORMAL( 0, 1 ) */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array of dimension ( 4 ) */
+/* >           Seed for random number generator. */
+/* >           Changed on exit. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is DOUBLE PRECISION array of dimension ( MIN( I , J ) ) */
+/* >           Diagonal entries of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IGRADE */
+/* > \verbatim */
+/* >          IGRADE is INTEGER */
+/* >           Specifies grading of matrix as follows: */
+/* >           0  => no grading */
+/* >           1  => matrix premultiplied by diag( DL ) */
+/* >           2  => matrix postmultiplied by diag( DR ) */
+/* >           3  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by diag( DR ) */
+/* >           4  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by inv( diag( DL ) ) */
+/* >           5  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by diag( DL ) */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] DL */
+/* > \verbatim */
+/* >          DL is DOUBLE PRECISION array ( I or J, as appropriate ) */
+/* >           Left scale factors for grading matrix.  Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] DR */
+/* > \verbatim */
+/* >          DR is DOUBLE PRECISION array ( I or J, as appropriate ) */
+/* >           Right scale factors for grading matrix.  Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPVTNG */
+/* > \verbatim */
+/* >          IPVTNG is INTEGER */
+/* >           On entry specifies pivoting permutations as follows: */
+/* >           0 => none. */
+/* >           1 => row pivoting. */
+/* >           2 => column pivoting. */
+/* >           3 => full pivoting, i.e., on both sides. */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array ( I or J, as appropriate ) */
+/* >           This array specifies the permutation used. The */
+/* >           row (or column) originally in position K is in */
+/* >           position IWORK( K ) after pivoting. */
+/* >           This differs from IWORK for DLATM2. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] SPARSE */
+/* > \verbatim */
+/* >          SPARSE is DOUBLE PRECISION between 0. and 1. */
+/* >           On entry specifies the sparsity of the matrix */
+/* >           if sparse matrix is to be generated. */
+/* >           SPARSE should lie between 0 and 1. */
+/* >           A uniform ( 0, 1 ) random number x is generated and */
+/* >           compared to SPARSE; if x is larger the matrix entry */
+/* >           is unchanged and if x is smaller the entry is set */
+/* >           to zero. Thus on the average a fraction SPARSE of the */
+/* >           entries will be set to zero. */
+/* >           Not modified. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date June 2016 */
+
+/* > \ingroup double_matgen */
+
+/*  ===================================================================== */
+doublereal dlatm3_(integer *m, integer *n, integer *i__, integer *j, integer *
+	isub, integer *jsub, integer *kl, integer *ku, integer *idist, 
+	integer *iseed, doublereal *d__, integer *igrade, doublereal *dl, 
+	doublereal *dr, integer *ipvtng, integer *iwork, doublereal *sparse)
+{
+    /* System generated locals */
+    doublereal ret_val;
+
+    /* Local variables */
+    doublereal temp;
+    extern doublereal dlaran_(integer *), dlarnd_(integer *, 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..-- */
+/*     June 2016 */
+
+
+
+
+
+/*  ===================================================================== */
+
+
+
+
+
+
+
+/* ----------------------------------------------------------------------- */
+
+
+
+/*     Check for I and J in range */
+
+    /* Parameter adjustments */
+    --iwork;
+    --dr;
+    --dl;
+    --d__;
+    --iseed;
+
+    /* Function Body */
+    if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) {
+	*isub = *i__;
+	*jsub = *j;
+	ret_val = 0.;
+	return ret_val;
+    }
+
+/*     Compute subscripts depending on IPVTNG */
+
+    if (*ipvtng == 0) {
+	*isub = *i__;
+	*jsub = *j;
+    } else if (*ipvtng == 1) {
+	*isub = iwork[*i__];
+	*jsub = *j;
+    } else if (*ipvtng == 2) {
+	*isub = *i__;
+	*jsub = iwork[*j];
+    } else if (*ipvtng == 3) {
+	*isub = iwork[*i__];
+	*jsub = iwork[*j];
+    }
+
+/*     Check for banding */
+
+    if (*jsub > *isub + *ku || *jsub < *isub - *kl) {
+	ret_val = 0.;
+	return ret_val;
+    }
+
+/*     Check for sparsity */
+
+    if (*sparse > 0.) {
+	if (dlaran_(&iseed[1]) < *sparse) {
+	    ret_val = 0.;
+	    return ret_val;
+	}
+    }
+
+/*     Compute entry and grade it according to IGRADE */
+
+    if (*i__ == *j) {
+	temp = d__[*i__];
+    } else {
+	temp = dlarnd_(idist, &iseed[1]);
+    }
+    if (*igrade == 1) {
+	temp *= dl[*i__];
+    } else if (*igrade == 2) {
+	temp *= dr[*j];
+    } else if (*igrade == 3) {
+	temp = temp * dl[*i__] * dr[*j];
+    } else if (*igrade == 4 && *i__ != *j) {
+	temp = temp * dl[*i__] / dl[*j];
+    } else if (*igrade == 5) {
+	temp = temp * dl[*i__] * dl[*j];
+    }
+    ret_val = temp;
+    return ret_val;
+
+/*     End of DLATM3 */
+
+} /* dlatm3_ */
+

lapack-netlib/TESTING/MATGEN/dlatm5.c

@@ -0,0 +1,981 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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_b29 = 1.;
+static doublereal c_b30 = 0.;
+static doublereal c_b33 = -1.;
+
+/* > \brief \b DLATM5 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE DLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD, */
+/*                          E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA, */
+/*                          QBLCKB ) */
+
+/*       INTEGER            LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N, */
+/*      $                   PRTYPE, QBLCKA, QBLCKB */
+/*       DOUBLE PRECISION   ALPHA */
+/*       DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ), */
+/*      $                   D( LDD, * ), E( LDE, * ), F( LDF, * ), */
+/*      $                   L( LDL, * ), R( LDR, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > DLATM5 generates matrices involved in the Generalized Sylvester */
+/* > equation: */
+/* > */
+/* >     A * R - L * B = C */
+/* >     D * R - L * E = F */
+/* > */
+/* > They also satisfy (the diagonalization condition) */
+/* > */
+/* >  [ I -L ] ( [ A  -C ], [ D -F ] ) [ I  R ] = ( [ A    ], [ D    ] ) */
+/* >  [    I ] ( [     B ]  [    E ] ) [    I ]   ( [    B ]  [    E ] ) */
+/* > */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] PRTYPE */
+/* > \verbatim */
+/* >          PRTYPE is INTEGER */
+/* >          "Points" to a certain type of the matrices to generate */
+/* >          (see further details). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          Specifies the order of A and D and the number of rows in */
+/* >          C, F,  R and L. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          Specifies the order of B and E and the number of columns in */
+/* >          C, F, R and L. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] A */
+/* > \verbatim */
+/* >          A is DOUBLE PRECISION array, dimension (LDA, M). */
+/* >          On exit A M-by-M is initialized according to PRTYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] B */
+/* > \verbatim */
+/* >          B is DOUBLE PRECISION array, dimension (LDB, N). */
+/* >          On exit B N-by-N is initialized according to PRTYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of B. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] C */
+/* > \verbatim */
+/* >          C is DOUBLE PRECISION array, dimension (LDC, N). */
+/* >          On exit C M-by-N is initialized according to PRTYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDC */
+/* > \verbatim */
+/* >          LDC is INTEGER */
+/* >          The leading dimension of C. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] D */
+/* > \verbatim */
+/* >          D is DOUBLE PRECISION array, dimension (LDD, M). */
+/* >          On exit D M-by-M is initialized according to PRTYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDD */
+/* > \verbatim */
+/* >          LDD is INTEGER */
+/* >          The leading dimension of D. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] E */
+/* > \verbatim */
+/* >          E is DOUBLE PRECISION array, dimension (LDE, N). */
+/* >          On exit E N-by-N is initialized according to PRTYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDE */
+/* > \verbatim */
+/* >          LDE is INTEGER */
+/* >          The leading dimension of E. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] F */
+/* > \verbatim */
+/* >          F is DOUBLE PRECISION array, dimension (LDF, N). */
+/* >          On exit F M-by-N is initialized according to PRTYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDF */
+/* > \verbatim */
+/* >          LDF is INTEGER */
+/* >          The leading dimension of F. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] R */
+/* > \verbatim */
+/* >          R is DOUBLE PRECISION array, dimension (LDR, N). */
+/* >          On exit R M-by-N is initialized according to PRTYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDR */
+/* > \verbatim */
+/* >          LDR is INTEGER */
+/* >          The leading dimension of R. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] L */
+/* > \verbatim */
+/* >          L is DOUBLE PRECISION array, dimension (LDL, N). */
+/* >          On exit L M-by-N is initialized according to PRTYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDL */
+/* > \verbatim */
+/* >          LDL is INTEGER */
+/* >          The leading dimension of L. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] ALPHA */
+/* > \verbatim */
+/* >          ALPHA is DOUBLE PRECISION */
+/* >          Parameter used in generating PRTYPE = 1 and 5 matrices. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] QBLCKA */
+/* > \verbatim */
+/* >          QBLCKA is INTEGER */
+/* >          When PRTYPE = 3, specifies the distance between 2-by-2 */
+/* >          blocks on the diagonal in A. Otherwise, QBLCKA is not */
+/* >          referenced. QBLCKA > 1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] QBLCKB */
+/* > \verbatim */
+/* >          QBLCKB is INTEGER */
+/* >          When PRTYPE = 3, specifies the distance between 2-by-2 */
+/* >          blocks on the diagonal in B. Otherwise, QBLCKB is not */
+/* >          referenced. QBLCKB > 1. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date June 2016 */
+
+/* > \ingroup double_matgen */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices */
+/* > */
+/* >             A : if (i == j) then A(i, j) = 1.0 */
+/* >                 if (j == i + 1) then A(i, j) = -1.0 */
+/* >                 else A(i, j) = 0.0,            i, j = 1...M */
+/* > */
+/* >             B : if (i == j) then B(i, j) = 1.0 - ALPHA */
+/* >                 if (j == i + 1) then B(i, j) = 1.0 */
+/* >                 else B(i, j) = 0.0,            i, j = 1...N */
+/* > */
+/* >             D : if (i == j) then D(i, j) = 1.0 */
+/* >                 else D(i, j) = 0.0,            i, j = 1...M */
+/* > */
+/* >             E : if (i == j) then E(i, j) = 1.0 */
+/* >                 else E(i, j) = 0.0,            i, j = 1...N */
+/* > */
+/* >             L =  R are chosen from [-10...10], */
+/* >                  which specifies the right hand sides (C, F). */
+/* > */
+/* >  PRTYPE = 2 or 3: Triangular and/or quasi- triangular. */
+/* > */
+/* >             A : if (i <= j) then A(i, j) = [-1...1] */
+/* >                 else A(i, j) = 0.0,             i, j = 1...M */
+/* > */
+/* >                 if (PRTYPE = 3) then */
+/* >                    A(k + 1, k + 1) = A(k, k) */
+/* >                    A(k + 1, k) = [-1...1] */
+/* >                    sign(A(k, k + 1) = -(sin(A(k + 1, k)) */
+/* >                        k = 1, M - 1, QBLCKA */
+/* > */
+/* >             B : if (i <= j) then B(i, j) = [-1...1] */
+/* >                 else B(i, j) = 0.0,            i, j = 1...N */
+/* > */
+/* >                 if (PRTYPE = 3) then */
+/* >                    B(k + 1, k + 1) = B(k, k) */
+/* >                    B(k + 1, k) = [-1...1] */
+/* >                    sign(B(k, k + 1) = -(sign(B(k + 1, k)) */
+/* >                        k = 1, N - 1, QBLCKB */
+/* > */
+/* >             D : if (i <= j) then D(i, j) = [-1...1]. */
+/* >                 else D(i, j) = 0.0,            i, j = 1...M */
+/* > */
+/* > */
+/* >             E : if (i <= j) then D(i, j) = [-1...1] */
+/* >                 else E(i, j) = 0.0,            i, j = 1...N */
+/* > */
+/* >                 L, R are chosen from [-10...10], */
+/* >                 which specifies the right hand sides (C, F). */
+/* > */
+/* >  PRTYPE = 4 Full */
+/* >             A(i, j) = [-10...10] */
+/* >             D(i, j) = [-1...1]    i,j = 1...M */
+/* >             B(i, j) = [-10...10] */
+/* >             E(i, j) = [-1...1]    i,j = 1...N */
+/* >             R(i, j) = [-10...10] */
+/* >             L(i, j) = [-1...1]    i = 1..M ,j = 1...N */
+/* > */
+/* >             L, R specifies the right hand sides (C, F). */
+/* > */
+/* >  PRTYPE = 5 special case common and/or close eigs. */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int dlatm5_(integer *prtype, integer *m, integer *n, 
+	doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *
+	c__, integer *ldc, doublereal *d__, integer *ldd, doublereal *e, 
+	integer *lde, doublereal *f, integer *ldf, doublereal *r__, integer *
+	ldr, doublereal *l, integer *ldl, doublereal *alpha, integer *qblcka, 
+	integer *qblckb)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1, 
+	    d_offset, e_dim1, e_offset, f_dim1, f_offset, l_dim1, l_offset, 
+	    r_dim1, r_offset, i__1, i__2;
+
+    /* Local variables */
+    integer i__, j, k;
+    extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, 
+	    integer *, doublereal *, doublereal *, integer *, doublereal *, 
+	    integer *, doublereal *, doublereal *, integer *);
+    doublereal imeps, reeps;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     June 2016 */
+
+
+/*  ===================================================================== */
+
+
+    /* 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;
+    c_dim1 = *ldc;
+    c_offset = 1 + c_dim1 * 1;
+    c__ -= c_offset;
+    d_dim1 = *ldd;
+    d_offset = 1 + d_dim1 * 1;
+    d__ -= d_offset;
+    e_dim1 = *lde;
+    e_offset = 1 + e_dim1 * 1;
+    e -= e_offset;
+    f_dim1 = *ldf;
+    f_offset = 1 + f_dim1 * 1;
+    f -= f_offset;
+    r_dim1 = *ldr;
+    r_offset = 1 + r_dim1 * 1;
+    r__ -= r_offset;
+    l_dim1 = *ldl;
+    l_offset = 1 + l_dim1 * 1;
+    l -= l_offset;
+
+    /* Function Body */
+    if (*prtype == 1) {
+	i__1 = *m;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *m;
+	    for (j = 1; j <= i__2; ++j) {
+		if (i__ == j) {
+		    a[i__ + j * a_dim1] = 1.;
+		    d__[i__ + j * d_dim1] = 1.;
+		} else if (i__ == j - 1) {
+		    a[i__ + j * a_dim1] = -1.;
+		    d__[i__ + j * d_dim1] = 0.;
+		} else {
+		    a[i__ + j * a_dim1] = 0.;
+		    d__[i__ + j * d_dim1] = 0.;
+		}
+/* L10: */
+	    }
+/* L20: */
+	}
+
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *n;
+	    for (j = 1; j <= i__2; ++j) {
+		if (i__ == j) {
+		    b[i__ + j * b_dim1] = 1. - *alpha;
+		    e[i__ + j * e_dim1] = 1.;
+		} else if (i__ == j - 1) {
+		    b[i__ + j * b_dim1] = 1.;
+		    e[i__ + j * e_dim1] = 0.;
+		} else {
+		    b[i__ + j * b_dim1] = 0.;
+		    e[i__ + j * e_dim1] = 0.;
+		}
+/* L30: */
+	    }
+/* L40: */
+	}
+
+	i__1 = *m;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *n;
+	    for (j = 1; j <= i__2; ++j) {
+		r__[i__ + j * r_dim1] = (.5 - sin((doublereal) (i__ / j))) * 
+			20.;
+		l[i__ + j * l_dim1] = r__[i__ + j * r_dim1];
+/* L50: */
+	    }
+/* L60: */
+	}
+
+    } else if (*prtype == 2 || *prtype == 3) {
+	i__1 = *m;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *m;
+	    for (j = 1; j <= i__2; ++j) {
+		if (i__ <= j) {
+		    a[i__ + j * a_dim1] = (.5 - sin((doublereal) i__)) * 2.;
+		    d__[i__ + j * d_dim1] = (.5 - sin((doublereal) (i__ * j)))
+			     * 2.;
+		} else {
+		    a[i__ + j * a_dim1] = 0.;
+		    d__[i__ + j * d_dim1] = 0.;
+		}
+/* L70: */
+	    }
+/* L80: */
+	}
+
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *n;
+	    for (j = 1; j <= i__2; ++j) {
+		if (i__ <= j) {
+		    b[i__ + j * b_dim1] = (.5 - sin((doublereal) (i__ + j))) *
+			     2.;
+		    e[i__ + j * e_dim1] = (.5 - sin((doublereal) j)) * 2.;
+		} else {
+		    b[i__ + j * b_dim1] = 0.;
+		    e[i__ + j * e_dim1] = 0.;
+		}
+/* L90: */
+	    }
+/* L100: */
+	}
+
+	i__1 = *m;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *n;
+	    for (j = 1; j <= i__2; ++j) {
+		r__[i__ + j * r_dim1] = (.5 - sin((doublereal) (i__ * j))) * 
+			20.;
+		l[i__ + j * l_dim1] = (.5 - sin((doublereal) (i__ + j))) * 
+			20.;
+/* L110: */
+	    }
+/* L120: */
+	}
+
+	if (*prtype == 3) {
+	    if (*qblcka <= 1) {
+		*qblcka = 2;
+	    }
+	    i__1 = *m - 1;
+	    i__2 = *qblcka;
+	    for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+		a[k + 1 + (k + 1) * a_dim1] = a[k + k * a_dim1];
+		a[k + 1 + k * a_dim1] = -sin(a[k + (k + 1) * a_dim1]);
+/* L130: */
+	    }
+
+	    if (*qblckb <= 1) {
+		*qblckb = 2;
+	    }
+	    i__2 = *n - 1;
+	    i__1 = *qblckb;
+	    for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+		b[k + 1 + (k + 1) * b_dim1] = b[k + k * b_dim1];
+		b[k + 1 + k * b_dim1] = -sin(b[k + (k + 1) * b_dim1]);
+/* L140: */
+	    }
+	}
+
+    } else if (*prtype == 4) {
+	i__1 = *m;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *m;
+	    for (j = 1; j <= i__2; ++j) {
+		a[i__ + j * a_dim1] = (.5 - sin((doublereal) (i__ * j))) * 
+			20.;
+		d__[i__ + j * d_dim1] = (.5 - sin((doublereal) (i__ + j))) * 
+			2.;
+/* L150: */
+	    }
+/* L160: */
+	}
+
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *n;
+	    for (j = 1; j <= i__2; ++j) {
+		b[i__ + j * b_dim1] = (.5 - sin((doublereal) (i__ + j))) * 
+			20.;
+		e[i__ + j * e_dim1] = (.5 - sin((doublereal) (i__ * j))) * 2.;
+/* L170: */
+	    }
+/* L180: */
+	}
+
+	i__1 = *m;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *n;
+	    for (j = 1; j <= i__2; ++j) {
+		r__[i__ + j * r_dim1] = (.5 - sin((doublereal) (j / i__))) * 
+			20.;
+		l[i__ + j * l_dim1] = (.5 - sin((doublereal) (i__ * j))) * 2.;
+/* L190: */
+	    }
+/* L200: */
+	}
+
+    } else if (*prtype >= 5) {
+	reeps = 20. / *alpha;
+	imeps = -1.5 / *alpha;
+	i__1 = *m;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *n;
+	    for (j = 1; j <= i__2; ++j) {
+		r__[i__ + j * r_dim1] = (.5 - sin((doublereal) (i__ * j))) * *
+			alpha / 20.;
+		l[i__ + j * l_dim1] = (.5 - sin((doublereal) (i__ + j))) * *
+			alpha / 20.;
+/* L210: */
+	    }
+/* L220: */
+	}
+
+	i__1 = *m;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    d__[i__ + i__ * d_dim1] = 1.;
+/* L230: */
+	}
+
+	i__1 = *m;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    if (i__ <= 4) {
+		a[i__ + i__ * a_dim1] = 1.;
+		if (i__ > 2) {
+		    a[i__ + i__ * a_dim1] = reeps + 1.;
+		}
+		if (i__ % 2 != 0 && i__ < *m) {
+		    a[i__ + (i__ + 1) * a_dim1] = imeps;
+		} else if (i__ > 1) {
+		    a[i__ + (i__ - 1) * a_dim1] = -imeps;
+		}
+	    } else if (i__ <= 8) {
+		if (i__ <= 6) {
+		    a[i__ + i__ * a_dim1] = reeps;
+		} else {
+		    a[i__ + i__ * a_dim1] = -reeps;
+		}
+		if (i__ % 2 != 0 && i__ < *m) {
+		    a[i__ + (i__ + 1) * a_dim1] = 1.;
+		} else if (i__ > 1) {
+		    a[i__ + (i__ - 1) * a_dim1] = -1.;
+		}
+	    } else {
+		a[i__ + i__ * a_dim1] = 1.;
+		if (i__ % 2 != 0 && i__ < *m) {
+		    a[i__ + (i__ + 1) * a_dim1] = imeps * 2;
+		} else if (i__ > 1) {
+		    a[i__ + (i__ - 1) * a_dim1] = -imeps * 2;
+		}
+	    }
+/* L240: */
+	}
+
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    e[i__ + i__ * e_dim1] = 1.;
+	    if (i__ <= 4) {
+		b[i__ + i__ * b_dim1] = -1.;
+		if (i__ > 2) {
+		    b[i__ + i__ * b_dim1] = 1. - reeps;
+		}
+		if (i__ % 2 != 0 && i__ < *n) {
+		    b[i__ + (i__ + 1) * b_dim1] = imeps;
+		} else if (i__ > 1) {
+		    b[i__ + (i__ - 1) * b_dim1] = -imeps;
+		}
+	    } else if (i__ <= 8) {
+		if (i__ <= 6) {
+		    b[i__ + i__ * b_dim1] = reeps;
+		} else {
+		    b[i__ + i__ * b_dim1] = -reeps;
+		}
+		if (i__ % 2 != 0 && i__ < *n) {
+		    b[i__ + (i__ + 1) * b_dim1] = imeps + 1.;
+		} else if (i__ > 1) {
+		    b[i__ + (i__ - 1) * b_dim1] = -1. - imeps;
+		}
+	    } else {
+		b[i__ + i__ * b_dim1] = 1. - reeps;
+		if (i__ % 2 != 0 && i__ < *n) {
+		    b[i__ + (i__ + 1) * b_dim1] = imeps * 2;
+		} else if (i__ > 1) {
+		    b[i__ + (i__ - 1) * b_dim1] = -imeps * 2;
+		}
+	    }
+/* L250: */
+	}
+    }
+
+/*     Compute rhs (C, F) */
+
+    dgemm_("N", "N", m, n, m, &c_b29, &a[a_offset], lda, &r__[r_offset], ldr, 
+	    &c_b30, &c__[c_offset], ldc);
+    dgemm_("N", "N", m, n, n, &c_b33, &l[l_offset], ldl, &b[b_offset], ldb, &
+	    c_b29, &c__[c_offset], ldc);
+    dgemm_("N", "N", m, n, m, &c_b29, &d__[d_offset], ldd, &r__[r_offset], 
+	    ldr, &c_b30, &f[f_offset], ldf);
+    dgemm_("N", "N", m, n, n, &c_b33, &l[l_offset], ldl, &e[e_offset], lde, &
+	    c_b29, &f[f_offset], ldf);
+
+/*     End of DLATM5 */
+
+    return 0;
+} /* dlatm5_ */
+

lapack-netlib/TESTING/MATGEN/dlatm6.c

@@ -0,0 +1,750 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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 integer c__4 = 4;
+static integer c__12 = 12;
+static integer c__8 = 8;
+static integer c__40 = 40;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__60 = 60;
+
+/* > \brief \b DLATM6 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE DLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA, */
+/*                          BETA, WX, WY, S, DIF ) */
+
+/*       INTEGER            LDA, LDX, LDY, N, TYPE */
+/*       DOUBLE PRECISION   ALPHA, BETA, WX, WY */
+/*       DOUBLE PRECISION   A( LDA, * ), B( LDA, * ), DIF( * ), S( * ), */
+/*      $                   X( LDX, * ), Y( LDY, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > DLATM6 generates test matrices for the generalized eigenvalue */
+/* > problem, their corresponding right and left eigenvector matrices, */
+/* > and also reciprocal condition numbers for all eigenvalues and */
+/* > the reciprocal condition numbers of eigenvectors corresponding to */
+/* > the 1th and 5th eigenvalues. */
+/* > */
+/* > Test Matrices */
+/* > ============= */
+/* > */
+/* > Two kinds of test matrix pairs */
+/* > */
+/* >       (A, B) = inverse(YH) * (Da, Db) * inverse(X) */
+/* > */
+/* > are used in the tests: */
+/* > */
+/* > Type 1: */
+/* >    Da = 1+a   0    0    0    0    Db = 1   0   0   0   0 */
+/* >          0   2+a   0    0    0         0   1   0   0   0 */
+/* >          0    0   3+a   0    0         0   0   1   0   0 */
+/* >          0    0    0   4+a   0         0   0   0   1   0 */
+/* >          0    0    0    0   5+a ,      0   0   0   0   1 , and */
+/* > */
+/* > Type 2: */
+/* >    Da =  1   -1    0    0    0    Db = 1   0   0   0   0 */
+/* >          1    1    0    0    0         0   1   0   0   0 */
+/* >          0    0    1    0    0         0   0   1   0   0 */
+/* >          0    0    0   1+a  1+b        0   0   0   1   0 */
+/* >          0    0    0  -1-b  1+a ,      0   0   0   0   1 . */
+/* > */
+/* > In both cases the same inverse(YH) and inverse(X) are used to compute */
+/* > (A, B), giving the exact eigenvectors to (A,B) as (YH, X): */
+/* > */
+/* > YH:  =  1    0   -y    y   -y    X =  1   0  -x  -x   x */
+/* >         0    1   -y    y   -y         0   1   x  -x  -x */
+/* >         0    0    1    0    0         0   0   1   0   0 */
+/* >         0    0    0    1    0         0   0   0   1   0 */
+/* >         0    0    0    0    1,        0   0   0   0   1 , */
+/* > */
+/* > where a, b, x and y will have all values independently of each other. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] TYPE */
+/* > \verbatim */
+/* >          TYPE is INTEGER */
+/* >          Specifies the problem type (see further details). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          Size of the matrices A and B. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] A */
+/* > \verbatim */
+/* >          A is DOUBLE PRECISION array, dimension (LDA, N). */
+/* >          On exit A N-by-N is initialized according to TYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of A and of B. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] B */
+/* > \verbatim */
+/* >          B is DOUBLE PRECISION array, dimension (LDA, N). */
+/* >          On exit B N-by-N is initialized according to TYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] X */
+/* > \verbatim */
+/* >          X is DOUBLE PRECISION array, dimension (LDX, N). */
+/* >          On exit X is the N-by-N matrix of right eigenvectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDX */
+/* > \verbatim */
+/* >          LDX is INTEGER */
+/* >          The leading dimension of X. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Y */
+/* > \verbatim */
+/* >          Y is DOUBLE PRECISION array, dimension (LDY, N). */
+/* >          On exit Y is the N-by-N matrix of left eigenvectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDY */
+/* > \verbatim */
+/* >          LDY is INTEGER */
+/* >          The leading dimension of Y. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] ALPHA */
+/* > \verbatim */
+/* >          ALPHA is DOUBLE PRECISION */
+/* > \endverbatim */
+/* > */
+/* > \param[in] BETA */
+/* > \verbatim */
+/* >          BETA is DOUBLE PRECISION */
+/* > */
+/* >          Weighting constants for matrix A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] WX */
+/* > \verbatim */
+/* >          WX is DOUBLE PRECISION */
+/* >          Constant for right eigenvector matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] WY */
+/* > \verbatim */
+/* >          WY is DOUBLE PRECISION */
+/* >          Constant for left eigenvector matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] S */
+/* > \verbatim */
+/* >          S is DOUBLE PRECISION array, dimension (N) */
+/* >          S(i) is the reciprocal condition number for eigenvalue i. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] DIF */
+/* > \verbatim */
+/* >          DIF is DOUBLE PRECISION array, dimension (N) */
+/* >          DIF(i) is the reciprocal condition number for eigenvector i. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup double_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int dlatm6_(integer *type__, integer *n, doublereal *a, 
+	integer *lda, doublereal *b, doublereal *x, integer *ldx, doublereal *
+	y, integer *ldy, doublereal *alpha, doublereal *beta, doublereal *wx, 
+	doublereal *wy, doublereal *s, doublereal *dif)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, y_dim1, 
+	    y_offset, i__1, i__2;
+
+    /* Local variables */
+    integer info;
+    doublereal work[100];
+    integer i__, j;
+    doublereal z__[144]	/* was [12][12] */;
+    extern /* Subroutine */ int dlakf2_(integer *, integer *, doublereal *, 
+	    integer *, doublereal *, doublereal *, doublereal *, doublereal *,
+	     integer *), dgesvd_(char *, char *, integer *, integer *, 
+	    doublereal *, integer *, doublereal *, doublereal *, integer *, 
+	    doublereal *, integer *, doublereal *, integer *, integer *), dlacpy_(char *, integer *, integer *, 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Generate test problem ... */
+/*     (Da, Db) ... */
+
+    /* Parameter adjustments */
+    b_dim1 = *lda;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    x_dim1 = *ldx;
+    x_offset = 1 + x_dim1 * 1;
+    x -= x_offset;
+    y_dim1 = *ldy;
+    y_offset = 1 + y_dim1 * 1;
+    y -= y_offset;
+    --s;
+    --dif;
+
+    /* Function Body */
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	i__2 = *n;
+	for (j = 1; j <= i__2; ++j) {
+
+	    if (i__ == j) {
+		a[i__ + i__ * a_dim1] = (doublereal) i__ + *alpha;
+		b[i__ + i__ * b_dim1] = 1.;
+	    } else {
+		a[i__ + j * a_dim1] = 0.;
+		b[i__ + j * b_dim1] = 0.;
+	    }
+
+/* L10: */
+	}
+/* L20: */
+    }
+
+/*     Form X and Y */
+
+    dlacpy_("F", n, n, &b[b_offset], lda, &y[y_offset], ldy);
+    y[y_dim1 + 3] = -(*wy);
+    y[y_dim1 + 4] = *wy;
+    y[y_dim1 + 5] = -(*wy);
+    y[(y_dim1 << 1) + 3] = -(*wy);
+    y[(y_dim1 << 1) + 4] = *wy;
+    y[(y_dim1 << 1) + 5] = -(*wy);
+
+    dlacpy_("F", n, n, &b[b_offset], lda, &x[x_offset], ldx);
+    x[x_dim1 * 3 + 1] = -(*wx);
+    x[(x_dim1 << 2) + 1] = -(*wx);
+    x[x_dim1 * 5 + 1] = *wx;
+    x[x_dim1 * 3 + 2] = *wx;
+    x[(x_dim1 << 2) + 2] = -(*wx);
+    x[x_dim1 * 5 + 2] = -(*wx);
+
+/*     Form (A, B) */
+
+    b[b_dim1 * 3 + 1] = *wx + *wy;
+    b[b_dim1 * 3 + 2] = -(*wx) + *wy;
+    b[(b_dim1 << 2) + 1] = *wx - *wy;
+    b[(b_dim1 << 2) + 2] = *wx - *wy;
+    b[b_dim1 * 5 + 1] = -(*wx) + *wy;
+    b[b_dim1 * 5 + 2] = *wx + *wy;
+    if (*type__ == 1) {
+	a[a_dim1 * 3 + 1] = *wx * a[a_dim1 + 1] + *wy * a[a_dim1 * 3 + 3];
+	a[a_dim1 * 3 + 2] = -(*wx) * a[(a_dim1 << 1) + 2] + *wy * a[a_dim1 * 
+		3 + 3];
+	a[(a_dim1 << 2) + 1] = *wx * a[a_dim1 + 1] - *wy * a[(a_dim1 << 2) + 
+		4];
+	a[(a_dim1 << 2) + 2] = *wx * a[(a_dim1 << 1) + 2] - *wy * a[(a_dim1 <<
+		 2) + 4];
+	a[a_dim1 * 5 + 1] = -(*wx) * a[a_dim1 + 1] + *wy * a[a_dim1 * 5 + 5];
+	a[a_dim1 * 5 + 2] = *wx * a[(a_dim1 << 1) + 2] + *wy * a[a_dim1 * 5 + 
+		5];
+    } else if (*type__ == 2) {
+	a[a_dim1 * 3 + 1] = *wx * 2. + *wy;
+	a[a_dim1 * 3 + 2] = *wy;
+	a[(a_dim1 << 2) + 1] = -(*wy) * (*alpha + 2. + *beta);
+	a[(a_dim1 << 2) + 2] = *wx * 2. - *wy * (*alpha + 2. + *beta);
+	a[a_dim1 * 5 + 1] = *wx * -2. + *wy * (*alpha - *beta);
+	a[a_dim1 * 5 + 2] = *wy * (*alpha - *beta);
+	a[a_dim1 + 1] = 1.;
+	a[(a_dim1 << 1) + 1] = -1.;
+	a[a_dim1 + 2] = 1.;
+	a[(a_dim1 << 1) + 2] = a[a_dim1 + 1];
+	a[a_dim1 * 3 + 3] = 1.;
+	a[(a_dim1 << 2) + 4] = *alpha + 1.;
+	a[a_dim1 * 5 + 4] = *beta + 1.;
+	a[(a_dim1 << 2) + 5] = -a[a_dim1 * 5 + 4];
+	a[a_dim1 * 5 + 5] = a[(a_dim1 << 2) + 4];
+    }
+
+/*     Compute condition numbers */
+
+    if (*type__ == 1) {
+
+	s[1] = 1. / sqrt((*wy * 3. * *wy + 1.) / (a[a_dim1 + 1] * a[a_dim1 + 
+		1] + 1.));
+	s[2] = 1. / sqrt((*wy * 3. * *wy + 1.) / (a[(a_dim1 << 1) + 2] * a[(
+		a_dim1 << 1) + 2] + 1.));
+	s[3] = 1. / sqrt((*wx * 2. * *wx + 1.) / (a[a_dim1 * 3 + 3] * a[
+		a_dim1 * 3 + 3] + 1.));
+	s[4] = 1. / sqrt((*wx * 2. * *wx + 1.) / (a[(a_dim1 << 2) + 4] * a[(
+		a_dim1 << 2) + 4] + 1.));
+	s[5] = 1. / sqrt((*wx * 2. * *wx + 1.) / (a[a_dim1 * 5 + 5] * a[
+		a_dim1 * 5 + 5] + 1.));
+
+	dlakf2_(&c__1, &c__4, &a[a_offset], lda, &a[(a_dim1 << 1) + 2], &b[
+		b_offset], &b[(b_dim1 << 1) + 2], z__, &c__12);
+	dgesvd_("N", "N", &c__8, &c__8, z__, &c__12, work, &work[8], &c__1, &
+		work[9], &c__1, &work[10], &c__40, &info);
+	dif[1] = work[7];
+
+	dlakf2_(&c__4, &c__1, &a[a_offset], lda, &a[a_dim1 * 5 + 5], &b[
+		b_offset], &b[b_dim1 * 5 + 5], z__, &c__12);
+	dgesvd_("N", "N", &c__8, &c__8, z__, &c__12, work, &work[8], &c__1, &
+		work[9], &c__1, &work[10], &c__40, &info);
+	dif[5] = work[7];
+
+    } else if (*type__ == 2) {
+
+	s[1] = 1. / sqrt(*wy * *wy + .33333333333333331);
+	s[2] = s[1];
+	s[3] = 1. / sqrt(*wx * *wx + .5);
+	s[4] = 1. / sqrt((*wx * 2. * *wx + 1.) / ((*alpha + 1.) * (*alpha + 
+		1.) + 1. + (*beta + 1.) * (*beta + 1.)));
+	s[5] = s[4];
+
+	dlakf2_(&c__2, &c__3, &a[a_offset], lda, &a[a_dim1 * 3 + 3], &b[
+		b_offset], &b[b_dim1 * 3 + 3], z__, &c__12);
+	dgesvd_("N", "N", &c__12, &c__12, z__, &c__12, work, &work[12], &c__1,
+		 &work[13], &c__1, &work[14], &c__60, &info);
+	dif[1] = work[11];
+
+	dlakf2_(&c__3, &c__2, &a[a_offset], lda, &a[(a_dim1 << 2) + 4], &b[
+		b_offset], &b[(b_dim1 << 2) + 4], z__, &c__12);
+	dgesvd_("N", "N", &c__12, &c__12, z__, &c__12, work, &work[12], &c__1,
+		 &work[13], &c__1, &work[14], &c__60, &info);
+	dif[5] = work[11];
+
+    }
+
+    return 0;
+
+/*     End of DLATM6 */
+
+} /* dlatm6_ */
+

lapack-netlib/TESTING/MATGEN/dlatm7.c

@@ -0,0 +1,699 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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)
+*/
+
+
+
+/* > \brief \b DLATM7 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE DLATM7( MODE, COND, IRSIGN, IDIST, ISEED, D, N, */
+/*                          RANK, INFO ) */
+
+/*       DOUBLE PRECISION   COND */
+/*       INTEGER            IDIST, INFO, IRSIGN, MODE, N, RANK */
+/*       DOUBLE PRECISION   D( * ) */
+/*       INTEGER            ISEED( 4 ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* >    DLATM7 computes the entries of D as specified by MODE */
+/* >    COND and IRSIGN. IDIST and ISEED determine the generation */
+/* >    of random numbers. DLATM7 is called by DLATMT to generate */
+/* >    random test matrices. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \verbatim */
+/* >  MODE   - INTEGER */
+/* >           On entry describes how D is to be computed: */
+/* >           MODE = 0 means do not change D. */
+/* > */
+/* >           MODE = 1 sets D(1)=1 and D(2:RANK)=1.0/COND */
+/* >           MODE = 2 sets D(1:RANK-1)=1 and D(RANK)=1.0/COND */
+/* >           MODE = 3 sets D(I)=COND**(-(I-1)/(RANK-1)) I=1:RANK */
+/* > */
+/* >           MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* >           MODE = 5 sets D to random numbers in the range */
+/* >                    ( 1/COND , 1 ) such that their logarithms */
+/* >                    are uniformly distributed. */
+/* >           MODE = 6 set D to random numbers from same distribution */
+/* >                    as the rest of the matrix. */
+/* >           MODE < 0 has the same meaning as ABS(MODE), except that */
+/* >              the order of the elements of D is reversed. */
+/* >           Thus if MODE is positive, D has entries ranging from */
+/* >              1 to 1/COND, if negative, from 1/COND to 1, */
+/* >           Not modified. */
+/* > */
+/* >  COND   - DOUBLE PRECISION */
+/* >           On entry, used as described under MODE above. */
+/* >           If used, it must be >= 1. Not modified. */
+/* > */
+/* >  IRSIGN - INTEGER */
+/* >           On entry, if MODE neither -6, 0 nor 6, determines sign of */
+/* >           entries of D */
+/* >           0 => leave entries of D unchanged */
+/* >           1 => multiply each entry of D by 1 or -1 with probability .5 */
+/* > */
+/* >  IDIST  - CHARACTER*1 */
+/* >           On entry, IDIST specifies the type of distribution to be */
+/* >           used to generate a random matrix . */
+/* >           1 => UNIFORM( 0, 1 ) */
+/* >           2 => UNIFORM( -1, 1 ) */
+/* >           3 => NORMAL( 0, 1 ) */
+/* >           Not modified. */
+/* > */
+/* >  ISEED  - INTEGER array, dimension ( 4 ) */
+/* >           On entry ISEED specifies the seed of the random number */
+/* >           generator. The random number generator uses a */
+/* >           linear congruential sequence limited to small */
+/* >           integers, and so should produce machine independent */
+/* >           random numbers. The values of ISEED are changed on */
+/* >           exit, and can be used in the next call to DLATM7 */
+/* >           to continue the same random number sequence. */
+/* >           Changed on exit. */
+/* > */
+/* >  D      - DOUBLE PRECISION array, dimension ( MIN( M , N ) ) */
+/* >           Array to be computed according to MODE, COND and IRSIGN. */
+/* >           May be changed on exit if MODE is nonzero. */
+/* > */
+/* >  N      - INTEGER */
+/* >           Number of entries of D. Not modified. */
+/* > */
+/* >  RANK   - INTEGER */
+/* >           The rank of matrix to be generated for modes 1,2,3 only. */
+/* >           D( RANK+1:N ) = 0. */
+/* >           Not modified. */
+/* > */
+/* >  INFO   - INTEGER */
+/* >            0  => normal termination */
+/* >           -1  => if MODE not in range -6 to 6 */
+/* >           -2  => if MODE neither -6, 0 nor 6, and */
+/* >                  IRSIGN neither 0 nor 1 */
+/* >           -3  => if MODE neither -6, 0 nor 6 and COND less than 1 */
+/* >           -4  => if MODE equals 6 or -6 and IDIST not in range 1 to 3 */
+/* >           -7  => if N negative */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup double_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int dlatm7_(integer *mode, doublereal *cond, integer *irsign,
+	 integer *idist, integer *iseed, doublereal *d__, integer *n, integer 
+	*rank, integer *info)
+{
+    /* System generated locals */
+    integer i__1, i__2;
+    doublereal d__1;
+
+    /* Local variables */
+    doublereal temp;
+    integer i__;
+    doublereal alpha;
+    extern doublereal dlaran_(integer *);
+    extern /* Subroutine */ int xerbla_(char *, integer *), dlarnv_(
+	    integer *, integer *, integer *, doublereal *);
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Decode and Test the input parameters. Initialize flags & seed. */
+
+    /* Parameter adjustments */
+    --d__;
+    --iseed;
+
+    /* Function Body */
+    *info = 0;
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+/*     Set INFO if an error */
+
+    if (*mode < -6 || *mode > 6) {
+	*info = -1;
+    } else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && *
+	    irsign != 1)) {
+	*info = -2;
+    } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.) {
+	*info = -3;
+    } else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 3)) {
+	*info = -4;
+    } else if (*n < 0) {
+	*info = -7;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("DLATM7", &i__1);
+	return 0;
+    }
+
+/*     Compute D according to COND and MODE */
+
+    if (*mode != 0) {
+	switch (abs(*mode)) {
+	    case 1:  goto L100;
+	    case 2:  goto L130;
+	    case 3:  goto L160;
+	    case 4:  goto L190;
+	    case 5:  goto L210;
+	    case 6:  goto L230;
+	}
+
+/*        One large D value: */
+
+L100:
+	i__1 = *rank;
+	for (i__ = 2; i__ <= i__1; ++i__) {
+	    d__[i__] = 1. / *cond;
+/* L110: */
+	}
+	i__1 = *n;
+	for (i__ = *rank + 1; i__ <= i__1; ++i__) {
+	    d__[i__] = 0.;
+/* L120: */
+	}
+	d__[1] = 1.;
+	goto L240;
+
+/*        One small D value: */
+
+L130:
+	i__1 = *rank - 1;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    d__[i__] = 1.;
+/* L140: */
+	}
+	i__1 = *n;
+	for (i__ = *rank + 1; i__ <= i__1; ++i__) {
+	    d__[i__] = 0.;
+/* L150: */
+	}
+	d__[*rank] = 1. / *cond;
+	goto L240;
+
+/*        Exponentially distributed D values: */
+
+L160:
+	d__[1] = 1.;
+	if (*n > 1 && *rank > 1) {
+	    d__1 = -1. / (doublereal) (*rank - 1);
+	    alpha = pow_dd(cond, &d__1);
+	    i__1 = *rank;
+	    for (i__ = 2; i__ <= i__1; ++i__) {
+		i__2 = i__ - 1;
+		d__[i__] = pow_di(&alpha, &i__2);
+/* L170: */
+	    }
+	    i__1 = *n;
+	    for (i__ = *rank + 1; i__ <= i__1; ++i__) {
+		d__[i__] = 0.;
+/* L180: */
+	    }
+	}
+	goto L240;
+
+/*        Arithmetically distributed D values: */
+
+L190:
+	d__[1] = 1.;
+	if (*n > 1) {
+	    temp = 1. / *cond;
+	    alpha = (1. - temp) / (doublereal) (*n - 1);
+	    i__1 = *n;
+	    for (i__ = 2; i__ <= i__1; ++i__) {
+		d__[i__] = (doublereal) (*n - i__) * alpha + temp;
+/* L200: */
+	    }
+	}
+	goto L240;
+
+/*        Randomly distributed D values on ( 1/COND , 1): */
+
+L210:
+	alpha = log(1. / *cond);
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    d__[i__] = exp(alpha * dlaran_(&iseed[1]));
+/* L220: */
+	}
+	goto L240;
+
+/*        Randomly distributed D values from IDIST */
+
+L230:
+	dlarnv_(idist, &iseed[1], n, &d__[1]);
+
+L240:
+
+/*        If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */
+/*        random signs to D */
+
+	if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) {
+	    i__1 = *n;
+	    for (i__ = 1; i__ <= i__1; ++i__) {
+		temp = dlaran_(&iseed[1]);
+		if (temp > .5) {
+		    d__[i__] = -d__[i__];
+		}
+/* L250: */
+	    }
+	}
+
+/*        Reverse if MODE < 0 */
+
+	if (*mode < 0) {
+	    i__1 = *n / 2;
+	    for (i__ = 1; i__ <= i__1; ++i__) {
+		temp = d__[i__];
+		d__[i__] = d__[*n + 1 - i__];
+		d__[*n + 1 - i__] = temp;
+/* L260: */
+	    }
+	}
+
+    }
+
+    return 0;
+
+/*     End of DLATM7 */
+
+} /* dlatm7_ */
+

lapack-netlib/TESTING/MATGEN/slagge.c

@@ -0,0 +1,845 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__3 = 3;
+static integer c__1 = 1;
+static real c_b11 = 1.f;
+static real c_b13 = 0.f;
+
+/* > \brief \b SLAGGE */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO ) */
+
+/*       INTEGER            INFO, KL, KU, LDA, M, N */
+/*       INTEGER            ISEED( 4 ) */
+/*       REAL               A( LDA, * ), D( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SLAGGE generates a real general m by n matrix A, by pre- and post- */
+/* > multiplying a real diagonal matrix D with random orthogonal matrices: */
+/* > A = U*D*V. The lower and upper bandwidths may then be reduced to */
+/* > kl and ku by additional orthogonal transformations. */
+/* > \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] KL */
+/* > \verbatim */
+/* >          KL is INTEGER */
+/* >          The number of nonzero subdiagonals within the band of A. */
+/* >          0 <= KL <= M-1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KU */
+/* > \verbatim */
+/* >          KU is INTEGER */
+/* >          The number of nonzero superdiagonals within the band of A. */
+/* >          0 <= KU <= N-1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is REAL array, dimension (f2cmin(M,N)) */
+/* >          The diagonal elements of the diagonal matrix D. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          The generated m by n matrix A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= M. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension (4) */
+/* >          On entry, the seed of the random number generator; the array */
+/* >          elements must be between 0 and 4095, and ISEED(4) must be */
+/* >          odd. */
+/* >          On exit, the seed is updated. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (M+N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit */
+/* >          < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup real_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int slagge_(integer *m, integer *n, integer *kl, integer *ku,
+	 real *d__, real *a, integer *lda, integer *iseed, real *work, 
+	integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+    real r__1;
+
+    /* Local variables */
+    extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, 
+	    integer *, real *, integer *, real *, integer *);
+    extern real snrm2_(integer *, real *, integer *);
+    integer i__, j;
+    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), 
+	    sgemv_(char *, integer *, integer *, real *, real *, integer *, 
+	    real *, integer *, real *, real *, integer *);
+    real wa, wb, wn;
+    extern /* Subroutine */ int xerbla_(char *, integer *), slarnv_(
+	    integer *, integer *, integer *, real *);
+    real tau;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    --d__;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --iseed;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    if (*m < 0) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*kl < 0 || *kl > *m - 1) {
+	*info = -3;
+    } else if (*ku < 0 || *ku > *n - 1) {
+	*info = -4;
+    } else if (*lda < f2cmax(1,*m)) {
+	*info = -7;
+    }
+    if (*info < 0) {
+	i__1 = -(*info);
+	xerbla_("SLAGGE", &i__1);
+	return 0;
+    }
+
+/*     initialize A to diagonal matrix */
+
+    i__1 = *n;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *m;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    a[i__ + j * a_dim1] = 0.f;
+/* L10: */
+	}
+/* L20: */
+    }
+    i__1 = f2cmin(*m,*n);
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	a[i__ + i__ * a_dim1] = d__[i__];
+/* L30: */
+    }
+
+/*     Quick exit if the user wants a diagonal matrix */
+
+    if (*kl == 0 && *ku == 0) {
+	return 0;
+    }
+
+/*     pre- and post-multiply A by random orthogonal matrices */
+
+    for (i__ = f2cmin(*m,*n); i__ >= 1; --i__) {
+	if (i__ < *m) {
+
+/*           generate random reflection */
+
+	    i__1 = *m - i__ + 1;
+	    slarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+	    i__1 = *m - i__ + 1;
+	    wn = snrm2_(&i__1, &work[1], &c__1);
+	    wa = r_sign(&wn, &work[1]);
+	    if (wn == 0.f) {
+		tau = 0.f;
+	    } else {
+		wb = work[1] + wa;
+		i__1 = *m - i__;
+		r__1 = 1.f / wb;
+		sscal_(&i__1, &r__1, &work[2], &c__1);
+		work[1] = 1.f;
+		tau = wb / wa;
+	    }
+
+/*           multiply A(i:m,i:n) by random reflection from the left */
+
+	    i__1 = *m - i__ + 1;
+	    i__2 = *n - i__ + 1;
+	    sgemv_("Transpose", &i__1, &i__2, &c_b11, &a[i__ + i__ * a_dim1], 
+		    lda, &work[1], &c__1, &c_b13, &work[*m + 1], &c__1);
+	    i__1 = *m - i__ + 1;
+	    i__2 = *n - i__ + 1;
+	    r__1 = -tau;
+	    sger_(&i__1, &i__2, &r__1, &work[1], &c__1, &work[*m + 1], &c__1, 
+		    &a[i__ + i__ * a_dim1], lda);
+	}
+	if (i__ < *n) {
+
+/*           generate random reflection */
+
+	    i__1 = *n - i__ + 1;
+	    slarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+	    i__1 = *n - i__ + 1;
+	    wn = snrm2_(&i__1, &work[1], &c__1);
+	    wa = r_sign(&wn, &work[1]);
+	    if (wn == 0.f) {
+		tau = 0.f;
+	    } else {
+		wb = work[1] + wa;
+		i__1 = *n - i__;
+		r__1 = 1.f / wb;
+		sscal_(&i__1, &r__1, &work[2], &c__1);
+		work[1] = 1.f;
+		tau = wb / wa;
+	    }
+
+/*           multiply A(i:m,i:n) by random reflection from the right */
+
+	    i__1 = *m - i__ + 1;
+	    i__2 = *n - i__ + 1;
+	    sgemv_("No transpose", &i__1, &i__2, &c_b11, &a[i__ + i__ * 
+		    a_dim1], lda, &work[1], &c__1, &c_b13, &work[*n + 1], &
+		    c__1);
+	    i__1 = *m - i__ + 1;
+	    i__2 = *n - i__ + 1;
+	    r__1 = -tau;
+	    sger_(&i__1, &i__2, &r__1, &work[*n + 1], &c__1, &work[1], &c__1, 
+		    &a[i__ + i__ * a_dim1], lda);
+	}
+/* L40: */
+    }
+
+/*     Reduce number of subdiagonals to KL and number of superdiagonals */
+/*     to KU */
+
+/* Computing MAX */
+    i__2 = *m - 1 - *kl, i__3 = *n - 1 - *ku;
+    i__1 = f2cmax(i__2,i__3);
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	if (*kl <= *ku) {
+
+/*           annihilate subdiagonal elements first (necessary if KL = 0) */
+
+/* Computing MIN */
+	    i__2 = *m - 1 - *kl;
+	    if (i__ <= f2cmin(i__2,*n)) {
+
+/*              generate reflection to annihilate A(kl+i+1:m,i) */
+
+		i__2 = *m - *kl - i__ + 1;
+		wn = snrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
+		wa = r_sign(&wn, &a[*kl + i__ + i__ * a_dim1]);
+		if (wn == 0.f) {
+		    tau = 0.f;
+		} else {
+		    wb = a[*kl + i__ + i__ * a_dim1] + wa;
+		    i__2 = *m - *kl - i__;
+		    r__1 = 1.f / wb;
+		    sscal_(&i__2, &r__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
+			    c__1);
+		    a[*kl + i__ + i__ * a_dim1] = 1.f;
+		    tau = wb / wa;
+		}
+
+/*              apply reflection to A(kl+i:m,i+1:n) from the left */
+
+		i__2 = *m - *kl - i__ + 1;
+		i__3 = *n - i__;
+		sgemv_("Transpose", &i__2, &i__3, &c_b11, &a[*kl + i__ + (i__ 
+			+ 1) * a_dim1], lda, &a[*kl + i__ + i__ * a_dim1], &
+			c__1, &c_b13, &work[1], &c__1);
+		i__2 = *m - *kl - i__ + 1;
+		i__3 = *n - i__;
+		r__1 = -tau;
+		sger_(&i__2, &i__3, &r__1, &a[*kl + i__ + i__ * a_dim1], &
+			c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) * 
+			a_dim1], lda);
+		a[*kl + i__ + i__ * a_dim1] = -wa;
+	    }
+
+/* Computing MIN */
+	    i__2 = *n - 1 - *ku;
+	    if (i__ <= f2cmin(i__2,*m)) {
+
+/*              generate reflection to annihilate A(i,ku+i+1:n) */
+
+		i__2 = *n - *ku - i__ + 1;
+		wn = snrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+		wa = r_sign(&wn, &a[i__ + (*ku + i__) * a_dim1]);
+		if (wn == 0.f) {
+		    tau = 0.f;
+		} else {
+		    wb = a[i__ + (*ku + i__) * a_dim1] + wa;
+		    i__2 = *n - *ku - i__;
+		    r__1 = 1.f / wb;
+		    sscal_(&i__2, &r__1, &a[i__ + (*ku + i__ + 1) * a_dim1], 
+			    lda);
+		    a[i__ + (*ku + i__) * a_dim1] = 1.f;
+		    tau = wb / wa;
+		}
+
+/*              apply reflection to A(i+1:m,ku+i:n) from the right */
+
+		i__2 = *m - i__;
+		i__3 = *n - *ku - i__ + 1;
+		sgemv_("No transpose", &i__2, &i__3, &c_b11, &a[i__ + 1 + (*
+			ku + i__) * a_dim1], lda, &a[i__ + (*ku + i__) * 
+			a_dim1], lda, &c_b13, &work[1], &c__1);
+		i__2 = *m - i__;
+		i__3 = *n - *ku - i__ + 1;
+		r__1 = -tau;
+		sger_(&i__2, &i__3, &r__1, &work[1], &c__1, &a[i__ + (*ku + 
+			i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) * 
+			a_dim1], lda);
+		a[i__ + (*ku + i__) * a_dim1] = -wa;
+	    }
+	} else {
+
+/*           annihilate superdiagonal elements first (necessary if */
+/*           KU = 0) */
+
+/* Computing MIN */
+	    i__2 = *n - 1 - *ku;
+	    if (i__ <= f2cmin(i__2,*m)) {
+
+/*              generate reflection to annihilate A(i,ku+i+1:n) */
+
+		i__2 = *n - *ku - i__ + 1;
+		wn = snrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+		wa = r_sign(&wn, &a[i__ + (*ku + i__) * a_dim1]);
+		if (wn == 0.f) {
+		    tau = 0.f;
+		} else {
+		    wb = a[i__ + (*ku + i__) * a_dim1] + wa;
+		    i__2 = *n - *ku - i__;
+		    r__1 = 1.f / wb;
+		    sscal_(&i__2, &r__1, &a[i__ + (*ku + i__ + 1) * a_dim1], 
+			    lda);
+		    a[i__ + (*ku + i__) * a_dim1] = 1.f;
+		    tau = wb / wa;
+		}
+
+/*              apply reflection to A(i+1:m,ku+i:n) from the right */
+
+		i__2 = *m - i__;
+		i__3 = *n - *ku - i__ + 1;
+		sgemv_("No transpose", &i__2, &i__3, &c_b11, &a[i__ + 1 + (*
+			ku + i__) * a_dim1], lda, &a[i__ + (*ku + i__) * 
+			a_dim1], lda, &c_b13, &work[1], &c__1);
+		i__2 = *m - i__;
+		i__3 = *n - *ku - i__ + 1;
+		r__1 = -tau;
+		sger_(&i__2, &i__3, &r__1, &work[1], &c__1, &a[i__ + (*ku + 
+			i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) * 
+			a_dim1], lda);
+		a[i__ + (*ku + i__) * a_dim1] = -wa;
+	    }
+
+/* Computing MIN */
+	    i__2 = *m - 1 - *kl;
+	    if (i__ <= f2cmin(i__2,*n)) {
+
+/*              generate reflection to annihilate A(kl+i+1:m,i) */
+
+		i__2 = *m - *kl - i__ + 1;
+		wn = snrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
+		wa = r_sign(&wn, &a[*kl + i__ + i__ * a_dim1]);
+		if (wn == 0.f) {
+		    tau = 0.f;
+		} else {
+		    wb = a[*kl + i__ + i__ * a_dim1] + wa;
+		    i__2 = *m - *kl - i__;
+		    r__1 = 1.f / wb;
+		    sscal_(&i__2, &r__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
+			    c__1);
+		    a[*kl + i__ + i__ * a_dim1] = 1.f;
+		    tau = wb / wa;
+		}
+
+/*              apply reflection to A(kl+i:m,i+1:n) from the left */
+
+		i__2 = *m - *kl - i__ + 1;
+		i__3 = *n - i__;
+		sgemv_("Transpose", &i__2, &i__3, &c_b11, &a[*kl + i__ + (i__ 
+			+ 1) * a_dim1], lda, &a[*kl + i__ + i__ * a_dim1], &
+			c__1, &c_b13, &work[1], &c__1);
+		i__2 = *m - *kl - i__ + 1;
+		i__3 = *n - i__;
+		r__1 = -tau;
+		sger_(&i__2, &i__3, &r__1, &a[*kl + i__ + i__ * a_dim1], &
+			c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) * 
+			a_dim1], lda);
+		a[*kl + i__ + i__ * a_dim1] = -wa;
+	    }
+	}
+
+	if (i__ <= *n) {
+	    i__2 = *m;
+	    for (j = *kl + i__ + 1; j <= i__2; ++j) {
+		a[j + i__ * a_dim1] = 0.f;
+/* L50: */
+	    }
+	}
+
+	if (i__ <= *m) {
+	    i__2 = *n;
+	    for (j = *ku + i__ + 1; j <= i__2; ++j) {
+		a[i__ + j * a_dim1] = 0.f;
+/* L60: */
+	    }
+	}
+/* L70: */
+    }
+    return 0;
+
+/*     End of SLAGGE */
+
+} /* slagge_ */
+

lapack-netlib/TESTING/MATGEN/slagsy.c

@@ -0,0 +1,702 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__3 = 3;
+static integer c__1 = 1;
+static real c_b12 = 0.f;
+static real c_b19 = -1.f;
+static real c_b26 = 1.f;
+
+/* > \brief \b SLAGSY */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) */
+
+/*       INTEGER            INFO, K, LDA, N */
+/*       INTEGER            ISEED( 4 ) */
+/*       REAL               A( LDA, * ), D( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SLAGSY generates a real symmetric matrix A, by pre- and post- */
+/* > multiplying a real diagonal matrix D with a random orthogonal matrix: */
+/* > A = U*D*U'. The semi-bandwidth may then be reduced to k by additional */
+/* > orthogonal transformations. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] K */
+/* > \verbatim */
+/* >          K is INTEGER */
+/* >          The number of nonzero subdiagonals within the band of A. */
+/* >          0 <= K <= N-1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is REAL array, dimension (N) */
+/* >          The diagonal elements of the diagonal matrix D. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          The generated n by n symmetric matrix A (the full matrix is */
+/* >          stored). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension (4) */
+/* >          On entry, the seed of the random number generator; the array */
+/* >          elements must be between 0 and 4095, and ISEED(4) must be */
+/* >          odd. */
+/* >          On exit, the seed is updated. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK 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 real_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int slagsy_(integer *n, integer *k, real *d__, real *a, 
+	integer *lda, integer *iseed, real *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+    real r__1;
+
+    /* Local variables */
+    extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, 
+	    integer *, real *, integer *, real *, integer *);
+    extern real sdot_(integer *, real *, integer *, real *, integer *), 
+	    snrm2_(integer *, real *, integer *);
+    integer i__, j;
+    extern /* Subroutine */ int ssyr2_(char *, integer *, real *, real *, 
+	    integer *, real *, integer *, real *, integer *);
+    real alpha;
+    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), 
+	    sgemv_(char *, integer *, integer *, real *, real *, integer *, 
+	    real *, integer *, real *, real *, integer *), saxpy_(
+	    integer *, real *, real *, integer *, real *, integer *), ssymv_(
+	    char *, integer *, real *, real *, integer *, real *, integer *, 
+	    real *, real *, integer *);
+    real wa, wb, wn;
+    extern /* Subroutine */ int xerbla_(char *, integer *), slarnv_(
+	    integer *, integer *, integer *, real *);
+    real tau;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    --d__;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --iseed;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    if (*n < 0) {
+	*info = -1;
+    } else if (*k < 0 || *k > *n - 1) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    }
+    if (*info < 0) {
+	i__1 = -(*info);
+	xerbla_("SLAGSY", &i__1);
+	return 0;
+    }
+
+/*     initialize lower triangle of A to diagonal matrix */
+
+    i__1 = *n;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *n;
+	for (i__ = j + 1; i__ <= i__2; ++i__) {
+	    a[i__ + j * a_dim1] = 0.f;
+/* L10: */
+	}
+/* L20: */
+    }
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	a[i__ + i__ * a_dim1] = d__[i__];
+/* L30: */
+    }
+
+/*     Generate lower triangle of symmetric matrix */
+
+    for (i__ = *n - 1; i__ >= 1; --i__) {
+
+/*        generate random reflection */
+
+	i__1 = *n - i__ + 1;
+	slarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+	i__1 = *n - i__ + 1;
+	wn = snrm2_(&i__1, &work[1], &c__1);
+	wa = r_sign(&wn, &work[1]);
+	if (wn == 0.f) {
+	    tau = 0.f;
+	} else {
+	    wb = work[1] + wa;
+	    i__1 = *n - i__;
+	    r__1 = 1.f / wb;
+	    sscal_(&i__1, &r__1, &work[2], &c__1);
+	    work[1] = 1.f;
+	    tau = wb / wa;
+	}
+
+/*        apply random reflection to A(i:n,i:n) from the left */
+/*        and the right */
+
+/*        compute  y := tau * A * u */
+
+	i__1 = *n - i__ + 1;
+	ssymv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], &
+		c__1, &c_b12, &work[*n + 1], &c__1);
+
+/*        compute  v := y - 1/2 * tau * ( y, u ) * u */
+
+	i__1 = *n - i__ + 1;
+	alpha = tau * -.5f * sdot_(&i__1, &work[*n + 1], &c__1, &work[1], &
+		c__1);
+	i__1 = *n - i__ + 1;
+	saxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
+
+/*        apply the transformation as a rank-2 update to A(i:n,i:n) */
+
+	i__1 = *n - i__ + 1;
+	ssyr2_("Lower", &i__1, &c_b19, &work[1], &c__1, &work[*n + 1], &c__1, 
+		&a[i__ + i__ * a_dim1], lda);
+/* L40: */
+    }
+
+/*     Reduce number of subdiagonals to K */
+
+    i__1 = *n - 1 - *k;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+
+/*        generate reflection to annihilate A(k+i+1:n,i) */
+
+	i__2 = *n - *k - i__ + 1;
+	wn = snrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
+	wa = r_sign(&wn, &a[*k + i__ + i__ * a_dim1]);
+	if (wn == 0.f) {
+	    tau = 0.f;
+	} else {
+	    wb = a[*k + i__ + i__ * a_dim1] + wa;
+	    i__2 = *n - *k - i__;
+	    r__1 = 1.f / wb;
+	    sscal_(&i__2, &r__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1);
+	    a[*k + i__ + i__ * a_dim1] = 1.f;
+	    tau = wb / wa;
+	}
+
+/*        apply reflection to A(k+i:n,i+1:k+i-1) from the left */
+
+	i__2 = *n - *k - i__ + 1;
+	i__3 = *k - 1;
+	sgemv_("Transpose", &i__2, &i__3, &c_b26, &a[*k + i__ + (i__ + 1) * 
+		a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b12, &
+		work[1], &c__1);
+	i__2 = *n - *k - i__ + 1;
+	i__3 = *k - 1;
+	r__1 = -tau;
+	sger_(&i__2, &i__3, &r__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[
+		1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda);
+
+/*        apply reflection to A(k+i:n,k+i:n) from the left and the right */
+
+/*        compute  y := tau * A * u */
+
+	i__2 = *n - *k - i__ + 1;
+	ssymv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda, 
+		&a[*k + i__ + i__ * a_dim1], &c__1, &c_b12, &work[1], &c__1);
+
+/*        compute  v := y - 1/2 * tau * ( y, u ) * u */
+
+	i__2 = *n - *k - i__ + 1;
+	alpha = tau * -.5f * sdot_(&i__2, &work[1], &c__1, &a[*k + i__ + i__ *
+		 a_dim1], &c__1);
+	i__2 = *n - *k - i__ + 1;
+	saxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
+		c__1);
+
+/*        apply symmetric rank-2 update to A(k+i:n,k+i:n) */
+
+	i__2 = *n - *k - i__ + 1;
+	ssyr2_("Lower", &i__2, &c_b19, &a[*k + i__ + i__ * a_dim1], &c__1, &
+		work[1], &c__1, &a[*k + i__ + (*k + i__) * a_dim1], lda);
+
+	a[*k + i__ + i__ * a_dim1] = -wa;
+	i__2 = *n;
+	for (j = *k + i__ + 1; j <= i__2; ++j) {
+	    a[j + i__ * a_dim1] = 0.f;
+/* L50: */
+	}
+/* L60: */
+    }
+
+/*     Store full symmetric matrix */
+
+    i__1 = *n;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *n;
+	for (i__ = j + 1; i__ <= i__2; ++i__) {
+	    a[j + i__ * a_dim1] = a[i__ + j * a_dim1];
+/* L70: */
+	}
+/* L80: */
+    }
+    return 0;
+
+/*     End of SLAGSY */
+
+} /* slagsy_ */
+

lapack-netlib/TESTING/MATGEN/slahilb.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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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 = 0.f;
+
+/* > \brief \b SLAHILB */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, INFO) */
+
+/*       INTEGER N, NRHS, LDA, LDX, LDB, INFO */
+/*       REAL A(LDA, N), X(LDX, NRHS), B(LDB, NRHS), WORK(N) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SLAHILB generates an N by N scaled Hilbert matrix in A along with */
+/* > NRHS right-hand sides in B and solutions in X such that A*X=B. */
+/* > */
+/* > The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all */
+/* > entries are integers.  The right-hand sides are the first NRHS */
+/* > columns of M * the identity matrix, and the solutions are the */
+/* > first NRHS columns of the inverse Hilbert matrix. */
+/* > */
+/* > The condition number of the Hilbert matrix grows exponentially with */
+/* > its size, roughly as O(e ** (3.5*N)).  Additionally, the inverse */
+/* > Hilbert matrices beyond a relatively small dimension cannot be */
+/* > generated exactly without extra precision.  Precision is exhausted */
+/* > when the largest entry in the inverse Hilbert matrix is greater than */
+/* > 2 to the power of the number of bits in the fraction of the data type */
+/* > used plus one, which is 24 for single precision. */
+/* > */
+/* > In single, the generated solution is exact for N <= 6 and has */
+/* > small componentwise error for 7 <= N <= 11. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The dimension of the matrix A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The requested number of right-hand sides. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA, N) */
+/* >          The generated scaled Hilbert matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] X */
+/* > \verbatim */
+/* >          X is REAL array, dimension (LDX, NRHS) */
+/* >          The generated exact solutions.  Currently, the first NRHS */
+/* >          columns of the inverse Hilbert matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDX */
+/* > \verbatim */
+/* >          LDX is INTEGER */
+/* >          The leading dimension of the array X.  LDX >= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB, NRHS) */
+/* >          The generated right-hand sides.  Currently, the first NRHS */
+/* >          columns of LCM(1, 2, ..., 2*N-1) * the identity matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit */
+/* >          = 1: N is too large; the data is still generated but may not */
+/* >               be not exact. */
+/* >          < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date November 2017 */
+
+/* > \ingroup real_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int slahilb_(integer *n, integer *nrhs, real *a, integer *
+	lda, real *x, integer *ldx, real *b, integer *ldb, real *work, 
+	integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, x_dim1, x_offset, b_dim1, b_offset, i__1, i__2;
+    real r__1;
+
+    /* Local variables */
+    integer i__, j, m, r__, ti, tm;
+    extern /* Subroutine */ int xerbla_(char *, integer *), slaset_(
+	    char *, integer *, integer *, real *, real *, real *, integer *);
+
+
+/*  -- LAPACK test routine (version 3.8.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     November 2017 */
+
+
+/*  ===================================================================== */
+/*     NMAX_EXACT   the largest dimension where the generated data is */
+/*                  exact. */
+/*     NMAX_APPROX  the largest dimension where the generated data has */
+/*                  a small componentwise relative error. */
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    --work;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    x_dim1 = *ldx;
+    x_offset = 1 + x_dim1 * 1;
+    x -= x_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+
+    /* Function Body */
+    *info = 0;
+    if (*n < 0 || *n > 11) {
+	*info = -1;
+    } else if (*nrhs < 0) {
+	*info = -2;
+    } else if (*lda < *n) {
+	*info = -4;
+    } else if (*ldx < *n) {
+	*info = -6;
+    } else if (*ldb < *n) {
+	*info = -8;
+    }
+    if (*info < 0) {
+	i__1 = -(*info);
+	xerbla_("SLAHILB", &i__1);
+	return 0;
+    }
+    if (*n > 6) {
+	*info = 1;
+    }
+
+/*     Compute M = the LCM of the integers [1, 2*N-1].  The largest */
+/*     reasonable N is small enough that integers suffice (up to N = 11). */
+    m = 1;
+    i__1 = (*n << 1) - 1;
+    for (i__ = 2; i__ <= i__1; ++i__) {
+	tm = m;
+	ti = i__;
+	r__ = tm % ti;
+	while(r__ != 0) {
+	    tm = ti;
+	    ti = r__;
+	    r__ = tm % ti;
+	}
+	m = m / ti * i__;
+    }
+
+/*     Generate the scaled Hilbert matrix in A */
+    i__1 = *n;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *n;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    a[i__ + j * a_dim1] = (real) m / (i__ + j - 1);
+	}
+    }
+
+/*     Generate matrix B as simply the first NRHS columns of M * the */
+/*     identity. */
+    r__1 = (real) m;
+    slaset_("Full", n, nrhs, &c_b4, &r__1, &b[b_offset], ldb);
+
+/*     Generate the true solutions in X.  Because B = the first NRHS */
+/*     columns of M*I, the true solutions are just the first NRHS columns */
+/*     of the inverse Hilbert matrix. */
+    work[1] = (real) (*n);
+    i__1 = *n;
+    for (j = 2; j <= i__1; ++j) {
+	work[j] = work[j - 1] / (j - 1) * (j - 1 - *n) / (j - 1) * (*n + j - 
+		1);
+    }
+
+    i__1 = *nrhs;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *n;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    x[i__ + j * x_dim1] = work[i__] * work[j] / (i__ + j - 1);
+	}
+    }
+
+    return 0;
+} /* slahilb_ */
+

lapack-netlib/TESTING/MATGEN/slakf2.c

@@ -0,0 +1,614 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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_b3 = 0.f;
+
+/* > \brief \b SLAKF2 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SLAKF2( M, N, A, LDA, B, D, E, Z, LDZ ) */
+
+/*       INTEGER            LDA, LDZ, M, N */
+/*       REAL               A( LDA, * ), B( LDA, * ), D( LDA, * ), */
+/*      $                   E( LDA, * ), Z( LDZ, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > Form the 2*M*N by 2*M*N matrix */
+/* > */
+/* >        Z = [ kron(In, A)  -kron(B', Im) ] */
+/* >            [ kron(In, D)  -kron(E', Im) ], */
+/* > */
+/* > where In is the identity matrix of size n and X' is the transpose */
+/* > of X. kron(X, Y) is the Kronecker product between the matrices X */
+/* > and Y. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          Size of matrix, must be >= 1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          Size of matrix, must be >= 1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] A */
+/* > \verbatim */
+/* >          A is REAL, dimension ( LDA, M ) */
+/* >          The matrix A in the output matrix Z. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of A, B, D, and E. ( LDA >= M+N ) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] B */
+/* > \verbatim */
+/* >          B is REAL, dimension ( LDA, N ) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is REAL, dimension ( LDA, M ) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] E */
+/* > \verbatim */
+/* >          E is REAL, dimension ( LDA, N ) */
+/* > */
+/* >          The matrices used in forming the output matrix Z. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Z */
+/* > \verbatim */
+/* >          Z is REAL, dimension ( LDZ, 2*M*N ) */
+/* >          The resultant Kronecker M*N*2 by M*N*2 matrix (see above.) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDZ */
+/* > \verbatim */
+/* >          LDZ is INTEGER */
+/* >          The leading dimension of Z. ( LDZ >= 2*M*N ) */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup real_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int slakf2_(integer *m, integer *n, real *a, integer *lda, 
+	real *b, real *d__, real *e, real *z__, integer *ldz)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, d_dim1, d_offset, e_dim1, 
+	    e_offset, z_dim1, z_offset, i__1, i__2, i__3;
+
+    /* Local variables */
+    integer i__, j, l, ik, jk, mn;
+    extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *, 
+	    real *, real *, integer *);
+    integer mn2;
+
+
+/*  -- 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 */
+
+
+/*  ==================================================================== */
+
+
+/*     Initialize Z */
+
+    /* Parameter adjustments */
+    e_dim1 = *lda;
+    e_offset = 1 + e_dim1 * 1;
+    e -= e_offset;
+    d_dim1 = *lda;
+    d_offset = 1 + d_dim1 * 1;
+    d__ -= d_offset;
+    b_dim1 = *lda;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    z_dim1 = *ldz;
+    z_offset = 1 + z_dim1 * 1;
+    z__ -= z_offset;
+
+    /* Function Body */
+    mn = *m * *n;
+    mn2 = mn << 1;
+    slaset_("Full", &mn2, &mn2, &c_b3, &c_b3, &z__[z_offset], ldz);
+
+    ik = 1;
+    i__1 = *n;
+    for (l = 1; l <= i__1; ++l) {
+
+/*        form kron(In, A) */
+
+	i__2 = *m;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    i__3 = *m;
+	    for (j = 1; j <= i__3; ++j) {
+		z__[ik + i__ - 1 + (ik + j - 1) * z_dim1] = a[i__ + j * 
+			a_dim1];
+/* L10: */
+	    }
+/* L20: */
+	}
+
+/*        form kron(In, D) */
+
+	i__2 = *m;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    i__3 = *m;
+	    for (j = 1; j <= i__3; ++j) {
+		z__[ik + mn + i__ - 1 + (ik + j - 1) * z_dim1] = d__[i__ + j *
+			 d_dim1];
+/* L30: */
+	    }
+/* L40: */
+	}
+
+	ik += *m;
+/* L50: */
+    }
+
+    ik = 1;
+    i__1 = *n;
+    for (l = 1; l <= i__1; ++l) {
+	jk = mn + 1;
+
+	i__2 = *n;
+	for (j = 1; j <= i__2; ++j) {
+
+/*           form -kron(B', Im) */
+
+	    i__3 = *m;
+	    for (i__ = 1; i__ <= i__3; ++i__) {
+		z__[ik + i__ - 1 + (jk + i__ - 1) * z_dim1] = -b[j + l * 
+			b_dim1];
+/* L60: */
+	    }
+
+/*           form -kron(E', Im) */
+
+	    i__3 = *m;
+	    for (i__ = 1; i__ <= i__3; ++i__) {
+		z__[ik + mn + i__ - 1 + (jk + i__ - 1) * z_dim1] = -e[j + l * 
+			e_dim1];
+/* L70: */
+	    }
+
+	    jk += *m;
+/* L80: */
+	}
+
+	ik += *m;
+/* L90: */
+    }
+
+    return 0;
+
+/*     End of SLAKF2 */
+
+} /* slakf2_ */
+

lapack-netlib/TESTING/MATGEN/slaran.c

@@ -0,0 +1,527 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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)
+*/
+
+
+
+/* > \brief \b SLARAN */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       REAL FUNCTION SLARAN( ISEED ) */
+
+/*       INTEGER            ISEED( 4 ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SLARAN returns a random real number from a uniform (0,1) */
+/* > distribution. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension (4) */
+/* >          On entry, the seed of the random number generator; the array */
+/* >          elements must be between 0 and 4095, and ISEED(4) must be */
+/* >          odd. */
+/* >          On exit, the seed is updated. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup real_matgen */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  This routine uses a multiplicative congruential method with modulus */
+/* >  2**48 and multiplier 33952834046453 (see G.S.Fishman, */
+/* >  'Multiplicative congruential random number generators with modulus */
+/* >  2**b: an exhaustive analysis for b = 32 and a partial analysis for */
+/* >  b = 48', Math. Comp. 189, pp 331-344, 1990). */
+/* > */
+/* >  48-bit integers are stored in 4 integer array elements with 12 bits */
+/* >  per element. Hence the routine is portable across machines with */
+/* >  integers of 32 bits or more. */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+real slaran_(integer *iseed)
+{
+    /* System generated locals */
+    real ret_val;
+
+    /* Local variables */
+    real rndout;
+    integer it1, it2, it3, it4;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+    /* Parameter adjustments */
+    --iseed;
+
+    /* Function Body */
+L10:
+
+/*     multiply the seed by the multiplier modulo 2**48 */
+
+    it4 = iseed[4] * 2549;
+    it3 = it4 / 4096;
+    it4 -= it3 << 12;
+    it3 = it3 + iseed[3] * 2549 + iseed[4] * 2508;
+    it2 = it3 / 4096;
+    it3 -= it2 << 12;
+    it2 = it2 + iseed[2] * 2549 + iseed[3] * 2508 + iseed[4] * 322;
+    it1 = it2 / 4096;
+    it2 -= it1 << 12;
+    it1 = it1 + iseed[1] * 2549 + iseed[2] * 2508 + iseed[3] * 322 + iseed[4] 
+	    * 494;
+    it1 %= 4096;
+
+/*     return updated seed */
+
+    iseed[1] = it1;
+    iseed[2] = it2;
+    iseed[3] = it3;
+    iseed[4] = it4;
+
+/*     convert 48-bit integer to a real number in the interval (0,1) */
+
+    rndout = ((real) it1 + ((real) it2 + ((real) it3 + (real) it4 * 
+	    2.44140625e-4f) * 2.44140625e-4f) * 2.44140625e-4f) * 
+	    2.44140625e-4f;
+
+    if (rndout == 1.f) {
+/*        If a real number has n bits of precision, and the first */
+/*        n bits of the 48-bit integer above happen to be all 1 (which */
+/*        will occur about once every 2**n calls), then SLARAN will */
+/*        be rounded to exactly 1.0. In IEEE single precision arithmetic, */
+/*        this will happen relatively often since n = 24. */
+/*        Since SLARAN is not supposed to return exactly 0.0 or 1.0 */
+/*        (and some callers of SLARAN, such as CLARND, depend on that), */
+/*        the statistically correct thing to do in this situation is */
+/*        simply to iterate again. */
+/*        N.B. the case SLARAN = 0.0 should not be possible. */
+
+	goto L10;
+    }
+
+    ret_val = rndout;
+    return ret_val;
+
+/*     End of SLARAN */
+
+} /* slaran_ */
+

lapack-netlib/TESTING/MATGEN/slarge.c

@@ -0,0 +1,579 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__3 = 3;
+static integer c__1 = 1;
+static real c_b8 = 1.f;
+static real c_b10 = 0.f;
+
+/* > \brief \b SLARGE */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SLARGE( N, A, LDA, ISEED, WORK, INFO ) */
+
+/*       INTEGER            INFO, LDA, N */
+/*       INTEGER            ISEED( 4 ) */
+/*       REAL               A( LDA, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SLARGE pre- and post-multiplies a real general n by n matrix A */
+/* > with a random orthogonal matrix: A = U*D*U'. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          On entry, the original n by n matrix A. */
+/* >          On exit, A is overwritten by U*A*U' for some random */
+/* >          orthogonal matrix U. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension (4) */
+/* >          On entry, the seed of the random number generator; the array */
+/* >          elements must be between 0 and 4095, and ISEED(4) must be */
+/* >          odd. */
+/* >          On exit, the seed is updated. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK 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 real_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int slarge_(integer *n, real *a, integer *lda, integer *
+	iseed, real *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1;
+    real r__1;
+
+    /* Local variables */
+    extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, 
+	    integer *, real *, integer *, real *, integer *);
+    extern real snrm2_(integer *, real *, integer *);
+    integer i__;
+    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), 
+	    sgemv_(char *, integer *, integer *, real *, real *, integer *, 
+	    real *, integer *, real *, real *, integer *);
+    real wa, wb, wn;
+    extern /* Subroutine */ int xerbla_(char *, integer *), slarnv_(
+	    integer *, integer *, integer *, real *);
+    real tau;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --iseed;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    if (*n < 0) {
+	*info = -1;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -3;
+    }
+    if (*info < 0) {
+	i__1 = -(*info);
+	xerbla_("SLARGE", &i__1);
+	return 0;
+    }
+
+/*     pre- and post-multiply A by random orthogonal matrix */
+
+    for (i__ = *n; i__ >= 1; --i__) {
+
+/*        generate random reflection */
+
+	i__1 = *n - i__ + 1;
+	slarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+	i__1 = *n - i__ + 1;
+	wn = snrm2_(&i__1, &work[1], &c__1);
+	wa = r_sign(&wn, &work[1]);
+	if (wn == 0.f) {
+	    tau = 0.f;
+	} else {
+	    wb = work[1] + wa;
+	    i__1 = *n - i__;
+	    r__1 = 1.f / wb;
+	    sscal_(&i__1, &r__1, &work[2], &c__1);
+	    work[1] = 1.f;
+	    tau = wb / wa;
+	}
+
+/*        multiply A(i:n,1:n) by random reflection from the left */
+
+	i__1 = *n - i__ + 1;
+	sgemv_("Transpose", &i__1, n, &c_b8, &a[i__ + a_dim1], lda, &work[1], 
+		&c__1, &c_b10, &work[*n + 1], &c__1);
+	i__1 = *n - i__ + 1;
+	r__1 = -tau;
+	sger_(&i__1, n, &r__1, &work[1], &c__1, &work[*n + 1], &c__1, &a[i__ 
+		+ a_dim1], lda);
+
+/*        multiply A(1:n,i:n) by random reflection from the right */
+
+	i__1 = *n - i__ + 1;
+	sgemv_("No transpose", n, &i__1, &c_b8, &a[i__ * a_dim1 + 1], lda, &
+		work[1], &c__1, &c_b10, &work[*n + 1], &c__1);
+	i__1 = *n - i__ + 1;
+	r__1 = -tau;
+	sger_(n, &i__1, &r__1, &work[*n + 1], &c__1, &work[1], &c__1, &a[i__ *
+		 a_dim1 + 1], lda);
+/* L10: */
+    }
+    return 0;
+
+/*     End of SLARGE */
+
+} /* slarge_ */
+

lapack-netlib/TESTING/MATGEN/slarnd.c

@@ -0,0 +1,508 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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)
+*/
+
+
+
+/* > \brief \b SLARND */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       REAL             FUNCTION SLARND( IDIST, ISEED ) */
+
+/*       INTEGER            IDIST */
+/*       INTEGER            ISEED( 4 ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SLARND returns a random real number from a uniform or normal */
+/* > distribution. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] IDIST */
+/* > \verbatim */
+/* >          IDIST is INTEGER */
+/* >          Specifies the distribution of the random numbers: */
+/* >          = 1:  uniform (0,1) */
+/* >          = 2:  uniform (-1,1) */
+/* >          = 3:  normal (0,1) */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension (4) */
+/* >          On entry, the seed of the random number generator; the array */
+/* >          elements must be between 0 and 4095, and ISEED(4) must be */
+/* >          odd. */
+/* >          On exit, the seed is updated. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup real_matgen */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  This routine calls the auxiliary routine SLARAN to generate a random */
+/* >  real number from a uniform (0,1) distribution. The Box-Muller method */
+/* >  is used to transform numbers from a uniform to a normal distribution. */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+real slarnd_(integer *idist, integer *iseed)
+{
+    /* System generated locals */
+    real ret_val;
+
+    /* Local variables */
+    real t1, t2;
+    extern real slaran_(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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Generate a real random number from a uniform (0,1) distribution */
+
+    /* Parameter adjustments */
+    --iseed;
+
+    /* Function Body */
+    t1 = slaran_(&iseed[1]);
+
+    if (*idist == 1) {
+
+/*        uniform (0,1) */
+
+	ret_val = t1;
+    } else if (*idist == 2) {
+
+/*        uniform (-1,1) */
+
+	ret_val = t1 * 2.f - 1.f;
+    } else if (*idist == 3) {
+
+/*        normal (0,1) */
+
+	t2 = slaran_(&iseed[1]);
+	ret_val = sqrt(log(t1) * -2.f) * cos(t2 * 
+		6.2831853071795864769252867663f);
+    }
+    return ret_val;
+
+/*     End of SLARND */
+
+} /* slarnd_ */
+

lapack-netlib/TESTING/MATGEN/slaror.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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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_b9 = 0.f;
+static real c_b10 = 1.f;
+static integer c__3 = 3;
+static integer c__1 = 1;
+
+/* > \brief \b SLAROR */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO ) */
+
+/*       CHARACTER          INIT, SIDE */
+/*       INTEGER            INFO, LDA, M, N */
+/*       INTEGER            ISEED( 4 ) */
+/*       REAL               A( LDA, * ), X( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SLAROR pre- or post-multiplies an M by N matrix A by a random */
+/* > orthogonal matrix U, overwriting A.  A may optionally be initialized */
+/* > to the identity matrix before multiplying by U.  U is generated using */
+/* > the method of G.W. Stewart (SIAM J. Numer. Anal. 17, 1980, 403-409). */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] SIDE */
+/* > \verbatim */
+/* >          SIDE is CHARACTER*1 */
+/* >          Specifies whether A is multiplied on the left or right by U. */
+/* >          = 'L':         Multiply A on the left (premultiply) by U */
+/* >          = 'R':         Multiply A on the right (postmultiply) by U' */
+/* >          = 'C' or 'T':  Multiply A on the left by U and the right */
+/* >                          by U' (Here, U' means U-transpose.) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] INIT */
+/* > \verbatim */
+/* >          INIT is CHARACTER*1 */
+/* >          Specifies whether or not A should be initialized to the */
+/* >          identity matrix. */
+/* >          = 'I':  Initialize A to (a section of) the identity matrix */
+/* >                   before applying U. */
+/* >          = 'N':  No initialization.  Apply U to the input matrix A. */
+/* > */
+/* >          INIT = 'I' may be used to generate square or rectangular */
+/* >          orthogonal matrices: */
+/* > */
+/* >          For M = N and SIDE = 'L' or 'R', the rows will be orthogonal */
+/* >          to each other, as will the columns. */
+/* > */
+/* >          If M < N, SIDE = 'R' produces a dense matrix whose rows are */
+/* >          orthogonal and whose columns are not, while SIDE = 'L' */
+/* >          produces a matrix whose rows are orthogonal, and whose first */
+/* >          M columns are orthogonal, and whose remaining columns are */
+/* >          zero. */
+/* > */
+/* >          If M > N, SIDE = 'L' produces a dense matrix whose columns */
+/* >          are orthogonal and whose rows are not, while SIDE = 'R' */
+/* >          produces a matrix whose columns are orthogonal, and whose */
+/* >          first M rows are orthogonal, and whose remaining rows are */
+/* >          zero. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of rows of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of columns of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA, N) */
+/* >          On entry, the array A. */
+/* >          On exit, overwritten by U A ( if SIDE = 'L' ), */
+/* >           or by A U ( if SIDE = 'R' ), */
+/* >           or by U A U' ( if SIDE = 'C' or 'T'). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,M). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension (4) */
+/* >          On entry ISEED specifies the seed of the random number */
+/* >          generator. The array elements should be between 0 and 4095; */
+/* >          if not they will be reduced mod 4096.  Also, ISEED(4) must */
+/* >          be odd.  The random number generator uses a linear */
+/* >          congruential sequence limited to small integers, and so */
+/* >          should produce machine independent random numbers. The */
+/* >          values of ISEED are changed on exit, and can be used in the */
+/* >          next call to SLAROR to continue the same random number */
+/* >          sequence. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] X */
+/* > \verbatim */
+/* >          X is REAL array, dimension (3*MAX( M, N )) */
+/* >          Workspace of length */
+/* >              2*M + N if SIDE = 'L', */
+/* >              2*N + M if SIDE = 'R', */
+/* >              3*N     if SIDE = 'C' or 'T'. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          An error flag.  It is set to: */
+/* >          = 0:  normal return */
+/* >          < 0:  if INFO = -k, the k-th argument had an illegal value */
+/* >          = 1:  if the random numbers generated by SLARND are bad. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup real_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int slaror_(char *side, char *init, integer *m, integer *n, 
+	real *a, integer *lda, integer *iseed, real *x, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+    real r__1;
+
+    /* Local variables */
+    integer kbeg, jcol;
+    extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, 
+	    integer *, real *, integer *, real *, integer *);
+    integer irow;
+    extern real snrm2_(integer *, real *, integer *);
+    integer j;
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), 
+	    sgemv_(char *, integer *, integer *, real *, real *, integer *, 
+	    real *, integer *, real *, real *, integer *);
+    integer ixfrm, itype, nxfrm;
+    real xnorm;
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    real factor;
+    extern real slarnd_(integer *, integer *);
+    extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *, 
+	    real *, real *, integer *);
+    real xnorms;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --iseed;
+    --x;
+
+    /* Function Body */
+    *info = 0;
+    if (*n == 0 || *m == 0) {
+	return 0;
+    }
+
+    itype = 0;
+    if (lsame_(side, "L")) {
+	itype = 1;
+    } else if (lsame_(side, "R")) {
+	itype = 2;
+    } else if (lsame_(side, "C") || lsame_(side, "T")) {
+	itype = 3;
+    }
+
+/*     Check for argument errors. */
+
+    if (itype == 0) {
+	*info = -1;
+    } else if (*m < 0) {
+	*info = -3;
+    } else if (*n < 0 || itype == 3 && *n != *m) {
+	*info = -4;
+    } else if (*lda < *m) {
+	*info = -6;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SLAROR", &i__1);
+	return 0;
+    }
+
+    if (itype == 1) {
+	nxfrm = *m;
+    } else {
+	nxfrm = *n;
+    }
+
+/*     Initialize A to the identity matrix if desired */
+
+    if (lsame_(init, "I")) {
+	slaset_("Full", m, n, &c_b9, &c_b10, &a[a_offset], lda);
+    }
+
+/*     If no rotation possible, multiply by random +/-1 */
+
+/*     Compute rotation by computing Householder transformations */
+/*     H(2), H(3), ..., H(nhouse) */
+
+    i__1 = nxfrm;
+    for (j = 1; j <= i__1; ++j) {
+	x[j] = 0.f;
+/* L10: */
+    }
+
+    i__1 = nxfrm;
+    for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) {
+	kbeg = nxfrm - ixfrm + 1;
+
+/*        Generate independent normal( 0, 1 ) random numbers */
+
+	i__2 = nxfrm;
+	for (j = kbeg; j <= i__2; ++j) {
+	    x[j] = slarnd_(&c__3, &iseed[1]);
+/* L20: */
+	}
+
+/*        Generate a Householder transformation from the random vector X */
+
+	xnorm = snrm2_(&ixfrm, &x[kbeg], &c__1);
+	xnorms = r_sign(&xnorm, &x[kbeg]);
+	r__1 = -x[kbeg];
+	x[kbeg + nxfrm] = r_sign(&c_b10, &r__1);
+	factor = xnorms * (xnorms + x[kbeg]);
+	if (abs(factor) < 1e-20f) {
+	    *info = 1;
+	    xerbla_("SLAROR", info);
+	    return 0;
+	} else {
+	    factor = 1.f / factor;
+	}
+	x[kbeg] += xnorms;
+
+/*        Apply Householder transformation to A */
+
+	if (itype == 1 || itype == 3) {
+
+/*           Apply H(k) from the left. */
+
+	    sgemv_("T", &ixfrm, n, &c_b10, &a[kbeg + a_dim1], lda, &x[kbeg], &
+		    c__1, &c_b9, &x[(nxfrm << 1) + 1], &c__1);
+	    r__1 = -factor;
+	    sger_(&ixfrm, n, &r__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], &
+		    c__1, &a[kbeg + a_dim1], lda);
+
+	}
+
+	if (itype == 2 || itype == 3) {
+
+/*           Apply H(k) from the right. */
+
+	    sgemv_("N", m, &ixfrm, &c_b10, &a[kbeg * a_dim1 + 1], lda, &x[
+		    kbeg], &c__1, &c_b9, &x[(nxfrm << 1) + 1], &c__1);
+	    r__1 = -factor;
+	    sger_(m, &ixfrm, &r__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], &
+		    c__1, &a[kbeg * a_dim1 + 1], lda);
+
+	}
+/* L30: */
+    }
+
+    r__1 = slarnd_(&c__3, &iseed[1]);
+    x[nxfrm * 2] = r_sign(&c_b10, &r__1);
+
+/*     Scale the matrix A by D. */
+
+    if (itype == 1 || itype == 3) {
+	i__1 = *m;
+	for (irow = 1; irow <= i__1; ++irow) {
+	    sscal_(n, &x[nxfrm + irow], &a[irow + a_dim1], lda);
+/* L40: */
+	}
+    }
+
+    if (itype == 2 || itype == 3) {
+	i__1 = *n;
+	for (jcol = 1; jcol <= i__1; ++jcol) {
+	    sscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1);
+/* L50: */
+	}
+    }
+    return 0;
+
+/*     End of SLAROR */
+
+} /* slaror_ */
+

lapack-netlib/TESTING/MATGEN/slarot.c

@@ -0,0 +1,709 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__4 = 4;
+static integer c__8 = 8;
+static integer c__1 = 1;
+
+/* > \brief \b SLAROT */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, */
+/*                          XRIGHT ) */
+
+/*       LOGICAL            LLEFT, LRIGHT, LROWS */
+/*       INTEGER            LDA, NL */
+/*       REAL               C, S, XLEFT, XRIGHT */
+/*       REAL               A( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* >    SLAROT applies a (Givens) rotation to two adjacent rows or */
+/* >    columns, where one element of the first and/or last column/row */
+/* >    for use on matrices stored in some format other than GE, so */
+/* >    that elements of the matrix may be used or modified for which */
+/* >    no array element is provided. */
+/* > */
+/* >    One example is a symmetric matrix in SB format (bandwidth=4), for */
+/* >    which UPLO='L':  Two adjacent rows will have the format: */
+/* > */
+/* >    row j:     C> C> C> C> C> .  .  .  . */
+/* >    row j+1:      C> C> C> C> C> .  .  .  . */
+/* > */
+/* >    '*' indicates elements for which storage is provided, */
+/* >    '.' indicates elements for which no storage is provided, but */
+/* >    are not necessarily zero; their values are determined by */
+/* >    symmetry.  ' ' indicates elements which are necessarily zero, */
+/* >     and have no storage provided. */
+/* > */
+/* >    Those columns which have two '*'s can be handled by SROT. */
+/* >    Those columns which have no '*'s can be ignored, since as long */
+/* >    as the Givens rotations are carefully applied to preserve */
+/* >    symmetry, their values are determined. */
+/* >    Those columns which have one '*' have to be handled separately, */
+/* >    by using separate variables "p" and "q": */
+/* > */
+/* >    row j:     C> C> C> C> C> p  .  .  . */
+/* >    row j+1:   q  C> C> C> C> C> .  .  .  . */
+/* > */
+/* >    The element p would have to be set correctly, then that column */
+/* >    is rotated, setting p to its new value.  The next call to */
+/* >    SLAROT would rotate columns j and j+1, using p, and restore */
+/* >    symmetry.  The element q would start out being zero, and be */
+/* >    made non-zero by the rotation.  Later, rotations would presumably */
+/* >    be chosen to zero q out. */
+/* > */
+/* >    Typical Calling Sequences: rotating the i-th and (i+1)-st rows. */
+/* >    ------- ------- --------- */
+/* > */
+/* >      General dense matrix: */
+/* > */
+/* >              CALL SLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S, */
+/* >                      A(i,1),LDA, DUMMY, DUMMY) */
+/* > */
+/* >      General banded matrix in GB format: */
+/* > */
+/* >              j = MAX(1, i-KL ) */
+/* >              NL = MIN( N, i+KU+1 ) + 1-j */
+/* >              CALL SLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S, */
+/* >                      A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT ) */
+/* > */
+/* >              [ note that i+1-j is just MIN(i,KL+1) ] */
+/* > */
+/* >      Symmetric banded matrix in SY format, bandwidth K, */
+/* >      lower triangle only: */
+/* > */
+/* >              j = MAX(1, i-K ) */
+/* >              NL = MIN( K+1, i ) + 1 */
+/* >              CALL SLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S, */
+/* >                      A(i,j), LDA, XLEFT, XRIGHT ) */
+/* > */
+/* >      Same, but upper triangle only: */
+/* > */
+/* >              NL = MIN( K+1, N-i ) + 1 */
+/* >              CALL SLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S, */
+/* >                      A(i,i), LDA, XLEFT, XRIGHT ) */
+/* > */
+/* >      Symmetric banded matrix in SB format, bandwidth K, */
+/* >      lower triangle only: */
+/* > */
+/* >              [ same as for SY, except:] */
+/* >                  . . . . */
+/* >                      A(i+1-j,j), LDA-1, XLEFT, XRIGHT ) */
+/* > */
+/* >              [ note that i+1-j is just MIN(i,K+1) ] */
+/* > */
+/* >      Same, but upper triangle only: */
+/* >                   . . . */
+/* >                      A(K+1,i), LDA-1, XLEFT, XRIGHT ) */
+/* > */
+/* >      Rotating columns is just the transpose of rotating rows, except */
+/* >      for GB and SB: (rotating columns i and i+1) */
+/* > */
+/* >      GB: */
+/* >              j = MAX(1, i-KU ) */
+/* >              NL = MIN( N, i+KL+1 ) + 1-j */
+/* >              CALL SLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S, */
+/* >                      A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM ) */
+/* > */
+/* >              [note that KU+j+1-i is just MAX(1,KU+2-i)] */
+/* > */
+/* >      SB: (upper triangle) */
+/* > */
+/* >                   . . . . . . */
+/* >                      A(K+j+1-i,i),LDA-1, XTOP, XBOTTM ) */
+/* > */
+/* >      SB: (lower triangle) */
+/* > */
+/* >                   . . . . . . */
+/* >                      A(1,i),LDA-1, XTOP, XBOTTM ) */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \verbatim */
+/* >  LROWS  - LOGICAL */
+/* >           If .TRUE., then SLAROT will rotate two rows.  If .FALSE., */
+/* >           then it will rotate two columns. */
+/* >           Not modified. */
+/* > */
+/* >  LLEFT  - LOGICAL */
+/* >           If .TRUE., then XLEFT will be used instead of the */
+/* >           corresponding element of A for the first element in the */
+/* >           second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) */
+/* >           If .FALSE., then the corresponding element of A will be */
+/* >           used. */
+/* >           Not modified. */
+/* > */
+/* >  LRIGHT - LOGICAL */
+/* >           If .TRUE., then XRIGHT will be used instead of the */
+/* >           corresponding element of A for the last element in the */
+/* >           first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If */
+/* >           .FALSE., then the corresponding element of A will be used. */
+/* >           Not modified. */
+/* > */
+/* >  NL     - INTEGER */
+/* >           The length of the rows (if LROWS=.TRUE.) or columns (if */
+/* >           LROWS=.FALSE.) to be rotated.  If XLEFT and/or XRIGHT are */
+/* >           used, the columns/rows they are in should be included in */
+/* >           NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at */
+/* >           least 2.  The number of rows/columns to be rotated */
+/* >           exclusive of those involving XLEFT and/or XRIGHT may */
+/* >           not be negative, i.e., NL minus how many of LLEFT and */
+/* >           LRIGHT are .TRUE. must be at least zero; if not, XERBLA */
+/* >           will be called. */
+/* >           Not modified. */
+/* > */
+/* >  C, S   - REAL */
+/* >           Specify the Givens rotation to be applied.  If LROWS is */
+/* >           true, then the matrix ( c  s ) */
+/* >                                 (-s  c )  is applied from the left; */
+/* >           if false, then the transpose thereof is applied from the */
+/* >           right.  For a Givens rotation, C**2 + S**2 should be 1, */
+/* >           but this is not checked. */
+/* >           Not modified. */
+/* > */
+/* >  A      - REAL array. */
+/* >           The array containing the rows/columns to be rotated.  The */
+/* >           first element of A should be the upper left element to */
+/* >           be rotated. */
+/* >           Read and modified. */
+/* > */
+/* >  LDA    - INTEGER */
+/* >           The "effective" leading dimension of A.  If A contains */
+/* >           a matrix stored in GE or SY format, then this is just */
+/* >           the leading dimension of A as dimensioned in the calling */
+/* >           routine.  If A contains a matrix stored in band (GB or SB) */
+/* >           format, then this should be *one less* than the leading */
+/* >           dimension used in the calling routine.  Thus, if */
+/* >           A were dimensioned A(LDA,*) in SLAROT, then A(1,j) would */
+/* >           be the j-th element in the first of the two rows */
+/* >           to be rotated, and A(2,j) would be the j-th in the second, */
+/* >           regardless of how the array may be stored in the calling */
+/* >           routine.  [A cannot, however, actually be dimensioned thus, */
+/* >           since for band format, the row number may exceed LDA, which */
+/* >           is not legal FORTRAN.] */
+/* >           If LROWS=.TRUE., then LDA must be at least 1, otherwise */
+/* >           it must be at least NL minus the number of .TRUE. values */
+/* >           in XLEFT and XRIGHT. */
+/* >           Not modified. */
+/* > */
+/* >  XLEFT  - REAL */
+/* >           If LLEFT is .TRUE., then XLEFT will be used and modified */
+/* >           instead of A(2,1) (if LROWS=.TRUE.) or A(1,2) */
+/* >           (if LROWS=.FALSE.). */
+/* >           Read and modified. */
+/* > */
+/* >  XRIGHT - REAL */
+/* >           If LRIGHT is .TRUE., then XRIGHT will be used and modified */
+/* >           instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1) */
+/* >           (if LROWS=.FALSE.). */
+/* >           Read and modified. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup real_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int slarot_(logical *lrows, logical *lleft, logical *lright, 
+	integer *nl, real *c__, real *s, real *a, integer *lda, real *xleft, 
+	real *xright)
+{
+    /* System generated locals */
+    integer i__1;
+
+    /* Local variables */
+    integer iinc;
+    extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, 
+	    integer *, real *, real *);
+    integer inext, ix, iy, nt;
+    real xt[2], yt[2];
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    integer iyt;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Set up indices, arrays for ends */
+
+    /* Parameter adjustments */
+    --a;
+
+    /* Function Body */
+    if (*lrows) {
+	iinc = *lda;
+	inext = 1;
+    } else {
+	iinc = 1;
+	inext = *lda;
+    }
+
+    if (*lleft) {
+	nt = 1;
+	ix = iinc + 1;
+	iy = *lda + 2;
+	xt[0] = a[1];
+	yt[0] = *xleft;
+    } else {
+	nt = 0;
+	ix = 1;
+	iy = inext + 1;
+    }
+
+    if (*lright) {
+	iyt = inext + 1 + (*nl - 1) * iinc;
+	++nt;
+	xt[nt - 1] = *xright;
+	yt[nt - 1] = a[iyt];
+    }
+
+/*     Check for errors */
+
+    if (*nl < nt) {
+	xerbla_("SLAROT", &c__4);
+	return 0;
+    }
+    if (*lda <= 0 || ! (*lrows) && *lda < *nl - nt) {
+	xerbla_("SLAROT", &c__8);
+	return 0;
+    }
+
+/*     Rotate */
+
+    i__1 = *nl - nt;
+    srot_(&i__1, &a[ix], &iinc, &a[iy], &iinc, c__, s);
+    srot_(&nt, xt, &c__1, yt, &c__1, c__, s);
+
+/*     Stuff values back into XLEFT, XRIGHT, etc. */
+
+    if (*lleft) {
+	a[1] = xt[0];
+	*xleft = yt[0];
+    }
+
+    if (*lright) {
+	*xright = xt[nt - 1];
+	a[iyt] = yt[nt - 1];
+    }
+
+    return 0;
+
+/*     End of SLAROT */
+
+} /* slarot_ */
+

lapack-netlib/TESTING/MATGEN/slatm1.c

@@ -0,0 +1,699 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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)
+*/
+
+
+
+/* > \brief \b SLATM1 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO ) */
+
+/*       INTEGER            IDIST, INFO, IRSIGN, MODE, N */
+/*       REAL               COND */
+/*       INTEGER            ISEED( 4 ) */
+/*       REAL               D( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* >    SLATM1 computes the entries of D(1..N) as specified by */
+/* >    MODE, COND and IRSIGN. IDIST and ISEED determine the generation */
+/* >    of random numbers. SLATM1 is called by SLATMR to generate */
+/* >    random test matrices for LAPACK programs. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] MODE */
+/* > \verbatim */
+/* >          MODE is INTEGER */
+/* >           On entry describes how D is to be computed: */
+/* >           MODE = 0 means do not change D. */
+/* >           MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
+/* >           MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
+/* >           MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
+/* >           MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* >           MODE = 5 sets D to random numbers in the range */
+/* >                    ( 1/COND , 1 ) such that their logarithms */
+/* >                    are uniformly distributed. */
+/* >           MODE = 6 set D to random numbers from same distribution */
+/* >                    as the rest of the matrix. */
+/* >           MODE < 0 has the same meaning as ABS(MODE), except that */
+/* >              the order of the elements of D is reversed. */
+/* >           Thus if MODE is positive, D has entries ranging from */
+/* >              1 to 1/COND, if negative, from 1/COND to 1, */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] COND */
+/* > \verbatim */
+/* >          COND is REAL */
+/* >           On entry, used as described under MODE above. */
+/* >           If used, it must be >= 1. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IRSIGN */
+/* > \verbatim */
+/* >          IRSIGN is INTEGER */
+/* >           On entry, if MODE neither -6, 0 nor 6, determines sign of */
+/* >           entries of D */
+/* >           0 => leave entries of D unchanged */
+/* >           1 => multiply each entry of D by 1 or -1 with probability .5 */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IDIST */
+/* > \verbatim */
+/* >          IDIST is INTEGER */
+/* >           On entry, IDIST specifies the type of distribution to be */
+/* >           used to generate a random matrix . */
+/* >           1 => UNIFORM( 0, 1 ) */
+/* >           2 => UNIFORM( -1, 1 ) */
+/* >           3 => NORMAL( 0, 1 ) */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension ( 4 ) */
+/* >           On entry ISEED specifies the seed of the random number */
+/* >           generator. The random number generator uses a */
+/* >           linear congruential sequence limited to small */
+/* >           integers, and so should produce machine independent */
+/* >           random numbers. The values of ISEED are changed on */
+/* >           exit, and can be used in the next call to SLATM1 */
+/* >           to continue the same random number sequence. */
+/* >           Changed on exit. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] D */
+/* > \verbatim */
+/* >          D is REAL array, dimension ( N ) */
+/* >           Array to be computed according to MODE, COND and IRSIGN. */
+/* >           May be changed on exit if MODE is nonzero. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >           Number of entries of D. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >            0  => normal termination */
+/* >           -1  => if MODE not in range -6 to 6 */
+/* >           -2  => if MODE neither -6, 0 nor 6, and */
+/* >                  IRSIGN neither 0 nor 1 */
+/* >           -3  => if MODE neither -6, 0 nor 6 and COND less than 1 */
+/* >           -4  => if MODE equals 6 or -6 and IDIST not in range 1 to 3 */
+/* >           -7  => if N negative */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup real_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int slatm1_(integer *mode, real *cond, integer *irsign, 
+	integer *idist, integer *iseed, real *d__, integer *n, integer *info)
+{
+    /* System generated locals */
+    integer i__1, i__2;
+    doublereal d__1, d__2;
+
+    /* Local variables */
+    real temp;
+    integer i__;
+    real alpha;
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    extern real slaran_(integer *);
+    extern /* Subroutine */ int slarnv_(integer *, integer *, 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Decode and Test the input parameters. Initialize flags & seed. */
+
+    /* Parameter adjustments */
+    --d__;
+    --iseed;
+
+    /* Function Body */
+    *info = 0;
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+/*     Set INFO if an error */
+
+    if (*mode < -6 || *mode > 6) {
+	*info = -1;
+    } else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && *
+	    irsign != 1)) {
+	*info = -2;
+    } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.f) {
+	*info = -3;
+    } else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 3)) {
+	*info = -4;
+    } else if (*n < 0) {
+	*info = -7;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SLATM1", &i__1);
+	return 0;
+    }
+
+/*     Compute D according to COND and MODE */
+
+    if (*mode != 0) {
+	switch (abs(*mode)) {
+	    case 1:  goto L10;
+	    case 2:  goto L30;
+	    case 3:  goto L50;
+	    case 4:  goto L70;
+	    case 5:  goto L90;
+	    case 6:  goto L110;
+	}
+
+/*        One large D value: */
+
+L10:
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    d__[i__] = 1.f / *cond;
+/* L20: */
+	}
+	d__[1] = 1.f;
+	goto L120;
+
+/*        One small D value: */
+
+L30:
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    d__[i__] = 1.f;
+/* L40: */
+	}
+	d__[*n] = 1.f / *cond;
+	goto L120;
+
+/*        Exponentially distributed D values: */
+
+L50:
+	d__[1] = 1.f;
+	if (*n > 1) {
+	    d__1 = (doublereal) (*cond);
+	    d__2 = (doublereal) (-1.f / (real) (*n - 1));
+	    alpha = pow_dd(&d__1, &d__2);
+	    i__1 = *n;
+	    for (i__ = 2; i__ <= i__1; ++i__) {
+		i__2 = i__ - 1;
+		d__[i__] = pow_ri(&alpha, &i__2);
+/* L60: */
+	    }
+	}
+	goto L120;
+
+/*        Arithmetically distributed D values: */
+
+L70:
+	d__[1] = 1.f;
+	if (*n > 1) {
+	    temp = 1.f / *cond;
+	    alpha = (1.f - temp) / (real) (*n - 1);
+	    i__1 = *n;
+	    for (i__ = 2; i__ <= i__1; ++i__) {
+		d__[i__] = (real) (*n - i__) * alpha + temp;
+/* L80: */
+	    }
+	}
+	goto L120;
+
+/*        Randomly distributed D values on ( 1/COND , 1): */
+
+L90:
+	alpha = log(1.f / *cond);
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    d__[i__] = exp(alpha * slaran_(&iseed[1]));
+/* L100: */
+	}
+	goto L120;
+
+/*        Randomly distributed D values from IDIST */
+
+L110:
+	slarnv_(idist, &iseed[1], n, &d__[1]);
+
+L120:
+
+/*        If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */
+/*        random signs to D */
+
+	if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) {
+	    i__1 = *n;
+	    for (i__ = 1; i__ <= i__1; ++i__) {
+		temp = slaran_(&iseed[1]);
+		if (temp > .5f) {
+		    d__[i__] = -d__[i__];
+		}
+/* L130: */
+	    }
+	}
+
+/*        Reverse if MODE < 0 */
+
+	if (*mode < 0) {
+	    i__1 = *n / 2;
+	    for (i__ = 1; i__ <= i__1; ++i__) {
+		temp = d__[i__];
+		d__[i__] = d__[*n + 1 - i__];
+		d__[*n + 1 - i__] = temp;
+/* L140: */
+	    }
+	}
+
+    }
+
+    return 0;
+
+/*     End of SLATM1 */
+
+} /* slatm1_ */
+

lapack-netlib/TESTING/MATGEN/slatm2.c

@@ -0,0 +1,698 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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)
+*/
+
+
+
+/* > \brief \b SLATM2 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       REAL             FUNCTION SLATM2( M, N, I, J, KL, KU, IDIST, */
+/*                        ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) */
+
+
+/*       INTEGER            I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N */
+/*       REAL               SPARSE */
+
+
+/*       INTEGER            ISEED( 4 ), IWORK( * ) */
+/*       REAL               D( * ), DL( * ), DR( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* >    SLATM2 returns the (I,J) entry of a random matrix of dimension */
+/* >    (M, N) described by the other parameters. It is called by the */
+/* >    SLATMR routine in order to build random test matrices. No error */
+/* >    checking on parameters is done, because this routine is called in */
+/* >    a tight loop by SLATMR which has already checked the parameters. */
+/* > */
+/* >    Use of SLATM2 differs from SLATM3 in the order in which the random */
+/* >    number generator is called to fill in random matrix entries. */
+/* >    With SLATM2, the generator is called to fill in the pivoted matrix */
+/* >    columnwise. With SLATM3, the generator is called to fill in the */
+/* >    matrix columnwise, after which it is pivoted. Thus, SLATM3 can */
+/* >    be used to construct random matrices which differ only in their */
+/* >    order of rows and/or columns. SLATM2 is used to construct band */
+/* >    matrices while avoiding calling the random number generator for */
+/* >    entries outside the band (and therefore generating random numbers */
+/* > */
+/* >    The matrix whose (I,J) entry is returned is constructed as */
+/* >    follows (this routine only computes one entry): */
+/* > */
+/* >      If I is outside (1..M) or J is outside (1..N), return zero */
+/* >         (this is convenient for generating matrices in band format). */
+/* > */
+/* >      Generate a matrix A with random entries of distribution IDIST. */
+/* > */
+/* >      Set the diagonal to D. */
+/* > */
+/* >      Grade the matrix, if desired, from the left (by DL) and/or */
+/* >         from the right (by DR or DL) as specified by IGRADE. */
+/* > */
+/* >      Permute, if desired, the rows and/or columns as specified by */
+/* >         IPVTNG and IWORK. */
+/* > */
+/* >      Band the matrix to have lower bandwidth KL and upper */
+/* >         bandwidth KU. */
+/* > */
+/* >      Set random entries to zero as specified by SPARSE. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >           Number of rows of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >           Number of columns of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] I */
+/* > \verbatim */
+/* >          I is INTEGER */
+/* >           Row of entry to be returned. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] J */
+/* > \verbatim */
+/* >          J is INTEGER */
+/* >           Column of entry to be returned. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KL */
+/* > \verbatim */
+/* >          KL is INTEGER */
+/* >           Lower bandwidth. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KU */
+/* > \verbatim */
+/* >          KU is INTEGER */
+/* >           Upper bandwidth. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IDIST */
+/* > \verbatim */
+/* >          IDIST is INTEGER */
+/* >           On entry, IDIST specifies the type of distribution to be */
+/* >           used to generate a random matrix . */
+/* >           1 => UNIFORM( 0, 1 ) */
+/* >           2 => UNIFORM( -1, 1 ) */
+/* >           3 => NORMAL( 0, 1 ) */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array of dimension ( 4 ) */
+/* >           Seed for random number generator. */
+/* >           Changed on exit. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is REAL array of dimension ( MIN( I , J ) ) */
+/* >           Diagonal entries of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IGRADE */
+/* > \verbatim */
+/* >          IGRADE is INTEGER */
+/* >           Specifies grading of matrix as follows: */
+/* >           0  => no grading */
+/* >           1  => matrix premultiplied by diag( DL ) */
+/* >           2  => matrix postmultiplied by diag( DR ) */
+/* >           3  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by diag( DR ) */
+/* >           4  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by inv( diag( DL ) ) */
+/* >           5  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by diag( DL ) */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] DL */
+/* > \verbatim */
+/* >          DL is REAL array ( I or J, as appropriate ) */
+/* >           Left scale factors for grading matrix.  Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] DR */
+/* > \verbatim */
+/* >          DR is REAL array ( I or J, as appropriate ) */
+/* >           Right scale factors for grading matrix.  Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPVTNG */
+/* > \verbatim */
+/* >          IPVTNG is INTEGER */
+/* >           On entry specifies pivoting permutations as follows: */
+/* >           0 => none. */
+/* >           1 => row pivoting. */
+/* >           2 => column pivoting. */
+/* >           3 => full pivoting, i.e., on both sides. */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array ( I or J, as appropriate ) */
+/* >           This array specifies the permutation used. The */
+/* >           row (or column) in position K was originally in */
+/* >           position IWORK( K ). */
+/* >           This differs from IWORK for SLATM3. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] SPARSE */
+/* > \verbatim */
+/* >          SPARSE is REAL between 0. and 1. */
+/* >           On entry specifies the sparsity of the matrix */
+/* >           if sparse matrix is to be generated. */
+/* >           SPARSE should lie between 0 and 1. */
+/* >           A uniform ( 0, 1 ) random number x is generated and */
+/* >           compared to SPARSE; if x is larger the matrix entry */
+/* >           is unchanged and if x is smaller the entry is set */
+/* >           to zero. Thus on the average a fraction SPARSE of the */
+/* >           entries will be set to zero. */
+/* >           Not modified. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date June 2016 */
+
+/* > \ingroup real_matgen */
+
+/*  ===================================================================== */
+real slatm2_(integer *m, integer *n, integer *i__, integer *j, integer *kl, 
+	integer *ku, integer *idist, integer *iseed, real *d__, integer *
+	igrade, real *dl, real *dr, integer *ipvtng, integer *iwork, real *
+	sparse)
+{
+    /* System generated locals */
+    real ret_val;
+
+    /* Local variables */
+    integer isub, jsub;
+    real temp;
+    extern real slaran_(integer *), slarnd_(integer *, 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..-- */
+/*     June 2016 */
+
+
+
+
+
+/*  ===================================================================== */
+
+
+
+
+
+
+
+/* ----------------------------------------------------------------------- */
+
+
+
+/*     Check for I and J in range */
+
+    /* Parameter adjustments */
+    --iwork;
+    --dr;
+    --dl;
+    --d__;
+    --iseed;
+
+    /* Function Body */
+    if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) {
+	ret_val = 0.f;
+	return ret_val;
+    }
+
+/*     Check for banding */
+
+    if (*j > *i__ + *ku || *j < *i__ - *kl) {
+	ret_val = 0.f;
+	return ret_val;
+    }
+
+/*     Check for sparsity */
+
+    if (*sparse > 0.f) {
+	if (slaran_(&iseed[1]) < *sparse) {
+	    ret_val = 0.f;
+	    return ret_val;
+	}
+    }
+
+/*     Compute subscripts depending on IPVTNG */
+
+    if (*ipvtng == 0) {
+	isub = *i__;
+	jsub = *j;
+    } else if (*ipvtng == 1) {
+	isub = iwork[*i__];
+	jsub = *j;
+    } else if (*ipvtng == 2) {
+	isub = *i__;
+	jsub = iwork[*j];
+    } else if (*ipvtng == 3) {
+	isub = iwork[*i__];
+	jsub = iwork[*j];
+    }
+
+/*     Compute entry and grade it according to IGRADE */
+
+    if (isub == jsub) {
+	temp = d__[isub];
+    } else {
+	temp = slarnd_(idist, &iseed[1]);
+    }
+    if (*igrade == 1) {
+	temp *= dl[isub];
+    } else if (*igrade == 2) {
+	temp *= dr[jsub];
+    } else if (*igrade == 3) {
+	temp = temp * dl[isub] * dr[jsub];
+    } else if (*igrade == 4 && isub != jsub) {
+	temp = temp * dl[isub] / dl[jsub];
+    } else if (*igrade == 5) {
+	temp = temp * dl[isub] * dl[jsub];
+    }
+    ret_val = temp;
+    return ret_val;
+
+/*     End of SLATM2 */
+
+} /* slatm2_ */
+

lapack-netlib/TESTING/MATGEN/slatm3.c

@@ -0,0 +1,716 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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)
+*/
+
+
+
+/* > \brief \b SLATM3 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       REAL             FUNCTION SLATM3( M, N, I, J, ISUB, JSUB, KL, KU, */
+/*                        IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, */
+/*                        SPARSE ) */
+
+
+/*       INTEGER            I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL, */
+/*      $                   KU, M, N */
+/*       REAL               SPARSE */
+
+
+/*       INTEGER            ISEED( 4 ), IWORK( * ) */
+/*       REAL               D( * ), DL( * ), DR( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* >    SLATM3 returns the (ISUB,JSUB) entry of a random matrix of */
+/* >    dimension (M, N) described by the other parameters. (ISUB,JSUB) */
+/* >    is the final position of the (I,J) entry after pivoting */
+/* >    according to IPVTNG and IWORK. SLATM3 is called by the */
+/* >    SLATMR routine in order to build random test matrices. No error */
+/* >    checking on parameters is done, because this routine is called in */
+/* >    a tight loop by SLATMR which has already checked the parameters. */
+/* > */
+/* >    Use of SLATM3 differs from SLATM2 in the order in which the random */
+/* >    number generator is called to fill in random matrix entries. */
+/* >    With SLATM2, the generator is called to fill in the pivoted matrix */
+/* >    columnwise. With SLATM3, the generator is called to fill in the */
+/* >    matrix columnwise, after which it is pivoted. Thus, SLATM3 can */
+/* >    be used to construct random matrices which differ only in their */
+/* >    order of rows and/or columns. SLATM2 is used to construct band */
+/* >    matrices while avoiding calling the random number generator for */
+/* >    entries outside the band (and therefore generating random numbers */
+/* >    in different orders for different pivot orders). */
+/* > */
+/* >    The matrix whose (ISUB,JSUB) entry is returned is constructed as */
+/* >    follows (this routine only computes one entry): */
+/* > */
+/* >      If ISUB is outside (1..M) or JSUB is outside (1..N), return zero */
+/* >         (this is convenient for generating matrices in band format). */
+/* > */
+/* >      Generate a matrix A with random entries of distribution IDIST. */
+/* > */
+/* >      Set the diagonal to D. */
+/* > */
+/* >      Grade the matrix, if desired, from the left (by DL) and/or */
+/* >         from the right (by DR or DL) as specified by IGRADE. */
+/* > */
+/* >      Permute, if desired, the rows and/or columns as specified by */
+/* >         IPVTNG and IWORK. */
+/* > */
+/* >      Band the matrix to have lower bandwidth KL and upper */
+/* >         bandwidth KU. */
+/* > */
+/* >      Set random entries to zero as specified by SPARSE. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >           Number of rows of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >           Number of columns of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] I */
+/* > \verbatim */
+/* >          I is INTEGER */
+/* >           Row of unpivoted entry to be returned. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] J */
+/* > \verbatim */
+/* >          J is INTEGER */
+/* >           Column of unpivoted entry to be returned. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISUB */
+/* > \verbatim */
+/* >          ISUB is INTEGER */
+/* >           Row of pivoted entry to be returned. Changed on exit. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] JSUB */
+/* > \verbatim */
+/* >          JSUB is INTEGER */
+/* >           Column of pivoted entry to be returned. Changed on exit. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KL */
+/* > \verbatim */
+/* >          KL is INTEGER */
+/* >           Lower bandwidth. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KU */
+/* > \verbatim */
+/* >          KU is INTEGER */
+/* >           Upper bandwidth. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IDIST */
+/* > \verbatim */
+/* >          IDIST is INTEGER */
+/* >           On entry, IDIST specifies the type of distribution to be */
+/* >           used to generate a random matrix . */
+/* >           1 => UNIFORM( 0, 1 ) */
+/* >           2 => UNIFORM( -1, 1 ) */
+/* >           3 => NORMAL( 0, 1 ) */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array of dimension ( 4 ) */
+/* >           Seed for random number generator. */
+/* >           Changed on exit. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is REAL array of dimension ( MIN( I , J ) ) */
+/* >           Diagonal entries of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IGRADE */
+/* > \verbatim */
+/* >          IGRADE is INTEGER */
+/* >           Specifies grading of matrix as follows: */
+/* >           0  => no grading */
+/* >           1  => matrix premultiplied by diag( DL ) */
+/* >           2  => matrix postmultiplied by diag( DR ) */
+/* >           3  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by diag( DR ) */
+/* >           4  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by inv( diag( DL ) ) */
+/* >           5  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by diag( DL ) */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] DL */
+/* > \verbatim */
+/* >          DL is REAL array ( I or J, as appropriate ) */
+/* >           Left scale factors for grading matrix.  Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] DR */
+/* > \verbatim */
+/* >          DR is REAL array ( I or J, as appropriate ) */
+/* >           Right scale factors for grading matrix.  Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPVTNG */
+/* > \verbatim */
+/* >          IPVTNG is INTEGER */
+/* >           On entry specifies pivoting permutations as follows: */
+/* >           0 => none. */
+/* >           1 => row pivoting. */
+/* >           2 => column pivoting. */
+/* >           3 => full pivoting, i.e., on both sides. */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array ( I or J, as appropriate ) */
+/* >           This array specifies the permutation used. The */
+/* >           row (or column) originally in position K is in */
+/* >           position IWORK( K ) after pivoting. */
+/* >           This differs from IWORK for SLATM2. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] SPARSE */
+/* > \verbatim */
+/* >          SPARSE is REAL between 0. and 1. */
+/* >           On entry specifies the sparsity of the matrix */
+/* >           if sparse matrix is to be generated. */
+/* >           SPARSE should lie between 0 and 1. */
+/* >           A uniform ( 0, 1 ) random number x is generated and */
+/* >           compared to SPARSE; if x is larger the matrix entry */
+/* >           is unchanged and if x is smaller the entry is set */
+/* >           to zero. Thus on the average a fraction SPARSE of the */
+/* >           entries will be set to zero. */
+/* >           Not modified. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date June 2016 */
+
+/* > \ingroup real_matgen */
+
+/*  ===================================================================== */
+real slatm3_(integer *m, integer *n, integer *i__, integer *j, integer *isub, 
+	integer *jsub, integer *kl, integer *ku, integer *idist, integer *
+	iseed, real *d__, integer *igrade, real *dl, real *dr, integer *
+	ipvtng, integer *iwork, real *sparse)
+{
+    /* System generated locals */
+    real ret_val;
+
+    /* Local variables */
+    real temp;
+    extern real slaran_(integer *), slarnd_(integer *, 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..-- */
+/*     June 2016 */
+
+
+
+
+
+/*  ===================================================================== */
+
+
+
+
+
+
+
+/* ----------------------------------------------------------------------- */
+
+
+
+/*     Check for I and J in range */
+
+    /* Parameter adjustments */
+    --iwork;
+    --dr;
+    --dl;
+    --d__;
+    --iseed;
+
+    /* Function Body */
+    if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) {
+	*isub = *i__;
+	*jsub = *j;
+	ret_val = 0.f;
+	return ret_val;
+    }
+
+/*     Compute subscripts depending on IPVTNG */
+
+    if (*ipvtng == 0) {
+	*isub = *i__;
+	*jsub = *j;
+    } else if (*ipvtng == 1) {
+	*isub = iwork[*i__];
+	*jsub = *j;
+    } else if (*ipvtng == 2) {
+	*isub = *i__;
+	*jsub = iwork[*j];
+    } else if (*ipvtng == 3) {
+	*isub = iwork[*i__];
+	*jsub = iwork[*j];
+    }
+
+/*     Check for banding */
+
+    if (*jsub > *isub + *ku || *jsub < *isub - *kl) {
+	ret_val = 0.f;
+	return ret_val;
+    }
+
+/*     Check for sparsity */
+
+    if (*sparse > 0.f) {
+	if (slaran_(&iseed[1]) < *sparse) {
+	    ret_val = 0.f;
+	    return ret_val;
+	}
+    }
+
+/*     Compute entry and grade it according to IGRADE */
+
+    if (*i__ == *j) {
+	temp = d__[*i__];
+    } else {
+	temp = slarnd_(idist, &iseed[1]);
+    }
+    if (*igrade == 1) {
+	temp *= dl[*i__];
+    } else if (*igrade == 2) {
+	temp *= dr[*j];
+    } else if (*igrade == 3) {
+	temp = temp * dl[*i__] * dr[*j];
+    } else if (*igrade == 4 && *i__ != *j) {
+	temp = temp * dl[*i__] / dl[*j];
+    } else if (*igrade == 5) {
+	temp = temp * dl[*i__] * dl[*j];
+    }
+    ret_val = temp;
+    return ret_val;
+
+/*     End of SLATM3 */
+
+} /* slatm3_ */
+

lapack-netlib/TESTING/MATGEN/slatm5.c

@@ -0,0 +1,972 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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_b29 = 1.f;
+static real c_b30 = 0.f;
+static real c_b33 = -1.f;
+
+/* > \brief \b SLATM5 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SLATM5( PRTYPE, M, N, A, LDA, B, LDB, C, LDC, D, LDD, */
+/*                          E, LDE, F, LDF, R, LDR, L, LDL, ALPHA, QBLCKA, */
+/*                          QBLCKB ) */
+
+/*       INTEGER            LDA, LDB, LDC, LDD, LDE, LDF, LDL, LDR, M, N, */
+/*      $                   PRTYPE, QBLCKA, QBLCKB */
+/*       REAL               ALPHA */
+/*       REAL               A( LDA, * ), B( LDB, * ), C( LDC, * ), */
+/*      $                   D( LDD, * ), E( LDE, * ), F( LDF, * ), */
+/*      $                   L( LDL, * ), R( LDR, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SLATM5 generates matrices involved in the Generalized Sylvester */
+/* > equation: */
+/* > */
+/* >     A * R - L * B = C */
+/* >     D * R - L * E = F */
+/* > */
+/* > They also satisfy (the diagonalization condition) */
+/* > */
+/* >  [ I -L ] ( [ A  -C ], [ D -F ] ) [ I  R ] = ( [ A    ], [ D    ] ) */
+/* >  [    I ] ( [     B ]  [    E ] ) [    I ]   ( [    B ]  [    E ] ) */
+/* > */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] PRTYPE */
+/* > \verbatim */
+/* >          PRTYPE is INTEGER */
+/* >          "Points" to a certain type of the matrices to generate */
+/* >          (see further details). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          Specifies the order of A and D and the number of rows in */
+/* >          C, F,  R and L. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          Specifies the order of B and E and the number of columns in */
+/* >          C, F, R and L. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA, M). */
+/* >          On exit A M-by-M is initialized according to PRTYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB, N). */
+/* >          On exit B N-by-N is initialized according to PRTYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of B. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] C */
+/* > \verbatim */
+/* >          C is REAL array, dimension (LDC, N). */
+/* >          On exit C M-by-N is initialized according to PRTYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDC */
+/* > \verbatim */
+/* >          LDC is INTEGER */
+/* >          The leading dimension of C. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] D */
+/* > \verbatim */
+/* >          D is REAL array, dimension (LDD, M). */
+/* >          On exit D M-by-M is initialized according to PRTYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDD */
+/* > \verbatim */
+/* >          LDD is INTEGER */
+/* >          The leading dimension of D. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] E */
+/* > \verbatim */
+/* >          E is REAL array, dimension (LDE, N). */
+/* >          On exit E N-by-N is initialized according to PRTYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDE */
+/* > \verbatim */
+/* >          LDE is INTEGER */
+/* >          The leading dimension of E. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] F */
+/* > \verbatim */
+/* >          F is REAL array, dimension (LDF, N). */
+/* >          On exit F M-by-N is initialized according to PRTYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDF */
+/* > \verbatim */
+/* >          LDF is INTEGER */
+/* >          The leading dimension of F. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] R */
+/* > \verbatim */
+/* >          R is REAL array, dimension (LDR, N). */
+/* >          On exit R M-by-N is initialized according to PRTYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDR */
+/* > \verbatim */
+/* >          LDR is INTEGER */
+/* >          The leading dimension of R. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] L */
+/* > \verbatim */
+/* >          L is REAL array, dimension (LDL, N). */
+/* >          On exit L M-by-N is initialized according to PRTYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDL */
+/* > \verbatim */
+/* >          LDL is INTEGER */
+/* >          The leading dimension of L. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] ALPHA */
+/* > \verbatim */
+/* >          ALPHA is REAL */
+/* >          Parameter used in generating PRTYPE = 1 and 5 matrices. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] QBLCKA */
+/* > \verbatim */
+/* >          QBLCKA is INTEGER */
+/* >          When PRTYPE = 3, specifies the distance between 2-by-2 */
+/* >          blocks on the diagonal in A. Otherwise, QBLCKA is not */
+/* >          referenced. QBLCKA > 1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] QBLCKB */
+/* > \verbatim */
+/* >          QBLCKB is INTEGER */
+/* >          When PRTYPE = 3, specifies the distance between 2-by-2 */
+/* >          blocks on the diagonal in B. Otherwise, QBLCKB is not */
+/* >          referenced. QBLCKB > 1. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date June 2016 */
+
+/* > \ingroup real_matgen */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  PRTYPE = 1: A and B are Jordan blocks, D and E are identity matrices */
+/* > */
+/* >             A : if (i == j) then A(i, j) = 1.0 */
+/* >                 if (j == i + 1) then A(i, j) = -1.0 */
+/* >                 else A(i, j) = 0.0,            i, j = 1...M */
+/* > */
+/* >             B : if (i == j) then B(i, j) = 1.0 - ALPHA */
+/* >                 if (j == i + 1) then B(i, j) = 1.0 */
+/* >                 else B(i, j) = 0.0,            i, j = 1...N */
+/* > */
+/* >             D : if (i == j) then D(i, j) = 1.0 */
+/* >                 else D(i, j) = 0.0,            i, j = 1...M */
+/* > */
+/* >             E : if (i == j) then E(i, j) = 1.0 */
+/* >                 else E(i, j) = 0.0,            i, j = 1...N */
+/* > */
+/* >             L =  R are chosen from [-10...10], */
+/* >                  which specifies the right hand sides (C, F). */
+/* > */
+/* >  PRTYPE = 2 or 3: Triangular and/or quasi- triangular. */
+/* > */
+/* >             A : if (i <= j) then A(i, j) = [-1...1] */
+/* >                 else A(i, j) = 0.0,             i, j = 1...M */
+/* > */
+/* >                 if (PRTYPE = 3) then */
+/* >                    A(k + 1, k + 1) = A(k, k) */
+/* >                    A(k + 1, k) = [-1...1] */
+/* >                    sign(A(k, k + 1) = -(sin(A(k + 1, k)) */
+/* >                        k = 1, M - 1, QBLCKA */
+/* > */
+/* >             B : if (i <= j) then B(i, j) = [-1...1] */
+/* >                 else B(i, j) = 0.0,            i, j = 1...N */
+/* > */
+/* >                 if (PRTYPE = 3) then */
+/* >                    B(k + 1, k + 1) = B(k, k) */
+/* >                    B(k + 1, k) = [-1...1] */
+/* >                    sign(B(k, k + 1) = -(sign(B(k + 1, k)) */
+/* >                        k = 1, N - 1, QBLCKB */
+/* > */
+/* >             D : if (i <= j) then D(i, j) = [-1...1]. */
+/* >                 else D(i, j) = 0.0,            i, j = 1...M */
+/* > */
+/* > */
+/* >             E : if (i <= j) then D(i, j) = [-1...1] */
+/* >                 else E(i, j) = 0.0,            i, j = 1...N */
+/* > */
+/* >                 L, R are chosen from [-10...10], */
+/* >                 which specifies the right hand sides (C, F). */
+/* > */
+/* >  PRTYPE = 4 Full */
+/* >             A(i, j) = [-10...10] */
+/* >             D(i, j) = [-1...1]    i,j = 1...M */
+/* >             B(i, j) = [-10...10] */
+/* >             E(i, j) = [-1...1]    i,j = 1...N */
+/* >             R(i, j) = [-10...10] */
+/* >             L(i, j) = [-1...1]    i = 1..M ,j = 1...N */
+/* > */
+/* >             L, R specifies the right hand sides (C, F). */
+/* > */
+/* >  PRTYPE = 5 special case common and/or close eigs. */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int slatm5_(integer *prtype, integer *m, integer *n, real *a,
+	 integer *lda, real *b, integer *ldb, real *c__, integer *ldc, real *
+	d__, integer *ldd, real *e, integer *lde, real *f, integer *ldf, real 
+	*r__, integer *ldr, real *l, integer *ldl, real *alpha, integer *
+	qblcka, integer *qblckb)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1, 
+	    d_offset, e_dim1, e_offset, f_dim1, f_offset, l_dim1, l_offset, 
+	    r_dim1, r_offset, i__1, i__2;
+
+    /* Local variables */
+    integer i__, j, k;
+    extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, 
+	    integer *, real *, real *, integer *, real *, integer *, real *, 
+	    real *, integer *);
+    real imeps, reeps;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     June 2016 */
+
+
+/*  ===================================================================== */
+
+
+    /* 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;
+    c_dim1 = *ldc;
+    c_offset = 1 + c_dim1 * 1;
+    c__ -= c_offset;
+    d_dim1 = *ldd;
+    d_offset = 1 + d_dim1 * 1;
+    d__ -= d_offset;
+    e_dim1 = *lde;
+    e_offset = 1 + e_dim1 * 1;
+    e -= e_offset;
+    f_dim1 = *ldf;
+    f_offset = 1 + f_dim1 * 1;
+    f -= f_offset;
+    r_dim1 = *ldr;
+    r_offset = 1 + r_dim1 * 1;
+    r__ -= r_offset;
+    l_dim1 = *ldl;
+    l_offset = 1 + l_dim1 * 1;
+    l -= l_offset;
+
+    /* Function Body */
+    if (*prtype == 1) {
+	i__1 = *m;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *m;
+	    for (j = 1; j <= i__2; ++j) {
+		if (i__ == j) {
+		    a[i__ + j * a_dim1] = 1.f;
+		    d__[i__ + j * d_dim1] = 1.f;
+		} else if (i__ == j - 1) {
+		    a[i__ + j * a_dim1] = -1.f;
+		    d__[i__ + j * d_dim1] = 0.f;
+		} else {
+		    a[i__ + j * a_dim1] = 0.f;
+		    d__[i__ + j * d_dim1] = 0.f;
+		}
+/* L10: */
+	    }
+/* L20: */
+	}
+
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *n;
+	    for (j = 1; j <= i__2; ++j) {
+		if (i__ == j) {
+		    b[i__ + j * b_dim1] = 1.f - *alpha;
+		    e[i__ + j * e_dim1] = 1.f;
+		} else if (i__ == j - 1) {
+		    b[i__ + j * b_dim1] = 1.f;
+		    e[i__ + j * e_dim1] = 0.f;
+		} else {
+		    b[i__ + j * b_dim1] = 0.f;
+		    e[i__ + j * e_dim1] = 0.f;
+		}
+/* L30: */
+	    }
+/* L40: */
+	}
+
+	i__1 = *m;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *n;
+	    for (j = 1; j <= i__2; ++j) {
+		r__[i__ + j * r_dim1] = (.5f - sin((real) (i__ / j))) * 20.f;
+		l[i__ + j * l_dim1] = r__[i__ + j * r_dim1];
+/* L50: */
+	    }
+/* L60: */
+	}
+
+    } else if (*prtype == 2 || *prtype == 3) {
+	i__1 = *m;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *m;
+	    for (j = 1; j <= i__2; ++j) {
+		if (i__ <= j) {
+		    a[i__ + j * a_dim1] = (.5f - sin((real) i__)) * 2.f;
+		    d__[i__ + j * d_dim1] = (.5f - sin((real) (i__ * j))) * 
+			    2.f;
+		} else {
+		    a[i__ + j * a_dim1] = 0.f;
+		    d__[i__ + j * d_dim1] = 0.f;
+		}
+/* L70: */
+	    }
+/* L80: */
+	}
+
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *n;
+	    for (j = 1; j <= i__2; ++j) {
+		if (i__ <= j) {
+		    b[i__ + j * b_dim1] = (.5f - sin((real) (i__ + j))) * 2.f;
+		    e[i__ + j * e_dim1] = (.5f - sin((real) j)) * 2.f;
+		} else {
+		    b[i__ + j * b_dim1] = 0.f;
+		    e[i__ + j * e_dim1] = 0.f;
+		}
+/* L90: */
+	    }
+/* L100: */
+	}
+
+	i__1 = *m;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *n;
+	    for (j = 1; j <= i__2; ++j) {
+		r__[i__ + j * r_dim1] = (.5f - sin((real) (i__ * j))) * 20.f;
+		l[i__ + j * l_dim1] = (.5f - sin((real) (i__ + j))) * 20.f;
+/* L110: */
+	    }
+/* L120: */
+	}
+
+	if (*prtype == 3) {
+	    if (*qblcka <= 1) {
+		*qblcka = 2;
+	    }
+	    i__1 = *m - 1;
+	    i__2 = *qblcka;
+	    for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+		a[k + 1 + (k + 1) * a_dim1] = a[k + k * a_dim1];
+		a[k + 1 + k * a_dim1] = -sin(a[k + (k + 1) * a_dim1]);
+/* L130: */
+	    }
+
+	    if (*qblckb <= 1) {
+		*qblckb = 2;
+	    }
+	    i__2 = *n - 1;
+	    i__1 = *qblckb;
+	    for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+		b[k + 1 + (k + 1) * b_dim1] = b[k + k * b_dim1];
+		b[k + 1 + k * b_dim1] = -sin(b[k + (k + 1) * b_dim1]);
+/* L140: */
+	    }
+	}
+
+    } else if (*prtype == 4) {
+	i__1 = *m;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *m;
+	    for (j = 1; j <= i__2; ++j) {
+		a[i__ + j * a_dim1] = (.5f - sin((real) (i__ * j))) * 20.f;
+		d__[i__ + j * d_dim1] = (.5f - sin((real) (i__ + j))) * 2.f;
+/* L150: */
+	    }
+/* L160: */
+	}
+
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *n;
+	    for (j = 1; j <= i__2; ++j) {
+		b[i__ + j * b_dim1] = (.5f - sin((real) (i__ + j))) * 20.f;
+		e[i__ + j * e_dim1] = (.5f - sin((real) (i__ * j))) * 2.f;
+/* L170: */
+	    }
+/* L180: */
+	}
+
+	i__1 = *m;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *n;
+	    for (j = 1; j <= i__2; ++j) {
+		r__[i__ + j * r_dim1] = (.5f - sin((real) (j / i__))) * 20.f;
+		l[i__ + j * l_dim1] = (.5f - sin((real) (i__ * j))) * 2.f;
+/* L190: */
+	    }
+/* L200: */
+	}
+
+    } else if (*prtype >= 5) {
+	reeps = 20.f / *alpha;
+	imeps = -1.5f / *alpha;
+	i__1 = *m;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = *n;
+	    for (j = 1; j <= i__2; ++j) {
+		r__[i__ + j * r_dim1] = (.5f - sin((real) (i__ * j))) * *
+			alpha / 20.f;
+		l[i__ + j * l_dim1] = (.5f - sin((real) (i__ + j))) * *alpha /
+			 20.f;
+/* L210: */
+	    }
+/* L220: */
+	}
+
+	i__1 = *m;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    d__[i__ + i__ * d_dim1] = 1.f;
+/* L230: */
+	}
+
+	i__1 = *m;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    if (i__ <= 4) {
+		a[i__ + i__ * a_dim1] = 1.f;
+		if (i__ > 2) {
+		    a[i__ + i__ * a_dim1] = reeps + 1.f;
+		}
+		if (i__ % 2 != 0 && i__ < *m) {
+		    a[i__ + (i__ + 1) * a_dim1] = imeps;
+		} else if (i__ > 1) {
+		    a[i__ + (i__ - 1) * a_dim1] = -imeps;
+		}
+	    } else if (i__ <= 8) {
+		if (i__ <= 6) {
+		    a[i__ + i__ * a_dim1] = reeps;
+		} else {
+		    a[i__ + i__ * a_dim1] = -reeps;
+		}
+		if (i__ % 2 != 0 && i__ < *m) {
+		    a[i__ + (i__ + 1) * a_dim1] = 1.f;
+		} else if (i__ > 1) {
+		    a[i__ + (i__ - 1) * a_dim1] = -1.f;
+		}
+	    } else {
+		a[i__ + i__ * a_dim1] = 1.f;
+		if (i__ % 2 != 0 && i__ < *m) {
+		    a[i__ + (i__ + 1) * a_dim1] = imeps * 2;
+		} else if (i__ > 1) {
+		    a[i__ + (i__ - 1) * a_dim1] = -imeps * 2;
+		}
+	    }
+/* L240: */
+	}
+
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    e[i__ + i__ * e_dim1] = 1.f;
+	    if (i__ <= 4) {
+		b[i__ + i__ * b_dim1] = -1.f;
+		if (i__ > 2) {
+		    b[i__ + i__ * b_dim1] = 1.f - reeps;
+		}
+		if (i__ % 2 != 0 && i__ < *n) {
+		    b[i__ + (i__ + 1) * b_dim1] = imeps;
+		} else if (i__ > 1) {
+		    b[i__ + (i__ - 1) * b_dim1] = -imeps;
+		}
+	    } else if (i__ <= 8) {
+		if (i__ <= 6) {
+		    b[i__ + i__ * b_dim1] = reeps;
+		} else {
+		    b[i__ + i__ * b_dim1] = -reeps;
+		}
+		if (i__ % 2 != 0 && i__ < *n) {
+		    b[i__ + (i__ + 1) * b_dim1] = imeps + 1.f;
+		} else if (i__ > 1) {
+		    b[i__ + (i__ - 1) * b_dim1] = -1.f - imeps;
+		}
+	    } else {
+		b[i__ + i__ * b_dim1] = 1.f - reeps;
+		if (i__ % 2 != 0 && i__ < *n) {
+		    b[i__ + (i__ + 1) * b_dim1] = imeps * 2;
+		} else if (i__ > 1) {
+		    b[i__ + (i__ - 1) * b_dim1] = -imeps * 2;
+		}
+	    }
+/* L250: */
+	}
+    }
+
+/*     Compute rhs (C, F) */
+
+    sgemm_("N", "N", m, n, m, &c_b29, &a[a_offset], lda, &r__[r_offset], ldr, 
+	    &c_b30, &c__[c_offset], ldc);
+    sgemm_("N", "N", m, n, n, &c_b33, &l[l_offset], ldl, &b[b_offset], ldb, &
+	    c_b29, &c__[c_offset], ldc);
+    sgemm_("N", "N", m, n, m, &c_b29, &d__[d_offset], ldd, &r__[r_offset], 
+	    ldr, &c_b30, &f[f_offset], ldf);
+    sgemm_("N", "N", m, n, n, &c_b33, &l[l_offset], ldl, &e[e_offset], lde, &
+	    c_b29, &f[f_offset], ldf);
+
+/*     End of SLATM5 */
+
+    return 0;
+} /* slatm5_ */
+

lapack-netlib/TESTING/MATGEN/slatm6.c

@@ -0,0 +1,748 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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 integer c__4 = 4;
+static integer c__12 = 12;
+static integer c__8 = 8;
+static integer c__40 = 40;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__60 = 60;
+
+/* > \brief \b SLATM6 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA, */
+/*                          BETA, WX, WY, S, DIF ) */
+
+/*       INTEGER            LDA, LDX, LDY, N, TYPE */
+/*       REAL               ALPHA, BETA, WX, WY */
+/*       REAL               A( LDA, * ), B( LDA, * ), DIF( * ), S( * ), */
+/*      $                   X( LDX, * ), Y( LDY, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SLATM6 generates test matrices for the generalized eigenvalue */
+/* > problem, their corresponding right and left eigenvector matrices, */
+/* > and also reciprocal condition numbers for all eigenvalues and */
+/* > the reciprocal condition numbers of eigenvectors corresponding to */
+/* > the 1th and 5th eigenvalues. */
+/* > */
+/* > Test Matrices */
+/* > ============= */
+/* > */
+/* > Two kinds of test matrix pairs */
+/* > */
+/* >       (A, B) = inverse(YH) * (Da, Db) * inverse(X) */
+/* > */
+/* > are used in the tests: */
+/* > */
+/* > Type 1: */
+/* >    Da = 1+a   0    0    0    0    Db = 1   0   0   0   0 */
+/* >          0   2+a   0    0    0         0   1   0   0   0 */
+/* >          0    0   3+a   0    0         0   0   1   0   0 */
+/* >          0    0    0   4+a   0         0   0   0   1   0 */
+/* >          0    0    0    0   5+a ,      0   0   0   0   1 , and */
+/* > */
+/* > Type 2: */
+/* >    Da =  1   -1    0    0    0    Db = 1   0   0   0   0 */
+/* >          1    1    0    0    0         0   1   0   0   0 */
+/* >          0    0    1    0    0         0   0   1   0   0 */
+/* >          0    0    0   1+a  1+b        0   0   0   1   0 */
+/* >          0    0    0  -1-b  1+a ,      0   0   0   0   1 . */
+/* > */
+/* > In both cases the same inverse(YH) and inverse(X) are used to compute */
+/* > (A, B), giving the exact eigenvectors to (A,B) as (YH, X): */
+/* > */
+/* > YH:  =  1    0   -y    y   -y    X =  1   0  -x  -x   x */
+/* >         0    1   -y    y   -y         0   1   x  -x  -x */
+/* >         0    0    1    0    0         0   0   1   0   0 */
+/* >         0    0    0    1    0         0   0   0   1   0 */
+/* >         0    0    0    0    1,        0   0   0   0   1 , */
+/* > */
+/* > where a, b, x and y will have all values independently of each other. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] TYPE */
+/* > \verbatim */
+/* >          TYPE is INTEGER */
+/* >          Specifies the problem type (see further details). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          Size of the matrices A and B. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA, N). */
+/* >          On exit A N-by-N is initialized according to TYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of A and of B. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDA, N). */
+/* >          On exit B N-by-N is initialized according to TYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] X */
+/* > \verbatim */
+/* >          X is REAL array, dimension (LDX, N). */
+/* >          On exit X is the N-by-N matrix of right eigenvectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDX */
+/* > \verbatim */
+/* >          LDX is INTEGER */
+/* >          The leading dimension of X. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Y */
+/* > \verbatim */
+/* >          Y is REAL array, dimension (LDY, N). */
+/* >          On exit Y is the N-by-N matrix of left eigenvectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDY */
+/* > \verbatim */
+/* >          LDY is INTEGER */
+/* >          The leading dimension of Y. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] ALPHA */
+/* > \verbatim */
+/* >          ALPHA is REAL */
+/* > \endverbatim */
+/* > */
+/* > \param[in] BETA */
+/* > \verbatim */
+/* >          BETA is REAL */
+/* > */
+/* >          Weighting constants for matrix A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] WX */
+/* > \verbatim */
+/* >          WX is REAL */
+/* >          Constant for right eigenvector matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] WY */
+/* > \verbatim */
+/* >          WY is REAL */
+/* >          Constant for left eigenvector matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] S */
+/* > \verbatim */
+/* >          S is REAL array, dimension (N) */
+/* >          S(i) is the reciprocal condition number for eigenvalue i. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] DIF */
+/* > \verbatim */
+/* >          DIF is REAL array, dimension (N) */
+/* >          DIF(i) is the reciprocal condition number for eigenvector i. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup real_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int slatm6_(integer *type__, integer *n, real *a, integer *
+	lda, real *b, real *x, integer *ldx, real *y, integer *ldy, real *
+	alpha, real *beta, real *wx, real *wy, real *s, real *dif)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, y_dim1, 
+	    y_offset, i__1, i__2;
+
+    /* Local variables */
+    integer info;
+    real work[100];
+    integer i__, j;
+    real z__[144]	/* was [12][12] */;
+    extern /* Subroutine */ int slakf2_(integer *, integer *, real *, integer 
+	    *, real *, real *, real *, real *, integer *), sgesvd_(char *, 
+	    char *, integer *, integer *, real *, integer *, real *, real *, 
+	    integer *, real *, integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Generate test problem ... */
+/*     (Da, Db) ... */
+
+    /* Parameter adjustments */
+    b_dim1 = *lda;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    x_dim1 = *ldx;
+    x_offset = 1 + x_dim1 * 1;
+    x -= x_offset;
+    y_dim1 = *ldy;
+    y_offset = 1 + y_dim1 * 1;
+    y -= y_offset;
+    --s;
+    --dif;
+
+    /* Function Body */
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	i__2 = *n;
+	for (j = 1; j <= i__2; ++j) {
+
+	    if (i__ == j) {
+		a[i__ + i__ * a_dim1] = (real) i__ + *alpha;
+		b[i__ + i__ * b_dim1] = 1.f;
+	    } else {
+		a[i__ + j * a_dim1] = 0.f;
+		b[i__ + j * b_dim1] = 0.f;
+	    }
+
+/* L10: */
+	}
+/* L20: */
+    }
+
+/*     Form X and Y */
+
+    slacpy_("F", n, n, &b[b_offset], lda, &y[y_offset], ldy);
+    y[y_dim1 + 3] = -(*wy);
+    y[y_dim1 + 4] = *wy;
+    y[y_dim1 + 5] = -(*wy);
+    y[(y_dim1 << 1) + 3] = -(*wy);
+    y[(y_dim1 << 1) + 4] = *wy;
+    y[(y_dim1 << 1) + 5] = -(*wy);
+
+    slacpy_("F", n, n, &b[b_offset], lda, &x[x_offset], ldx);
+    x[x_dim1 * 3 + 1] = -(*wx);
+    x[(x_dim1 << 2) + 1] = -(*wx);
+    x[x_dim1 * 5 + 1] = *wx;
+    x[x_dim1 * 3 + 2] = *wx;
+    x[(x_dim1 << 2) + 2] = -(*wx);
+    x[x_dim1 * 5 + 2] = -(*wx);
+
+/*     Form (A, B) */
+
+    b[b_dim1 * 3 + 1] = *wx + *wy;
+    b[b_dim1 * 3 + 2] = -(*wx) + *wy;
+    b[(b_dim1 << 2) + 1] = *wx - *wy;
+    b[(b_dim1 << 2) + 2] = *wx - *wy;
+    b[b_dim1 * 5 + 1] = -(*wx) + *wy;
+    b[b_dim1 * 5 + 2] = *wx + *wy;
+    if (*type__ == 1) {
+	a[a_dim1 * 3 + 1] = *wx * a[a_dim1 + 1] + *wy * a[a_dim1 * 3 + 3];
+	a[a_dim1 * 3 + 2] = -(*wx) * a[(a_dim1 << 1) + 2] + *wy * a[a_dim1 * 
+		3 + 3];
+	a[(a_dim1 << 2) + 1] = *wx * a[a_dim1 + 1] - *wy * a[(a_dim1 << 2) + 
+		4];
+	a[(a_dim1 << 2) + 2] = *wx * a[(a_dim1 << 1) + 2] - *wy * a[(a_dim1 <<
+		 2) + 4];
+	a[a_dim1 * 5 + 1] = -(*wx) * a[a_dim1 + 1] + *wy * a[a_dim1 * 5 + 5];
+	a[a_dim1 * 5 + 2] = *wx * a[(a_dim1 << 1) + 2] + *wy * a[a_dim1 * 5 + 
+		5];
+    } else if (*type__ == 2) {
+	a[a_dim1 * 3 + 1] = *wx * 2.f + *wy;
+	a[a_dim1 * 3 + 2] = *wy;
+	a[(a_dim1 << 2) + 1] = -(*wy) * (*alpha + 2.f + *beta);
+	a[(a_dim1 << 2) + 2] = *wx * 2.f - *wy * (*alpha + 2.f + *beta);
+	a[a_dim1 * 5 + 1] = *wx * -2.f + *wy * (*alpha - *beta);
+	a[a_dim1 * 5 + 2] = *wy * (*alpha - *beta);
+	a[a_dim1 + 1] = 1.f;
+	a[(a_dim1 << 1) + 1] = -1.f;
+	a[a_dim1 + 2] = 1.f;
+	a[(a_dim1 << 1) + 2] = a[a_dim1 + 1];
+	a[a_dim1 * 3 + 3] = 1.f;
+	a[(a_dim1 << 2) + 4] = *alpha + 1.f;
+	a[a_dim1 * 5 + 4] = *beta + 1.f;
+	a[(a_dim1 << 2) + 5] = -a[a_dim1 * 5 + 4];
+	a[a_dim1 * 5 + 5] = a[(a_dim1 << 2) + 4];
+    }
+
+/*     Compute condition numbers */
+
+    if (*type__ == 1) {
+
+	s[1] = 1.f / sqrt((*wy * 3.f * *wy + 1.f) / (a[a_dim1 + 1] * a[a_dim1 
+		+ 1] + 1.f));
+	s[2] = 1.f / sqrt((*wy * 3.f * *wy + 1.f) / (a[(a_dim1 << 1) + 2] * a[
+		(a_dim1 << 1) + 2] + 1.f));
+	s[3] = 1.f / sqrt((*wx * 2.f * *wx + 1.f) / (a[a_dim1 * 3 + 3] * a[
+		a_dim1 * 3 + 3] + 1.f));
+	s[4] = 1.f / sqrt((*wx * 2.f * *wx + 1.f) / (a[(a_dim1 << 2) + 4] * a[
+		(a_dim1 << 2) + 4] + 1.f));
+	s[5] = 1.f / sqrt((*wx * 2.f * *wx + 1.f) / (a[a_dim1 * 5 + 5] * a[
+		a_dim1 * 5 + 5] + 1.f));
+
+	slakf2_(&c__1, &c__4, &a[a_offset], lda, &a[(a_dim1 << 1) + 2], &b[
+		b_offset], &b[(b_dim1 << 1) + 2], z__, &c__12);
+	sgesvd_("N", "N", &c__8, &c__8, z__, &c__12, work, &work[8], &c__1, &
+		work[9], &c__1, &work[10], &c__40, &info);
+	dif[1] = work[7];
+
+	slakf2_(&c__4, &c__1, &a[a_offset], lda, &a[a_dim1 * 5 + 5], &b[
+		b_offset], &b[b_dim1 * 5 + 5], z__, &c__12);
+	sgesvd_("N", "N", &c__8, &c__8, z__, &c__12, work, &work[8], &c__1, &
+		work[9], &c__1, &work[10], &c__40, &info);
+	dif[5] = work[7];
+
+    } else if (*type__ == 2) {
+
+	s[1] = 1.f / sqrt(*wy * *wy + .33333333333333331f);
+	s[2] = s[1];
+	s[3] = 1.f / sqrt(*wx * *wx + .5f);
+	s[4] = 1.f / sqrt((*wx * 2.f * *wx + 1.f) / ((*alpha + 1.f) * (*alpha 
+		+ 1.f) + 1.f + (*beta + 1.f) * (*beta + 1.f)));
+	s[5] = s[4];
+
+	slakf2_(&c__2, &c__3, &a[a_offset], lda, &a[a_dim1 * 3 + 3], &b[
+		b_offset], &b[b_dim1 * 3 + 3], z__, &c__12);
+	sgesvd_("N", "N", &c__12, &c__12, z__, &c__12, work, &work[12], &c__1,
+		 &work[13], &c__1, &work[14], &c__60, &info);
+	dif[1] = work[11];
+
+	slakf2_(&c__3, &c__2, &a[a_offset], lda, &a[(a_dim1 << 2) + 4], &b[
+		b_offset], &b[(b_dim1 << 2) + 4], z__, &c__12);
+	sgesvd_("N", "N", &c__12, &c__12, z__, &c__12, work, &work[12], &c__1,
+		 &work[13], &c__1, &work[14], &c__60, &info);
+	dif[5] = work[11];
+
+    }
+
+    return 0;
+
+/*     End of SLATM6 */
+
+} /* slatm6_ */
+

lapack-netlib/TESTING/MATGEN/slatm7.c

@@ -0,0 +1,701 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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)
+*/
+
+
+
+/* > \brief \b SLATM7 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SLATM7( MODE, COND, IRSIGN, IDIST, ISEED, D, N, */
+/*                          RANK, INFO ) */
+
+/*       REAL               COND */
+/*       INTEGER            IDIST, INFO, IRSIGN, MODE, N, RANK */
+/*       REAL               D( * ) */
+/*       INTEGER            ISEED( 4 ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* >    SLATM7 computes the entries of D as specified by MODE */
+/* >    COND and IRSIGN. IDIST and ISEED determine the generation */
+/* >    of random numbers. SLATM7 is called by SLATMT to generate */
+/* >    random test matrices. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \verbatim */
+/* >  MODE   - INTEGER */
+/* >           On entry describes how D is to be computed: */
+/* >           MODE = 0 means do not change D. */
+/* > */
+/* >           MODE = 1 sets D(1)=1 and D(2:RANK)=1.0/COND */
+/* >           MODE = 2 sets D(1:RANK-1)=1 and D(RANK)=1.0/COND */
+/* >           MODE = 3 sets D(I)=COND**(-(I-1)/(RANK-1)) I=1:RANK */
+/* > */
+/* >           MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* >           MODE = 5 sets D to random numbers in the range */
+/* >                    ( 1/COND , 1 ) such that their logarithms */
+/* >                    are uniformly distributed. */
+/* >           MODE = 6 set D to random numbers from same distribution */
+/* >                    as the rest of the matrix. */
+/* >           MODE < 0 has the same meaning as ABS(MODE), except that */
+/* >              the order of the elements of D is reversed. */
+/* >           Thus if MODE is positive, D has entries ranging from */
+/* >              1 to 1/COND, if negative, from 1/COND to 1, */
+/* >           Not modified. */
+/* > */
+/* >  COND   - REAL */
+/* >           On entry, used as described under MODE above. */
+/* >           If used, it must be >= 1. Not modified. */
+/* > */
+/* >  IRSIGN - INTEGER */
+/* >           On entry, if MODE neither -6, 0 nor 6, determines sign of */
+/* >           entries of D */
+/* >           0 => leave entries of D unchanged */
+/* >           1 => multiply each entry of D by 1 or -1 with probability .5 */
+/* > */
+/* >  IDIST  - CHARACTER*1 */
+/* >           On entry, IDIST specifies the type of distribution to be */
+/* >           used to generate a random matrix . */
+/* >           1 => UNIFORM( 0, 1 ) */
+/* >           2 => UNIFORM( -1, 1 ) */
+/* >           3 => NORMAL( 0, 1 ) */
+/* >           Not modified. */
+/* > */
+/* >  ISEED  - INTEGER array, dimension ( 4 ) */
+/* >           On entry ISEED specifies the seed of the random number */
+/* >           generator. The random number generator uses a */
+/* >           linear congruential sequence limited to small */
+/* >           integers, and so should produce machine independent */
+/* >           random numbers. The values of ISEED are changed on */
+/* >           exit, and can be used in the next call to SLATM7 */
+/* >           to continue the same random number sequence. */
+/* >           Changed on exit. */
+/* > */
+/* >  D      - REAL array, dimension ( MIN( M , N ) ) */
+/* >           Array to be computed according to MODE, COND and IRSIGN. */
+/* >           May be changed on exit if MODE is nonzero. */
+/* > */
+/* >  N      - INTEGER */
+/* >           Number of entries of D. Not modified. */
+/* > */
+/* >  RANK   - INTEGER */
+/* >           The rank of matrix to be generated for modes 1,2,3 only. */
+/* >           D( RANK+1:N ) = 0. */
+/* >           Not modified. */
+/* > */
+/* >  INFO   - INTEGER */
+/* >            0  => normal termination */
+/* >           -1  => if MODE not in range -6 to 6 */
+/* >           -2  => if MODE neither -6, 0 nor 6, and */
+/* >                  IRSIGN neither 0 nor 1 */
+/* >           -3  => if MODE neither -6, 0 nor 6 and COND less than 1 */
+/* >           -4  => if MODE equals 6 or -6 and IDIST not in range 1 to 3 */
+/* >           -7  => if N negative */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup real_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int slatm7_(integer *mode, real *cond, integer *irsign, 
+	integer *idist, integer *iseed, real *d__, integer *n, integer *rank, 
+	integer *info)
+{
+    /* System generated locals */
+    integer i__1, i__2;
+    doublereal d__1, d__2;
+
+    /* Local variables */
+    real temp;
+    integer i__;
+    real alpha;
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    extern real slaran_(integer *);
+    extern /* Subroutine */ int slarnv_(integer *, integer *, 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Decode and Test the input parameters. Initialize flags & seed. */
+
+    /* Parameter adjustments */
+    --d__;
+    --iseed;
+
+    /* Function Body */
+    *info = 0;
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+/*     Set INFO if an error */
+
+    if (*mode < -6 || *mode > 6) {
+	*info = -1;
+    } else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && *
+	    irsign != 1)) {
+	*info = -2;
+    } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.f) {
+	*info = -3;
+    } else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 3)) {
+	*info = -4;
+    } else if (*n < 0) {
+	*info = -7;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SLATM7", &i__1);
+	return 0;
+    }
+
+/*     Compute D according to COND and MODE */
+
+    if (*mode != 0) {
+	switch (abs(*mode)) {
+	    case 1:  goto L100;
+	    case 2:  goto L130;
+	    case 3:  goto L160;
+	    case 4:  goto L190;
+	    case 5:  goto L210;
+	    case 6:  goto L230;
+	}
+
+/*        One large D value: */
+
+L100:
+	i__1 = *rank;
+	for (i__ = 2; i__ <= i__1; ++i__) {
+	    d__[i__] = 1.f / *cond;
+/* L110: */
+	}
+	i__1 = *n;
+	for (i__ = *rank + 1; i__ <= i__1; ++i__) {
+	    d__[i__] = 0.f;
+/* L120: */
+	}
+	d__[1] = 1.f;
+	goto L240;
+
+/*        One small D value: */
+
+L130:
+	i__1 = *rank - 1;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    d__[i__] = 1.f;
+/* L140: */
+	}
+	i__1 = *n;
+	for (i__ = *rank + 1; i__ <= i__1; ++i__) {
+	    d__[i__] = 0.f;
+/* L150: */
+	}
+	d__[*rank] = 1.f / *cond;
+	goto L240;
+
+/*        Exponentially distributed D values: */
+
+L160:
+	d__[1] = 1.f;
+	if (*n > 1 && *rank > 1) {
+	    d__1 = (doublereal) (*cond);
+	    d__2 = (doublereal) (-1.f / (real) (*rank - 1));
+	    alpha = pow_dd(&d__1, &d__2);
+	    i__1 = *rank;
+	    for (i__ = 2; i__ <= i__1; ++i__) {
+		i__2 = i__ - 1;
+		d__[i__] = pow_ri(&alpha, &i__2);
+/* L170: */
+	    }
+	    i__1 = *n;
+	    for (i__ = *rank + 1; i__ <= i__1; ++i__) {
+		d__[i__] = 0.f;
+/* L180: */
+	    }
+	}
+	goto L240;
+
+/*        Arithmetically distributed D values: */
+
+L190:
+	d__[1] = 1.f;
+	if (*n > 1) {
+	    temp = 1.f / *cond;
+	    alpha = (1.f - temp) / (real) (*n - 1);
+	    i__1 = *n;
+	    for (i__ = 2; i__ <= i__1; ++i__) {
+		d__[i__] = (real) (*n - i__) * alpha + temp;
+/* L200: */
+	    }
+	}
+	goto L240;
+
+/*        Randomly distributed D values on ( 1/COND , 1): */
+
+L210:
+	alpha = log(1.f / *cond);
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    d__[i__] = exp(alpha * slaran_(&iseed[1]));
+/* L220: */
+	}
+	goto L240;
+
+/*        Randomly distributed D values from IDIST */
+
+L230:
+	slarnv_(idist, &iseed[1], n, &d__[1]);
+
+L240:
+
+/*        If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */
+/*        random signs to D */
+
+	if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) {
+	    i__1 = *n;
+	    for (i__ = 1; i__ <= i__1; ++i__) {
+		temp = slaran_(&iseed[1]);
+		if (temp > .5f) {
+		    d__[i__] = -d__[i__];
+		}
+/* L250: */
+	    }
+	}
+
+/*        Reverse if MODE < 0 */
+
+	if (*mode < 0) {
+	    i__1 = *n / 2;
+	    for (i__ = 1; i__ <= i__1; ++i__) {
+		temp = d__[i__];
+		d__[i__] = d__[*n + 1 - i__];
+		d__[*n + 1 - i__] = temp;
+/* L260: */
+	    }
+	}
+
+    }
+
+    return 0;
+
+/*     End of SLATM7 */
+
+} /* slatm7_ */
+

lapack-netlib/TESTING/MATGEN/zlagge.c

@@ -0,0 +1,909 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__3 = 3;
+static integer c__1 = 1;
+
+/* > \brief \b ZLAGGE */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE ZLAGGE( M, N, KL, KU, D, A, LDA, ISEED, WORK, INFO ) */
+
+/*       INTEGER            INFO, KL, KU, LDA, M, N */
+/*       INTEGER            ISEED( 4 ) */
+/*       DOUBLE PRECISION   D( * ) */
+/*       COMPLEX*16         A( LDA, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > ZLAGGE generates a complex general m by n matrix A, by pre- and post- */
+/* > multiplying a real diagonal matrix D with random unitary matrices: */
+/* > A = U*D*V. The lower and upper bandwidths may then be reduced to */
+/* > kl and ku by additional unitary transformations. */
+/* > \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] KL */
+/* > \verbatim */
+/* >          KL is INTEGER */
+/* >          The number of nonzero subdiagonals within the band of A. */
+/* >          0 <= KL <= M-1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KU */
+/* > \verbatim */
+/* >          KU is INTEGER */
+/* >          The number of nonzero superdiagonals within the band of A. */
+/* >          0 <= KU <= N-1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is DOUBLE PRECISION array, dimension (f2cmin(M,N)) */
+/* >          The diagonal elements of the diagonal matrix D. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] A */
+/* > \verbatim */
+/* >          A is COMPLEX*16 array, dimension (LDA,N) */
+/* >          The generated m by n matrix A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= M. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension (4) */
+/* >          On entry, the seed of the random number generator; the array */
+/* >          elements must be between 0 and 4095, and ISEED(4) must be */
+/* >          odd. */
+/* >          On exit, the seed is updated. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is COMPLEX*16 array, dimension (M+N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit */
+/* >          < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complex16_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int zlagge_(integer *m, integer *n, integer *kl, integer *ku,
+	 doublereal *d__, doublecomplex *a, integer *lda, integer *iseed, 
+	doublecomplex *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+    doublereal d__1;
+    doublecomplex z__1;
+
+    /* Local variables */
+    integer i__, j;
+    extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *, 
+	    doublecomplex *, integer *, doublecomplex *, integer *, 
+	    doublecomplex *, integer *), zscal_(integer *, doublecomplex *, 
+	    doublecomplex *, integer *), zgemv_(char *, integer *, integer *, 
+	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
+	    integer *, doublecomplex *, doublecomplex *, integer *);
+    extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
+    doublecomplex wa, wb;
+    doublereal wn;
+    extern /* Subroutine */ int xerbla_(char *, integer *), zlacgv_(
+	    integer *, doublecomplex *, integer *), zlarnv_(integer *, 
+	    integer *, integer *, doublecomplex *);
+    doublecomplex tau;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    --d__;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --iseed;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    if (*m < 0) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*kl < 0 || *kl > *m - 1) {
+	*info = -3;
+    } else if (*ku < 0 || *ku > *n - 1) {
+	*info = -4;
+    } else if (*lda < f2cmax(1,*m)) {
+	*info = -7;
+    }
+    if (*info < 0) {
+	i__1 = -(*info);
+	xerbla_("ZLAGGE", &i__1);
+	return 0;
+    }
+
+/*     initialize A to diagonal matrix */
+
+    i__1 = *n;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *m;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    i__3 = i__ + j * a_dim1;
+	    a[i__3].r = 0., a[i__3].i = 0.;
+/* L10: */
+	}
+/* L20: */
+    }
+    i__1 = f2cmin(*m,*n);
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	i__2 = i__ + i__ * a_dim1;
+	i__3 = i__;
+	a[i__2].r = d__[i__3], a[i__2].i = 0.;
+/* L30: */
+    }
+
+/*     Quick exit if the user wants a diagonal matrix */
+
+    if (*kl == 0 && *ku == 0) {
+	return 0;
+    }
+
+/*     pre- and post-multiply A by random unitary matrices */
+
+    for (i__ = f2cmin(*m,*n); i__ >= 1; --i__) {
+	if (i__ < *m) {
+
+/*           generate random reflection */
+
+	    i__1 = *m - i__ + 1;
+	    zlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+	    i__1 = *m - i__ + 1;
+	    wn = dznrm2_(&i__1, &work[1], &c__1);
+	    d__1 = wn / z_abs(&work[1]);
+	    z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i;
+	    wa.r = z__1.r, wa.i = z__1.i;
+	    if (wn == 0.) {
+		tau.r = 0., tau.i = 0.;
+	    } else {
+		z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i;
+		wb.r = z__1.r, wb.i = z__1.i;
+		i__1 = *m - i__;
+		z_div(&z__1, &c_b2, &wb);
+		zscal_(&i__1, &z__1, &work[2], &c__1);
+		work[1].r = 1., work[1].i = 0.;
+		z_div(&z__1, &wb, &wa);
+		d__1 = z__1.r;
+		tau.r = d__1, tau.i = 0.;
+	    }
+
+/*           multiply A(i:m,i:n) by random reflection from the left */
+
+	    i__1 = *m - i__ + 1;
+	    i__2 = *n - i__ + 1;
+	    zgemv_("Conjugate transpose", &i__1, &i__2, &c_b2, &a[i__ + i__ * 
+		    a_dim1], lda, &work[1], &c__1, &c_b1, &work[*m + 1], &
+		    c__1);
+	    i__1 = *m - i__ + 1;
+	    i__2 = *n - i__ + 1;
+	    z__1.r = -tau.r, z__1.i = -tau.i;
+	    zgerc_(&i__1, &i__2, &z__1, &work[1], &c__1, &work[*m + 1], &c__1,
+		     &a[i__ + i__ * a_dim1], lda);
+	}
+	if (i__ < *n) {
+
+/*           generate random reflection */
+
+	    i__1 = *n - i__ + 1;
+	    zlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+	    i__1 = *n - i__ + 1;
+	    wn = dznrm2_(&i__1, &work[1], &c__1);
+	    d__1 = wn / z_abs(&work[1]);
+	    z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i;
+	    wa.r = z__1.r, wa.i = z__1.i;
+	    if (wn == 0.) {
+		tau.r = 0., tau.i = 0.;
+	    } else {
+		z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i;
+		wb.r = z__1.r, wb.i = z__1.i;
+		i__1 = *n - i__;
+		z_div(&z__1, &c_b2, &wb);
+		zscal_(&i__1, &z__1, &work[2], &c__1);
+		work[1].r = 1., work[1].i = 0.;
+		z_div(&z__1, &wb, &wa);
+		d__1 = z__1.r;
+		tau.r = d__1, tau.i = 0.;
+	    }
+
+/*           multiply A(i:m,i:n) by random reflection from the right */
+
+	    i__1 = *m - i__ + 1;
+	    i__2 = *n - i__ + 1;
+	    zgemv_("No transpose", &i__1, &i__2, &c_b2, &a[i__ + i__ * a_dim1]
+		    , lda, &work[1], &c__1, &c_b1, &work[*n + 1], &c__1);
+	    i__1 = *m - i__ + 1;
+	    i__2 = *n - i__ + 1;
+	    z__1.r = -tau.r, z__1.i = -tau.i;
+	    zgerc_(&i__1, &i__2, &z__1, &work[*n + 1], &c__1, &work[1], &c__1,
+		     &a[i__ + i__ * a_dim1], lda);
+	}
+/* L40: */
+    }
+
+/*     Reduce number of subdiagonals to KL and number of superdiagonals */
+/*     to KU */
+
+/* Computing MAX */
+    i__2 = *m - 1 - *kl, i__3 = *n - 1 - *ku;
+    i__1 = f2cmax(i__2,i__3);
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	if (*kl <= *ku) {
+
+/*           annihilate subdiagonal elements first (necessary if KL = 0) */
+
+/* Computing MIN */
+	    i__2 = *m - 1 - *kl;
+	    if (i__ <= f2cmin(i__2,*n)) {
+
+/*              generate reflection to annihilate A(kl+i+1:m,i) */
+
+		i__2 = *m - *kl - i__ + 1;
+		wn = dznrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
+		d__1 = wn / z_abs(&a[*kl + i__ + i__ * a_dim1]);
+		i__2 = *kl + i__ + i__ * a_dim1;
+		z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
+		wa.r = z__1.r, wa.i = z__1.i;
+		if (wn == 0.) {
+		    tau.r = 0., tau.i = 0.;
+		} else {
+		    i__2 = *kl + i__ + i__ * a_dim1;
+		    z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
+		    wb.r = z__1.r, wb.i = z__1.i;
+		    i__2 = *m - *kl - i__;
+		    z_div(&z__1, &c_b2, &wb);
+		    zscal_(&i__2, &z__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
+			    c__1);
+		    i__2 = *kl + i__ + i__ * a_dim1;
+		    a[i__2].r = 1., a[i__2].i = 0.;
+		    z_div(&z__1, &wb, &wa);
+		    d__1 = z__1.r;
+		    tau.r = d__1, tau.i = 0.;
+		}
+
+/*              apply reflection to A(kl+i:m,i+1:n) from the left */
+
+		i__2 = *m - *kl - i__ + 1;
+		i__3 = *n - i__;
+		zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*kl + 
+			i__ + (i__ + 1) * a_dim1], lda, &a[*kl + i__ + i__ * 
+			a_dim1], &c__1, &c_b1, &work[1], &c__1);
+		i__2 = *m - *kl - i__ + 1;
+		i__3 = *n - i__;
+		z__1.r = -tau.r, z__1.i = -tau.i;
+		zgerc_(&i__2, &i__3, &z__1, &a[*kl + i__ + i__ * a_dim1], &
+			c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) * 
+			a_dim1], lda);
+		i__2 = *kl + i__ + i__ * a_dim1;
+		z__1.r = -wa.r, z__1.i = -wa.i;
+		a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+	    }
+
+/* Computing MIN */
+	    i__2 = *n - 1 - *ku;
+	    if (i__ <= f2cmin(i__2,*m)) {
+
+/*              generate reflection to annihilate A(i,ku+i+1:n) */
+
+		i__2 = *n - *ku - i__ + 1;
+		wn = dznrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+		d__1 = wn / z_abs(&a[i__ + (*ku + i__) * a_dim1]);
+		i__2 = i__ + (*ku + i__) * a_dim1;
+		z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
+		wa.r = z__1.r, wa.i = z__1.i;
+		if (wn == 0.) {
+		    tau.r = 0., tau.i = 0.;
+		} else {
+		    i__2 = i__ + (*ku + i__) * a_dim1;
+		    z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
+		    wb.r = z__1.r, wb.i = z__1.i;
+		    i__2 = *n - *ku - i__;
+		    z_div(&z__1, &c_b2, &wb);
+		    zscal_(&i__2, &z__1, &a[i__ + (*ku + i__ + 1) * a_dim1], 
+			    lda);
+		    i__2 = i__ + (*ku + i__) * a_dim1;
+		    a[i__2].r = 1., a[i__2].i = 0.;
+		    z_div(&z__1, &wb, &wa);
+		    d__1 = z__1.r;
+		    tau.r = d__1, tau.i = 0.;
+		}
+
+/*              apply reflection to A(i+1:m,ku+i:n) from the right */
+
+		i__2 = *n - *ku - i__ + 1;
+		zlacgv_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+		i__2 = *m - i__;
+		i__3 = *n - *ku - i__ + 1;
+		zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (*ku 
+			+ i__) * a_dim1], lda, &a[i__ + (*ku + i__) * a_dim1],
+			 lda, &c_b1, &work[1], &c__1);
+		i__2 = *m - i__;
+		i__3 = *n - *ku - i__ + 1;
+		z__1.r = -tau.r, z__1.i = -tau.i;
+		zgerc_(&i__2, &i__3, &z__1, &work[1], &c__1, &a[i__ + (*ku + 
+			i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) * 
+			a_dim1], lda);
+		i__2 = i__ + (*ku + i__) * a_dim1;
+		z__1.r = -wa.r, z__1.i = -wa.i;
+		a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+	    }
+	} else {
+
+/*           annihilate superdiagonal elements first (necessary if */
+/*           KU = 0) */
+
+/* Computing MIN */
+	    i__2 = *n - 1 - *ku;
+	    if (i__ <= f2cmin(i__2,*m)) {
+
+/*              generate reflection to annihilate A(i,ku+i+1:n) */
+
+		i__2 = *n - *ku - i__ + 1;
+		wn = dznrm2_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+		d__1 = wn / z_abs(&a[i__ + (*ku + i__) * a_dim1]);
+		i__2 = i__ + (*ku + i__) * a_dim1;
+		z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
+		wa.r = z__1.r, wa.i = z__1.i;
+		if (wn == 0.) {
+		    tau.r = 0., tau.i = 0.;
+		} else {
+		    i__2 = i__ + (*ku + i__) * a_dim1;
+		    z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
+		    wb.r = z__1.r, wb.i = z__1.i;
+		    i__2 = *n - *ku - i__;
+		    z_div(&z__1, &c_b2, &wb);
+		    zscal_(&i__2, &z__1, &a[i__ + (*ku + i__ + 1) * a_dim1], 
+			    lda);
+		    i__2 = i__ + (*ku + i__) * a_dim1;
+		    a[i__2].r = 1., a[i__2].i = 0.;
+		    z_div(&z__1, &wb, &wa);
+		    d__1 = z__1.r;
+		    tau.r = d__1, tau.i = 0.;
+		}
+
+/*              apply reflection to A(i+1:m,ku+i:n) from the right */
+
+		i__2 = *n - *ku - i__ + 1;
+		zlacgv_(&i__2, &a[i__ + (*ku + i__) * a_dim1], lda);
+		i__2 = *m - i__;
+		i__3 = *n - *ku - i__ + 1;
+		zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (*ku 
+			+ i__) * a_dim1], lda, &a[i__ + (*ku + i__) * a_dim1],
+			 lda, &c_b1, &work[1], &c__1);
+		i__2 = *m - i__;
+		i__3 = *n - *ku - i__ + 1;
+		z__1.r = -tau.r, z__1.i = -tau.i;
+		zgerc_(&i__2, &i__3, &z__1, &work[1], &c__1, &a[i__ + (*ku + 
+			i__) * a_dim1], lda, &a[i__ + 1 + (*ku + i__) * 
+			a_dim1], lda);
+		i__2 = i__ + (*ku + i__) * a_dim1;
+		z__1.r = -wa.r, z__1.i = -wa.i;
+		a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+	    }
+
+/* Computing MIN */
+	    i__2 = *m - 1 - *kl;
+	    if (i__ <= f2cmin(i__2,*n)) {
+
+/*              generate reflection to annihilate A(kl+i+1:m,i) */
+
+		i__2 = *m - *kl - i__ + 1;
+		wn = dznrm2_(&i__2, &a[*kl + i__ + i__ * a_dim1], &c__1);
+		d__1 = wn / z_abs(&a[*kl + i__ + i__ * a_dim1]);
+		i__2 = *kl + i__ + i__ * a_dim1;
+		z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
+		wa.r = z__1.r, wa.i = z__1.i;
+		if (wn == 0.) {
+		    tau.r = 0., tau.i = 0.;
+		} else {
+		    i__2 = *kl + i__ + i__ * a_dim1;
+		    z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
+		    wb.r = z__1.r, wb.i = z__1.i;
+		    i__2 = *m - *kl - i__;
+		    z_div(&z__1, &c_b2, &wb);
+		    zscal_(&i__2, &z__1, &a[*kl + i__ + 1 + i__ * a_dim1], &
+			    c__1);
+		    i__2 = *kl + i__ + i__ * a_dim1;
+		    a[i__2].r = 1., a[i__2].i = 0.;
+		    z_div(&z__1, &wb, &wa);
+		    d__1 = z__1.r;
+		    tau.r = d__1, tau.i = 0.;
+		}
+
+/*              apply reflection to A(kl+i:m,i+1:n) from the left */
+
+		i__2 = *m - *kl - i__ + 1;
+		i__3 = *n - i__;
+		zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*kl + 
+			i__ + (i__ + 1) * a_dim1], lda, &a[*kl + i__ + i__ * 
+			a_dim1], &c__1, &c_b1, &work[1], &c__1);
+		i__2 = *m - *kl - i__ + 1;
+		i__3 = *n - i__;
+		z__1.r = -tau.r, z__1.i = -tau.i;
+		zgerc_(&i__2, &i__3, &z__1, &a[*kl + i__ + i__ * a_dim1], &
+			c__1, &work[1], &c__1, &a[*kl + i__ + (i__ + 1) * 
+			a_dim1], lda);
+		i__2 = *kl + i__ + i__ * a_dim1;
+		z__1.r = -wa.r, z__1.i = -wa.i;
+		a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+	    }
+	}
+
+	if (i__ <= *n) {
+	    i__2 = *m;
+	    for (j = *kl + i__ + 1; j <= i__2; ++j) {
+		i__3 = j + i__ * a_dim1;
+		a[i__3].r = 0., a[i__3].i = 0.;
+/* L50: */
+	    }
+	}
+
+	if (i__ <= *m) {
+	    i__2 = *n;
+	    for (j = *ku + i__ + 1; j <= i__2; ++j) {
+		i__3 = i__ + j * a_dim1;
+		a[i__3].r = 0., a[i__3].i = 0.;
+/* L60: */
+	    }
+	}
+/* L70: */
+    }
+    return 0;
+
+/*     End of ZLAGGE */
+
+} /* zlagge_ */
+

lapack-netlib/TESTING/MATGEN/zlaghe.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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__3 = 3;
+static integer c__1 = 1;
+
+/* > \brief \b ZLAGHE */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE ZLAGHE( N, K, D, A, LDA, ISEED, WORK, INFO ) */
+
+/*       INTEGER            INFO, K, LDA, N */
+/*       INTEGER            ISEED( 4 ) */
+/*       DOUBLE PRECISION   D( * ) */
+/*       COMPLEX*16         A( LDA, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > ZLAGHE generates a complex hermitian matrix A, by pre- and post- */
+/* > multiplying a real diagonal matrix D with a random unitary matrix: */
+/* > A = U*D*U'. The semi-bandwidth may then be reduced to k by additional */
+/* > unitary transformations. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] K */
+/* > \verbatim */
+/* >          K is INTEGER */
+/* >          The number of nonzero subdiagonals within the band of A. */
+/* >          0 <= K <= N-1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is DOUBLE PRECISION array, dimension (N) */
+/* >          The diagonal elements of the diagonal matrix D. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] A */
+/* > \verbatim */
+/* >          A is COMPLEX*16 array, dimension (LDA,N) */
+/* >          The generated n by n hermitian matrix A (the full matrix is */
+/* >          stored). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension (4) */
+/* >          On entry, the seed of the random number generator; the array */
+/* >          elements must be between 0 and 4095, and ISEED(4) must be */
+/* >          odd. */
+/* >          On exit, the seed is updated. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is COMPLEX*16 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 complex16_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int zlaghe_(integer *n, integer *k, doublereal *d__, 
+	doublecomplex *a, integer *lda, integer *iseed, doublecomplex *work, 
+	integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+    doublereal d__1;
+    doublecomplex z__1, z__2, z__3, z__4;
+
+    /* Local variables */
+    extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *, 
+	    doublecomplex *, integer *, doublecomplex *, integer *, 
+	    doublecomplex *, integer *);
+    integer i__, j;
+    doublecomplex alpha;
+    extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *, 
+	    doublecomplex *, integer *, doublecomplex *, integer *, 
+	    doublecomplex *, integer *), zscal_(integer *, doublecomplex *, 
+	    doublecomplex *, integer *);
+    extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, 
+	    doublecomplex *, integer *, doublecomplex *, integer *);
+    extern /* Subroutine */ int zgemv_(char *, integer *, integer *, 
+	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
+	    integer *, doublecomplex *, doublecomplex *, integer *), 
+	    zhemv_(char *, integer *, doublecomplex *, doublecomplex *, 
+	    integer *, doublecomplex *, integer *, doublecomplex *, 
+	    doublecomplex *, integer *), zaxpy_(integer *, 
+	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
+	    integer *);
+    extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
+    doublecomplex wa, wb;
+    doublereal wn;
+    extern /* Subroutine */ int xerbla_(char *, integer *), zlarnv_(
+	    integer *, integer *, integer *, doublecomplex *);
+    doublecomplex tau;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    --d__;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --iseed;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    if (*n < 0) {
+	*info = -1;
+    } else if (*k < 0 || *k > *n - 1) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    }
+    if (*info < 0) {
+	i__1 = -(*info);
+	xerbla_("ZLAGHE", &i__1);
+	return 0;
+    }
+
+/*     initialize lower triangle of A to diagonal matrix */
+
+    i__1 = *n;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *n;
+	for (i__ = j + 1; i__ <= i__2; ++i__) {
+	    i__3 = i__ + j * a_dim1;
+	    a[i__3].r = 0., a[i__3].i = 0.;
+/* L10: */
+	}
+/* L20: */
+    }
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	i__2 = i__ + i__ * a_dim1;
+	i__3 = i__;
+	a[i__2].r = d__[i__3], a[i__2].i = 0.;
+/* L30: */
+    }
+
+/*     Generate lower triangle of hermitian matrix */
+
+    for (i__ = *n - 1; i__ >= 1; --i__) {
+
+/*        generate random reflection */
+
+	i__1 = *n - i__ + 1;
+	zlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+	i__1 = *n - i__ + 1;
+	wn = dznrm2_(&i__1, &work[1], &c__1);
+	d__1 = wn / z_abs(&work[1]);
+	z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i;
+	wa.r = z__1.r, wa.i = z__1.i;
+	if (wn == 0.) {
+	    tau.r = 0., tau.i = 0.;
+	} else {
+	    z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i;
+	    wb.r = z__1.r, wb.i = z__1.i;
+	    i__1 = *n - i__;
+	    z_div(&z__1, &c_b2, &wb);
+	    zscal_(&i__1, &z__1, &work[2], &c__1);
+	    work[1].r = 1., work[1].i = 0.;
+	    z_div(&z__1, &wb, &wa);
+	    d__1 = z__1.r;
+	    tau.r = d__1, tau.i = 0.;
+	}
+
+/*        apply random reflection to A(i:n,i:n) from the left */
+/*        and the right */
+
+/*        compute  y := tau * A * u */
+
+	i__1 = *n - i__ + 1;
+	zhemv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], &
+		c__1, &c_b1, &work[*n + 1], &c__1);
+
+/*        compute  v := y - 1/2 * tau * ( y, u ) * u */
+
+	z__3.r = -.5, z__3.i = 0.;
+	z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i + 
+		z__3.i * tau.r;
+	i__1 = *n - i__ + 1;
+	zdotc_(&z__4, &i__1, &work[*n + 1], &c__1, &work[1], &c__1);
+	z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i 
+		+ z__2.i * z__4.r;
+	alpha.r = z__1.r, alpha.i = z__1.i;
+	i__1 = *n - i__ + 1;
+	zaxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
+
+/*        apply the transformation as a rank-2 update to A(i:n,i:n) */
+
+	i__1 = *n - i__ + 1;
+	z__1.r = -1., z__1.i = 0.;
+	zher2_("Lower", &i__1, &z__1, &work[1], &c__1, &work[*n + 1], &c__1, &
+		a[i__ + i__ * a_dim1], lda);
+/* L40: */
+    }
+
+/*     Reduce number of subdiagonals to K */
+
+    i__1 = *n - 1 - *k;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+
+/*        generate reflection to annihilate A(k+i+1:n,i) */
+
+	i__2 = *n - *k - i__ + 1;
+	wn = dznrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
+	d__1 = wn / z_abs(&a[*k + i__ + i__ * a_dim1]);
+	i__2 = *k + i__ + i__ * a_dim1;
+	z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
+	wa.r = z__1.r, wa.i = z__1.i;
+	if (wn == 0.) {
+	    tau.r = 0., tau.i = 0.;
+	} else {
+	    i__2 = *k + i__ + i__ * a_dim1;
+	    z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
+	    wb.r = z__1.r, wb.i = z__1.i;
+	    i__2 = *n - *k - i__;
+	    z_div(&z__1, &c_b2, &wb);
+	    zscal_(&i__2, &z__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1);
+	    i__2 = *k + i__ + i__ * a_dim1;
+	    a[i__2].r = 1., a[i__2].i = 0.;
+	    z_div(&z__1, &wb, &wa);
+	    d__1 = z__1.r;
+	    tau.r = d__1, tau.i = 0.;
+	}
+
+/*        apply reflection to A(k+i:n,i+1:k+i-1) from the left */
+
+	i__2 = *n - *k - i__ + 1;
+	i__3 = *k - 1;
+	zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + (i__ 
+		+ 1) * a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &
+		c_b1, &work[1], &c__1);
+	i__2 = *n - *k - i__ + 1;
+	i__3 = *k - 1;
+	z__1.r = -tau.r, z__1.i = -tau.i;
+	zgerc_(&i__2, &i__3, &z__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[
+		1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda);
+
+/*        apply reflection to A(k+i:n,k+i:n) from the left and the right */
+
+/*        compute  y := tau * A * u */
+
+	i__2 = *n - *k - i__ + 1;
+	zhemv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda, 
+		&a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &work[1], &c__1);
+
+/*        compute  v := y - 1/2 * tau * ( y, u ) * u */
+
+	z__3.r = -.5, z__3.i = 0.;
+	z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i + 
+		z__3.i * tau.r;
+	i__2 = *n - *k - i__ + 1;
+	zdotc_(&z__4, &i__2, &work[1], &c__1, &a[*k + i__ + i__ * a_dim1], &
+		c__1);
+	z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i 
+		+ z__2.i * z__4.r;
+	alpha.r = z__1.r, alpha.i = z__1.i;
+	i__2 = *n - *k - i__ + 1;
+	zaxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
+		c__1);
+
+/*        apply hermitian rank-2 update to A(k+i:n,k+i:n) */
+
+	i__2 = *n - *k - i__ + 1;
+	z__1.r = -1., z__1.i = 0.;
+	zher2_("Lower", &i__2, &z__1, &a[*k + i__ + i__ * a_dim1], &c__1, &
+		work[1], &c__1, &a[*k + i__ + (*k + i__) * a_dim1], lda);
+
+	i__2 = *k + i__ + i__ * a_dim1;
+	z__1.r = -wa.r, z__1.i = -wa.i;
+	a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+	i__2 = *n;
+	for (j = *k + i__ + 1; j <= i__2; ++j) {
+	    i__3 = j + i__ * a_dim1;
+	    a[i__3].r = 0., a[i__3].i = 0.;
+/* L50: */
+	}
+/* L60: */
+    }
+
+/*     Store full hermitian matrix */
+
+    i__1 = *n;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *n;
+	for (i__ = j + 1; i__ <= i__2; ++i__) {
+	    i__3 = j + i__ * a_dim1;
+	    d_cnjg(&z__1, &a[i__ + j * a_dim1]);
+	    a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L70: */
+	}
+/* L80: */
+    }
+    return 0;
+
+/*     End of ZLAGHE */
+
+} /* zlaghe_ */
+

lapack-netlib/TESTING/MATGEN/zlagsy.c

@@ -0,0 +1,796 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__3 = 3;
+static integer c__1 = 1;
+
+/* > \brief \b ZLAGSY */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE ZLAGSY( N, K, D, A, LDA, ISEED, WORK, INFO ) */
+
+/*       INTEGER            INFO, K, LDA, N */
+/*       INTEGER            ISEED( 4 ) */
+/*       DOUBLE PRECISION   D( * ) */
+/*       COMPLEX*16         A( LDA, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > ZLAGSY generates a complex symmetric matrix A, by pre- and post- */
+/* > multiplying a real diagonal matrix D with a random unitary matrix: */
+/* > A = U*D*U**T. The semi-bandwidth may then be reduced to k by */
+/* > additional unitary transformations. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] K */
+/* > \verbatim */
+/* >          K is INTEGER */
+/* >          The number of nonzero subdiagonals within the band of A. */
+/* >          0 <= K <= N-1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is DOUBLE PRECISION array, dimension (N) */
+/* >          The diagonal elements of the diagonal matrix D. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] A */
+/* > \verbatim */
+/* >          A is COMPLEX*16 array, dimension (LDA,N) */
+/* >          The generated n by n symmetric matrix A (the full matrix is */
+/* >          stored). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension (4) */
+/* >          On entry, the seed of the random number generator; the array */
+/* >          elements must be between 0 and 4095, and ISEED(4) must be */
+/* >          odd. */
+/* >          On exit, the seed is updated. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is COMPLEX*16 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 complex16_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int zlagsy_(integer *n, integer *k, doublereal *d__, 
+	doublecomplex *a, integer *lda, integer *iseed, doublecomplex *work, 
+	integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, 
+	    i__9;
+    doublereal d__1;
+    doublecomplex z__1, z__2, z__3, z__4;
+
+    /* Local variables */
+    integer i__, j;
+    doublecomplex alpha;
+    extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *, 
+	    doublecomplex *, integer *, doublecomplex *, integer *, 
+	    doublecomplex *, integer *), zscal_(integer *, doublecomplex *, 
+	    doublecomplex *, integer *);
+    extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, 
+	    doublecomplex *, integer *, doublecomplex *, integer *);
+    extern /* Subroutine */ int zgemv_(char *, integer *, integer *, 
+	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
+	    integer *, doublecomplex *, doublecomplex *, integer *), 
+	    zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, 
+	    doublecomplex *, integer *), zsymv_(char *, integer *, 
+	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
+	    integer *, doublecomplex *, doublecomplex *, integer *);
+    extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
+    integer ii, jj;
+    doublecomplex wa, wb;
+    doublereal wn;
+    extern /* Subroutine */ int xerbla_(char *, integer *), zlacgv_(
+	    integer *, doublecomplex *, integer *), zlarnv_(integer *, 
+	    integer *, integer *, doublecomplex *);
+    doublecomplex tau;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    --d__;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --iseed;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    if (*n < 0) {
+	*info = -1;
+    } else if (*k < 0 || *k > *n - 1) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    }
+    if (*info < 0) {
+	i__1 = -(*info);
+	xerbla_("ZLAGSY", &i__1);
+	return 0;
+    }
+
+/*     initialize lower triangle of A to diagonal matrix */
+
+    i__1 = *n;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *n;
+	for (i__ = j + 1; i__ <= i__2; ++i__) {
+	    i__3 = i__ + j * a_dim1;
+	    a[i__3].r = 0., a[i__3].i = 0.;
+/* L10: */
+	}
+/* L20: */
+    }
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	i__2 = i__ + i__ * a_dim1;
+	i__3 = i__;
+	a[i__2].r = d__[i__3], a[i__2].i = 0.;
+/* L30: */
+    }
+
+/*     Generate lower triangle of symmetric matrix */
+
+    for (i__ = *n - 1; i__ >= 1; --i__) {
+
+/*        generate random reflection */
+
+	i__1 = *n - i__ + 1;
+	zlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+	i__1 = *n - i__ + 1;
+	wn = dznrm2_(&i__1, &work[1], &c__1);
+	d__1 = wn / z_abs(&work[1]);
+	z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i;
+	wa.r = z__1.r, wa.i = z__1.i;
+	if (wn == 0.) {
+	    tau.r = 0., tau.i = 0.;
+	} else {
+	    z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i;
+	    wb.r = z__1.r, wb.i = z__1.i;
+	    i__1 = *n - i__;
+	    z_div(&z__1, &c_b2, &wb);
+	    zscal_(&i__1, &z__1, &work[2], &c__1);
+	    work[1].r = 1., work[1].i = 0.;
+	    z_div(&z__1, &wb, &wa);
+	    d__1 = z__1.r;
+	    tau.r = d__1, tau.i = 0.;
+	}
+
+/*        apply random reflection to A(i:n,i:n) from the left */
+/*        and the right */
+
+/*        compute  y := tau * A * conjg(u) */
+
+	i__1 = *n - i__ + 1;
+	zlacgv_(&i__1, &work[1], &c__1);
+	i__1 = *n - i__ + 1;
+	zsymv_("Lower", &i__1, &tau, &a[i__ + i__ * a_dim1], lda, &work[1], &
+		c__1, &c_b1, &work[*n + 1], &c__1);
+	i__1 = *n - i__ + 1;
+	zlacgv_(&i__1, &work[1], &c__1);
+
+/*        compute  v := y - 1/2 * tau * ( u, y ) * u */
+
+	z__3.r = -.5, z__3.i = 0.;
+	z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i + 
+		z__3.i * tau.r;
+	i__1 = *n - i__ + 1;
+	zdotc_(&z__4, &i__1, &work[1], &c__1, &work[*n + 1], &c__1);
+	z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i 
+		+ z__2.i * z__4.r;
+	alpha.r = z__1.r, alpha.i = z__1.i;
+	i__1 = *n - i__ + 1;
+	zaxpy_(&i__1, &alpha, &work[1], &c__1, &work[*n + 1], &c__1);
+
+/*        apply the transformation as a rank-2 update to A(i:n,i:n) */
+
+/*        CALL ZSYR2( 'Lower', N-I+1, -ONE, WORK, 1, WORK( N+1 ), 1, */
+/*        $               A( I, I ), LDA ) */
+
+	i__1 = *n;
+	for (jj = i__; jj <= i__1; ++jj) {
+	    i__2 = *n;
+	    for (ii = jj; ii <= i__2; ++ii) {
+		i__3 = ii + jj * a_dim1;
+		i__4 = ii + jj * a_dim1;
+		i__5 = ii - i__ + 1;
+		i__6 = *n + jj - i__ + 1;
+		z__3.r = work[i__5].r * work[i__6].r - work[i__5].i * work[
+			i__6].i, z__3.i = work[i__5].r * work[i__6].i + work[
+			i__5].i * work[i__6].r;
+		z__2.r = a[i__4].r - z__3.r, z__2.i = a[i__4].i - z__3.i;
+		i__7 = *n + ii - i__ + 1;
+		i__8 = jj - i__ + 1;
+		z__4.r = work[i__7].r * work[i__8].r - work[i__7].i * work[
+			i__8].i, z__4.i = work[i__7].r * work[i__8].i + work[
+			i__7].i * work[i__8].r;
+		z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i;
+		a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+/* L40: */
+	    }
+/* L50: */
+	}
+/* L60: */
+    }
+
+/*     Reduce number of subdiagonals to K */
+
+    i__1 = *n - 1 - *k;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+
+/*        generate reflection to annihilate A(k+i+1:n,i) */
+
+	i__2 = *n - *k - i__ + 1;
+	wn = dznrm2_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
+	d__1 = wn / z_abs(&a[*k + i__ + i__ * a_dim1]);
+	i__2 = *k + i__ + i__ * a_dim1;
+	z__1.r = d__1 * a[i__2].r, z__1.i = d__1 * a[i__2].i;
+	wa.r = z__1.r, wa.i = z__1.i;
+	if (wn == 0.) {
+	    tau.r = 0., tau.i = 0.;
+	} else {
+	    i__2 = *k + i__ + i__ * a_dim1;
+	    z__1.r = a[i__2].r + wa.r, z__1.i = a[i__2].i + wa.i;
+	    wb.r = z__1.r, wb.i = z__1.i;
+	    i__2 = *n - *k - i__;
+	    z_div(&z__1, &c_b2, &wb);
+	    zscal_(&i__2, &z__1, &a[*k + i__ + 1 + i__ * a_dim1], &c__1);
+	    i__2 = *k + i__ + i__ * a_dim1;
+	    a[i__2].r = 1., a[i__2].i = 0.;
+	    z_div(&z__1, &wb, &wa);
+	    d__1 = z__1.r;
+	    tau.r = d__1, tau.i = 0.;
+	}
+
+/*        apply reflection to A(k+i:n,i+1:k+i-1) from the left */
+
+	i__2 = *n - *k - i__ + 1;
+	i__3 = *k - 1;
+	zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + (i__ 
+		+ 1) * a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &
+		c_b1, &work[1], &c__1);
+	i__2 = *n - *k - i__ + 1;
+	i__3 = *k - 1;
+	z__1.r = -tau.r, z__1.i = -tau.i;
+	zgerc_(&i__2, &i__3, &z__1, &a[*k + i__ + i__ * a_dim1], &c__1, &work[
+		1], &c__1, &a[*k + i__ + (i__ + 1) * a_dim1], lda);
+
+/*        apply reflection to A(k+i:n,k+i:n) from the left and the right */
+
+/*        compute  y := tau * A * conjg(u) */
+
+	i__2 = *n - *k - i__ + 1;
+	zlacgv_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
+	i__2 = *n - *k - i__ + 1;
+	zsymv_("Lower", &i__2, &tau, &a[*k + i__ + (*k + i__) * a_dim1], lda, 
+		&a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &work[1], &c__1);
+	i__2 = *n - *k - i__ + 1;
+	zlacgv_(&i__2, &a[*k + i__ + i__ * a_dim1], &c__1);
+
+/*        compute  v := y - 1/2 * tau * ( u, y ) * u */
+
+	z__3.r = -.5, z__3.i = 0.;
+	z__2.r = z__3.r * tau.r - z__3.i * tau.i, z__2.i = z__3.r * tau.i + 
+		z__3.i * tau.r;
+	i__2 = *n - *k - i__ + 1;
+	zdotc_(&z__4, &i__2, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
+		c__1);
+	z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i 
+		+ z__2.i * z__4.r;
+	alpha.r = z__1.r, alpha.i = z__1.i;
+	i__2 = *n - *k - i__ + 1;
+	zaxpy_(&i__2, &alpha, &a[*k + i__ + i__ * a_dim1], &c__1, &work[1], &
+		c__1);
+
+/*        apply symmetric rank-2 update to A(k+i:n,k+i:n) */
+
+/*        CALL ZSYR2( 'Lower', N-K-I+1, -ONE, A( K+I, I ), 1, WORK, 1, */
+/*        $               A( K+I, K+I ), LDA ) */
+
+	i__2 = *n;
+	for (jj = *k + i__; jj <= i__2; ++jj) {
+	    i__3 = *n;
+	    for (ii = jj; ii <= i__3; ++ii) {
+		i__4 = ii + jj * a_dim1;
+		i__5 = ii + jj * a_dim1;
+		i__6 = ii + i__ * a_dim1;
+		i__7 = jj - *k - i__ + 1;
+		z__3.r = a[i__6].r * work[i__7].r - a[i__6].i * work[i__7].i, 
+			z__3.i = a[i__6].r * work[i__7].i + a[i__6].i * work[
+			i__7].r;
+		z__2.r = a[i__5].r - z__3.r, z__2.i = a[i__5].i - z__3.i;
+		i__8 = ii - *k - i__ + 1;
+		i__9 = jj + i__ * a_dim1;
+		z__4.r = work[i__8].r * a[i__9].r - work[i__8].i * a[i__9].i, 
+			z__4.i = work[i__8].r * a[i__9].i + work[i__8].i * a[
+			i__9].r;
+		z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i;
+		a[i__4].r = z__1.r, a[i__4].i = z__1.i;
+/* L70: */
+	    }
+/* L80: */
+	}
+
+	i__2 = *k + i__ + i__ * a_dim1;
+	z__1.r = -wa.r, z__1.i = -wa.i;
+	a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+	i__2 = *n;
+	for (j = *k + i__ + 1; j <= i__2; ++j) {
+	    i__3 = j + i__ * a_dim1;
+	    a[i__3].r = 0., a[i__3].i = 0.;
+/* L90: */
+	}
+/* L100: */
+    }
+
+/*     Store full symmetric matrix */
+
+    i__1 = *n;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = *n;
+	for (i__ = j + 1; i__ <= i__2; ++i__) {
+	    i__3 = j + i__ * a_dim1;
+	    i__4 = i__ + j * a_dim1;
+	    a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i;
+/* L110: */
+	}
+/* L120: */
+    }
+    return 0;
+
+/*     End of ZLAGSY */
+
+} /* zlagsy_ */
+

lapack-netlib/TESTING/MATGEN/zlahilb.c

@@ -0,0 +1,711 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__2 = 2;
+static doublecomplex c_b6 = {0.,0.};
+
+/* > \brief \b ZLAHILB */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE ZLAHILB( N, NRHS, A, LDA, X, LDX, B, LDB, WORK, */
+/*            INFO, PATH) */
+
+/*       INTEGER N, NRHS, LDA, LDX, LDB, INFO */
+/*       DOUBLE PRECISION WORK(N) */
+/*       COMPLEX*16 A(LDA,N), X(LDX, NRHS), B(LDB, NRHS) */
+/*       CHARACTER*3 PATH */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > ZLAHILB generates an N by N scaled Hilbert matrix in A along with */
+/* > NRHS right-hand sides in B and solutions in X such that A*X=B. */
+/* > */
+/* > The Hilbert matrix is scaled by M = LCM(1, 2, ..., 2*N-1) so that all */
+/* > entries are integers.  The right-hand sides are the first NRHS */
+/* > columns of M * the identity matrix, and the solutions are the */
+/* > first NRHS columns of the inverse Hilbert matrix. */
+/* > */
+/* > The condition number of the Hilbert matrix grows exponentially with */
+/* > its size, roughly as O(e ** (3.5*N)).  Additionally, the inverse */
+/* > Hilbert matrices beyond a relatively small dimension cannot be */
+/* > generated exactly without extra precision.  Precision is exhausted */
+/* > when the largest entry in the inverse Hilbert matrix is greater than */
+/* > 2 to the power of the number of bits in the fraction of the data type */
+/* > used plus one, which is 24 for single precision. */
+/* > */
+/* > In single, the generated solution is exact for N <= 6 and has */
+/* > small componentwise error for 7 <= N <= 11. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The dimension of the matrix A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The requested number of right-hand sides. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] A */
+/* > \verbatim */
+/* >          A is COMPLEX array, dimension (LDA, N) */
+/* >          The generated scaled Hilbert matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] X */
+/* > \verbatim */
+/* >          X is COMPLEX array, dimension (LDX, NRHS) */
+/* >          The generated exact solutions.  Currently, the first NRHS */
+/* >          columns of the inverse Hilbert matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDX */
+/* > \verbatim */
+/* >          LDX is INTEGER */
+/* >          The leading dimension of the array X.  LDX >= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB, NRHS) */
+/* >          The generated right-hand sides.  Currently, the first NRHS */
+/* >          columns of LCM(1, 2, ..., 2*N-1) * the identity matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit */
+/* >          = 1: N is too large; the data is still generated but may not */
+/* >               be not exact. */
+/* >          < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+/* > */
+/* > \param[in] PATH */
+/* > \verbatim */
+/* >          PATH is CHARACTER*3 */
+/* >          The LAPACK path name. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date November 2017 */
+
+/* > \ingroup complex16_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int zlahilb_(integer *n, integer *nrhs, doublecomplex *a, 
+	integer *lda, doublecomplex *x, integer *ldx, doublecomplex *b, 
+	integer *ldb, doublereal *work, integer *info, char *path)
+{
+    /* Initialized data */
+
+    static doublecomplex d1[8] = { {-1.,0.},{0.,1.},{-1.,-1.},{0.,-1.},{1.,0.}
+	    ,{-1.,1.},{1.,1.},{1.,-1.} };
+    static doublecomplex d2[8] = { {-1.,0.},{0.,-1.},{-1.,1.},{0.,1.},{1.,0.},
+	    {-1.,-1.},{1.,-1.},{1.,1.} };
+    static doublecomplex invd1[8] = { {-1.,0.},{0.,-1.},{-.5,.5},{0.,1.},{1.,
+	    0.},{-.5,-.5},{.5,-.5},{.5,.5} };
+    static doublecomplex invd2[8] = { {-1.,0.},{0.,1.},{-.5,-.5},{0.,-1.},{1.,
+	    0.},{-.5,.5},{.5,.5},{.5,-.5} };
+
+    /* System generated locals */
+    integer a_dim1, a_offset, x_dim1, x_offset, b_dim1, b_offset, i__1, i__2, 
+	    i__3, i__4, i__5;
+    doublereal d__1;
+    doublecomplex z__1, z__2;
+
+    /* Local variables */
+    integer i__, j, m, r__;
+    char c2[2];
+    integer ti, tm;
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    extern logical lsamen_(integer *, char *, char *);
+    extern /* Subroutine */ int zlaset_(char *, integer *, integer *, 
+	    doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+    doublecomplex tmp;
+
+
+/*  -- LAPACK test routine (version 3.8.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     November 2017 */
+
+
+/*  ===================================================================== */
+/*     NMAX_EXACT   the largest dimension where the generated data is */
+/*                  exact. */
+/*     NMAX_APPROX  the largest dimension where the generated data has */
+/*                  a small componentwise relative error. */
+/*     ??? complex uses how many bits ??? */
+
+/*     d's are generated from random permutation of those eight elements. */
+    /* Parameter adjustments */
+    --work;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    x_dim1 = *ldx;
+    x_offset = 1 + x_dim1 * 1;
+    x -= x_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+
+    /* Function Body */
+    s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
+
+/*     Test the input arguments */
+
+    *info = 0;
+    if (*n < 0 || *n > 11) {
+	*info = -1;
+    } else if (*nrhs < 0) {
+	*info = -2;
+    } else if (*lda < *n) {
+	*info = -4;
+    } else if (*ldx < *n) {
+	*info = -6;
+    } else if (*ldb < *n) {
+	*info = -8;
+    }
+    if (*info < 0) {
+	i__1 = -(*info);
+	xerbla_("ZLAHILB", &i__1);
+	return 0;
+    }
+    if (*n > 6) {
+	*info = 1;
+    }
+
+/*     Compute M = the LCM of the integers [1, 2*N-1].  The largest */
+/*     reasonable N is small enough that integers suffice (up to N = 11). */
+    m = 1;
+    i__1 = (*n << 1) - 1;
+    for (i__ = 2; i__ <= i__1; ++i__) {
+	tm = m;
+	ti = i__;
+	r__ = tm % ti;
+	while(r__ != 0) {
+	    tm = ti;
+	    ti = r__;
+	    r__ = tm % ti;
+	}
+	m = m / ti * i__;
+    }
+
+/*     Generate the scaled Hilbert matrix in A */
+/*     If we are testing SY routines, */
+/*        take D1_i = D2_i, else, D1_i = D2_i* */
+    if (lsamen_(&c__2, c2, "SY")) {
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    i__2 = *n;
+	    for (i__ = 1; i__ <= i__2; ++i__) {
+		i__3 = i__ + j * a_dim1;
+		i__4 = j % 8;
+		d__1 = (doublereal) m / (i__ + j - 1);
+		z__2.r = d__1 * d1[i__4].r, z__2.i = d__1 * d1[i__4].i;
+		i__5 = i__ % 8;
+		z__1.r = z__2.r * d1[i__5].r - z__2.i * d1[i__5].i, z__1.i = 
+			z__2.r * d1[i__5].i + z__2.i * d1[i__5].r;
+		a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+	    }
+	}
+    } else {
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    i__2 = *n;
+	    for (i__ = 1; i__ <= i__2; ++i__) {
+		i__3 = i__ + j * a_dim1;
+		i__4 = j % 8;
+		d__1 = (doublereal) m / (i__ + j - 1);
+		z__2.r = d__1 * d1[i__4].r, z__2.i = d__1 * d1[i__4].i;
+		i__5 = i__ % 8;
+		z__1.r = z__2.r * d2[i__5].r - z__2.i * d2[i__5].i, z__1.i = 
+			z__2.r * d2[i__5].i + z__2.i * d2[i__5].r;
+		a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+	    }
+	}
+    }
+
+/*     Generate matrix B as simply the first NRHS columns of M * the */
+/*     identity. */
+    d__1 = (doublereal) m;
+    tmp.r = d__1, tmp.i = 0.;
+    zlaset_("Full", n, nrhs, &c_b6, &tmp, &b[b_offset], ldb);
+
+/*     Generate the true solutions in X.  Because B = the first NRHS */
+/*     columns of M*I, the true solutions are just the first NRHS columns */
+/*     of the inverse Hilbert matrix. */
+    work[1] = (doublereal) (*n);
+    i__1 = *n;
+    for (j = 2; j <= i__1; ++j) {
+	work[j] = work[j - 1] / (j - 1) * (j - 1 - *n) / (j - 1) * (*n + j - 
+		1);
+    }
+/*     If we are testing SY routines, */
+/*           take D1_i = D2_i, else, D1_i = D2_i* */
+    if (lsamen_(&c__2, c2, "SY")) {
+	i__1 = *nrhs;
+	for (j = 1; j <= i__1; ++j) {
+	    i__2 = *n;
+	    for (i__ = 1; i__ <= i__2; ++i__) {
+		i__3 = i__ + j * x_dim1;
+		i__4 = j % 8;
+		d__1 = work[i__] * work[j] / (i__ + j - 1);
+		z__2.r = d__1 * invd1[i__4].r, z__2.i = d__1 * invd1[i__4].i;
+		i__5 = i__ % 8;
+		z__1.r = z__2.r * invd1[i__5].r - z__2.i * invd1[i__5].i, 
+			z__1.i = z__2.r * invd1[i__5].i + z__2.i * invd1[i__5]
+			.r;
+		x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+	    }
+	}
+    } else {
+	i__1 = *nrhs;
+	for (j = 1; j <= i__1; ++j) {
+	    i__2 = *n;
+	    for (i__ = 1; i__ <= i__2; ++i__) {
+		i__3 = i__ + j * x_dim1;
+		i__4 = j % 8;
+		d__1 = work[i__] * work[j] / (i__ + j - 1);
+		z__2.r = d__1 * invd2[i__4].r, z__2.i = d__1 * invd2[i__4].i;
+		i__5 = i__ % 8;
+		z__1.r = z__2.r * invd1[i__5].r - z__2.i * invd1[i__5].i, 
+			z__1.i = z__2.r * invd1[i__5].i + z__2.i * invd1[i__5]
+			.r;
+		x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+	    }
+	}
+    }
+    return 0;
+} /* zlahilb_ */
+

lapack-netlib/TESTING/MATGEN/zlahilb.f

@@ -166,13 +166,6 @@
 *
 *     d's are generated from random permutation of those eight elements.
       COMPLEX*16 d1(8), d2(8), invd1(8), invd2(8)
-      DATA D1 /(-1,0),(0,1),(-1,-1),(0,-1),(1,0),(-1,1),(1,1),(1,-1)/
-      DATA D2 /(-1,0),(0,-1),(-1,1),(0,1),(1,0),(-1,-1),(1,-1),(1,1)/
-
-      DATA INVD1 /(-1,0),(0,-1),(-.5,.5),(0,1),(1,0),
-     $     (-.5,-.5),(.5,-.5),(.5,.5)/
-      DATA INVD2 /(-1,0),(0,1),(-.5,-.5),(0,-1),(1,0),
-     $     (-.5,.5),(.5,.5),(.5,-.5)/
 *     ..
 *     .. External Subroutines ..
       EXTERNAL XERBLA
@@ -181,6 +174,14 @@
       EXTERNAL ZLASET, LSAMEN
       INTRINSIC DBLE
       LOGICAL LSAMEN
+      
+      DATA D1 /(-1,0),(0,1),(-1,-1),(0,-1),(1,0),(-1,1),(1,1),(1,-1)/
+      DATA D2 /(-1,0),(0,-1),(-1,1),(0,1),(1,0),(-1,-1),(1,-1),(1,1)/
+
+      DATA INVD1 /(-1,0),(0,-1),(-.5,.5),(0,1),(1,0),
+     $     (-.5,-.5),(.5,-.5),(.5,.5)/
+      DATA INVD2 /(-1,0),(0,1),(-.5,-.5),(0,-1),(1,0),
+     $     (-.5,.5),(.5,.5),(.5,-.5)/
 *     ..
 *     .. Executable Statements ..
       C2 = PATH( 2: 3 )

lapack-netlib/TESTING/MATGEN/zlakf2.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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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.};
+
+/* > \brief \b ZLAKF2 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE ZLAKF2( M, N, A, LDA, B, D, E, Z, LDZ ) */
+
+/*       INTEGER            LDA, LDZ, M, N */
+/*       COMPLEX*16         A( LDA, * ), B( LDA, * ), D( LDA, * ), */
+/*      $                   E( LDA, * ), Z( LDZ, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > Form the 2*M*N by 2*M*N matrix */
+/* > */
+/* >        Z = [ kron(In, A)  -kron(B', Im) ] */
+/* >            [ kron(In, D)  -kron(E', Im) ], */
+/* > */
+/* > where In is the identity matrix of size n and X' is the transpose */
+/* > of X. kron(X, Y) is the Kronecker product between the matrices X */
+/* > and Y. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          Size of matrix, must be >= 1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          Size of matrix, must be >= 1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] A */
+/* > \verbatim */
+/* >          A is COMPLEX*16, dimension ( LDA, M ) */
+/* >          The matrix A in the output matrix Z. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of A, B, D, and E. ( LDA >= M+N ) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] B */
+/* > \verbatim */
+/* >          B is COMPLEX*16, dimension ( LDA, N ) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is COMPLEX*16, dimension ( LDA, M ) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] E */
+/* > \verbatim */
+/* >          E is COMPLEX*16, dimension ( LDA, N ) */
+/* > */
+/* >          The matrices used in forming the output matrix Z. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Z */
+/* > \verbatim */
+/* >          Z is COMPLEX*16, dimension ( LDZ, 2*M*N ) */
+/* >          The resultant Kronecker M*N*2 by M*N*2 matrix (see above.) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDZ */
+/* > \verbatim */
+/* >          LDZ is INTEGER */
+/* >          The leading dimension of Z. ( LDZ >= 2*M*N ) */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complex16_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int zlakf2_(integer *m, integer *n, doublecomplex *a, 
+	integer *lda, doublecomplex *b, doublecomplex *d__, doublecomplex *e, 
+	doublecomplex *z__, integer *ldz)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, d_dim1, d_offset, e_dim1, 
+	    e_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
+    doublecomplex z__1;
+
+    /* Local variables */
+    integer i__, j, l, ik, jk, mn;
+    extern /* Subroutine */ int zlaset_(char *, integer *, integer *, 
+	    doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+    integer mn2;
+
+
+/*  -- 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 */
+
+
+/*  ==================================================================== */
+
+
+/*     Initialize Z */
+
+    /* Parameter adjustments */
+    e_dim1 = *lda;
+    e_offset = 1 + e_dim1 * 1;
+    e -= e_offset;
+    d_dim1 = *lda;
+    d_offset = 1 + d_dim1 * 1;
+    d__ -= d_offset;
+    b_dim1 = *lda;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    z_dim1 = *ldz;
+    z_offset = 1 + z_dim1 * 1;
+    z__ -= z_offset;
+
+    /* Function Body */
+    mn = *m * *n;
+    mn2 = mn << 1;
+    zlaset_("Full", &mn2, &mn2, &c_b1, &c_b1, &z__[z_offset], ldz);
+
+    ik = 1;
+    i__1 = *n;
+    for (l = 1; l <= i__1; ++l) {
+
+/*        form kron(In, A) */
+
+	i__2 = *m;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    i__3 = *m;
+	    for (j = 1; j <= i__3; ++j) {
+		i__4 = ik + i__ - 1 + (ik + j - 1) * z_dim1;
+		i__5 = i__ + j * a_dim1;
+		z__[i__4].r = a[i__5].r, z__[i__4].i = a[i__5].i;
+/* L10: */
+	    }
+/* L20: */
+	}
+
+/*        form kron(In, D) */
+
+	i__2 = *m;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    i__3 = *m;
+	    for (j = 1; j <= i__3; ++j) {
+		i__4 = ik + mn + i__ - 1 + (ik + j - 1) * z_dim1;
+		i__5 = i__ + j * d_dim1;
+		z__[i__4].r = d__[i__5].r, z__[i__4].i = d__[i__5].i;
+/* L30: */
+	    }
+/* L40: */
+	}
+
+	ik += *m;
+/* L50: */
+    }
+
+    ik = 1;
+    i__1 = *n;
+    for (l = 1; l <= i__1; ++l) {
+	jk = mn + 1;
+
+	i__2 = *n;
+	for (j = 1; j <= i__2; ++j) {
+
+/*           form -kron(B', Im) */
+
+	    i__3 = *m;
+	    for (i__ = 1; i__ <= i__3; ++i__) {
+		i__4 = ik + i__ - 1 + (jk + i__ - 1) * z_dim1;
+		i__5 = j + l * b_dim1;
+		z__1.r = -b[i__5].r, z__1.i = -b[i__5].i;
+		z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
+/* L60: */
+	    }
+
+/*           form -kron(E', Im) */
+
+	    i__3 = *m;
+	    for (i__ = 1; i__ <= i__3; ++i__) {
+		i__4 = ik + mn + i__ - 1 + (jk + i__ - 1) * z_dim1;
+		i__5 = j + l * e_dim1;
+		z__1.r = -e[i__5].r, z__1.i = -e[i__5].i;
+		z__[i__4].r = z__1.r, z__[i__4].i = z__1.i;
+/* L70: */
+	    }
+
+	    jk += *m;
+/* L80: */
+	}
+
+	ik += *m;
+/* L90: */
+    }
+
+    return 0;
+
+/*     End of ZLAKF2 */
+
+} /* zlakf2_ */
+

lapack-netlib/TESTING/MATGEN/zlarge.c

@@ -0,0 +1,587 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__3 = 3;
+static integer c__1 = 1;
+
+/* > \brief \b ZLARGE */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE ZLARGE( N, A, LDA, ISEED, WORK, INFO ) */
+
+/*       INTEGER            INFO, LDA, N */
+/*       INTEGER            ISEED( 4 ) */
+/*       COMPLEX*16         A( LDA, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > ZLARGE pre- and post-multiplies a complex general n by n matrix A */
+/* > with a random unitary matrix: A = U*D*U'. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is COMPLEX*16 array, dimension (LDA,N) */
+/* >          On entry, the original n by n matrix A. */
+/* >          On exit, A is overwritten by U*A*U' for some random */
+/* >          unitary matrix U. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension (4) */
+/* >          On entry, the seed of the random number generator; the array */
+/* >          elements must be between 0 and 4095, and ISEED(4) must be */
+/* >          odd. */
+/* >          On exit, the seed is updated. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is COMPLEX*16 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 complex16_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int zlarge_(integer *n, doublecomplex *a, integer *lda, 
+	integer *iseed, doublecomplex *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1;
+    doublereal d__1;
+    doublecomplex z__1;
+
+    /* Local variables */
+    integer i__;
+    extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *, 
+	    doublecomplex *, integer *, doublecomplex *, integer *, 
+	    doublecomplex *, integer *), zscal_(integer *, doublecomplex *, 
+	    doublecomplex *, integer *), zgemv_(char *, integer *, integer *, 
+	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
+	    integer *, doublecomplex *, doublecomplex *, integer *);
+    extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
+    doublecomplex wa, wb;
+    doublereal wn;
+    extern /* Subroutine */ int xerbla_(char *, integer *), zlarnv_(
+	    integer *, integer *, integer *, doublecomplex *);
+    doublecomplex tau;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --iseed;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    if (*n < 0) {
+	*info = -1;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -3;
+    }
+    if (*info < 0) {
+	i__1 = -(*info);
+	xerbla_("ZLARGE", &i__1);
+	return 0;
+    }
+
+/*     pre- and post-multiply A by random unitary matrix */
+
+    for (i__ = *n; i__ >= 1; --i__) {
+
+/*        generate random reflection */
+
+	i__1 = *n - i__ + 1;
+	zlarnv_(&c__3, &iseed[1], &i__1, &work[1]);
+	i__1 = *n - i__ + 1;
+	wn = dznrm2_(&i__1, &work[1], &c__1);
+	d__1 = wn / z_abs(&work[1]);
+	z__1.r = d__1 * work[1].r, z__1.i = d__1 * work[1].i;
+	wa.r = z__1.r, wa.i = z__1.i;
+	if (wn == 0.) {
+	    tau.r = 0., tau.i = 0.;
+	} else {
+	    z__1.r = work[1].r + wa.r, z__1.i = work[1].i + wa.i;
+	    wb.r = z__1.r, wb.i = z__1.i;
+	    i__1 = *n - i__;
+	    z_div(&z__1, &c_b2, &wb);
+	    zscal_(&i__1, &z__1, &work[2], &c__1);
+	    work[1].r = 1., work[1].i = 0.;
+	    z_div(&z__1, &wb, &wa);
+	    d__1 = z__1.r;
+	    tau.r = d__1, tau.i = 0.;
+	}
+
+/*        multiply A(i:n,1:n) by random reflection from the left */
+
+	i__1 = *n - i__ + 1;
+	zgemv_("Conjugate transpose", &i__1, n, &c_b2, &a[i__ + a_dim1], lda, 
+		&work[1], &c__1, &c_b1, &work[*n + 1], &c__1);
+	i__1 = *n - i__ + 1;
+	z__1.r = -tau.r, z__1.i = -tau.i;
+	zgerc_(&i__1, n, &z__1, &work[1], &c__1, &work[*n + 1], &c__1, &a[i__ 
+		+ a_dim1], lda);
+
+/*        multiply A(1:n,i:n) by random reflection from the right */
+
+	i__1 = *n - i__ + 1;
+	zgemv_("No transpose", n, &i__1, &c_b2, &a[i__ * a_dim1 + 1], lda, &
+		work[1], &c__1, &c_b1, &work[*n + 1], &c__1);
+	i__1 = *n - i__ + 1;
+	z__1.r = -tau.r, z__1.i = -tau.i;
+	zgerc_(n, &i__1, &z__1, &work[*n + 1], &c__1, &work[1], &c__1, &a[i__ 
+		* a_dim1 + 1], lda);
+/* L10: */
+    }
+    return 0;
+
+/*     End of ZLARGE */
+
+} /* zlarge_ */
+

lapack-netlib/TESTING/MATGEN/zlarnd.c

@@ -0,0 +1,542 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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)
+*/
+
+
+
+/* > \brief \b ZLARND */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       COMPLEX*16   FUNCTION ZLARND( IDIST, ISEED ) */
+
+/*       INTEGER            IDIST */
+/*       INTEGER            ISEED( 4 ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > ZLARND returns a random complex number from a uniform or normal */
+/* > distribution. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] IDIST */
+/* > \verbatim */
+/* >          IDIST is INTEGER */
+/* >          Specifies the distribution of the random numbers: */
+/* >          = 1:  real and imaginary parts each uniform (0,1) */
+/* >          = 2:  real and imaginary parts each uniform (-1,1) */
+/* >          = 3:  real and imaginary parts each normal (0,1) */
+/* >          = 4:  uniformly distributed on the disc abs(z) <= 1 */
+/* >          = 5:  uniformly distributed on the circle abs(z) = 1 */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension (4) */
+/* >          On entry, the seed of the random number generator; the array */
+/* >          elements must be between 0 and 4095, and ISEED(4) must be */
+/* >          odd. */
+/* >          On exit, the seed is updated. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complex16_matgen */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  This routine calls the auxiliary routine DLARAN to generate a random */
+/* >  real number from a uniform (0,1) distribution. The Box-Muller method */
+/* >  is used to transform numbers from a uniform to a normal distribution. */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+// VOID zlarnd_(doublecomplex * ret_val, integer *idist, integer *iseed)
+
+doublecomplex zlarnd_(integer *idist, 
+	integer *iseed)
+{
+    /* System generated locals */
+    doublereal d__1, d__2;
+    doublecomplex z__1, z__2, z__3;
+    doublecomplex *ret_val =(doublecomplex*)malloc(sizeof(doublecomplex));
+    /* Local variables */
+    doublereal t1, t2;
+    extern doublereal dlaran_(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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Generate a pair of real random numbers from a uniform (0,1) */
+/*     distribution */
+
+    /* Parameter adjustments */
+    --iseed;
+//fprintf(stderr,"iseed %d %d %d %d\n", iseed[1], iseed[2], iseed[3],iseed[4]);
+    /* Function Body */
+    t1 = dlaran_(&iseed[1]);
+    t2 = dlaran_(&iseed[1]);
+
+    if (*idist == 1) {
+
+/*        real and imaginary parts each uniform (0,1) */
+
+	z__1.r = t1, z__1.i = t2;
+	 ret_val->r = z__1.r,  ret_val->i = z__1.i;
+    } else if (*idist == 2) {
+
+/*        real and imaginary parts each uniform (-1,1) */
+
+	d__1 = t1 * 2. - 1.;
+	d__2 = t2 * 2. - 1.;
+	z__1.r = d__1, z__1.i = d__2;
+	 ret_val->r = z__1.r,  ret_val->i = z__1.i;
+    } else if (*idist == 3) {
+
+/*        real and imaginary parts each normal (0,1) */
+
+	d__1 = sqrt(log(t1) * -2.);
+	d__2 = t2 * 6.2831853071795864769252867663;
+	z__3.r = 0., z__3.i = d__2;
+	z_exp(&z__2, &z__3);
+	z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+	 ret_val->r = z__1.r,  ret_val->i = z__1.i;
+    } else if (*idist == 4) {
+
+/*        uniform distribution on the unit disc abs(z) <= 1 */
+
+	d__1 = sqrt(t1);
+	d__2 = t2 * 6.2831853071795864769252867663;
+	z__3.r = 0., z__3.i = d__2;
+	z_exp(&z__2, &z__3);
+	z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i;
+	 ret_val->r = z__1.r,  ret_val->i = z__1.i;
+    } else if (*idist == 5) {
+
+/*        uniform distribution on the unit circle abs(z) = 1 */
+
+	d__1 = t2 * 6.2831853071795864769252867663;
+	z__2.r = 0., z__2.i = d__1;
+	z_exp(&z__1, &z__2);
+	 ret_val->r = z__1.r,  ret_val->i = z__1.i;
+    }
+//    fprintf(stderr,"zlarnd returning %f %f\n",ret_val->r, ret_val->i);
+    return *ret_val;
+
+/*     End of ZLARND */
+
+} /* zlarnd_ */
+

lapack-netlib/TESTING/MATGEN/zlaror.c

@@ -0,0 +1,788 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__3 = 3;
+static integer c__1 = 1;
+
+/* > \brief \b ZLAROR */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE ZLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO ) */
+
+/*       CHARACTER          INIT, SIDE */
+/*       INTEGER            INFO, LDA, M, N */
+/*       INTEGER            ISEED( 4 ) */
+/*       COMPLEX*16         A( LDA, * ), X( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* >    ZLAROR pre- or post-multiplies an M by N matrix A by a random */
+/* >    unitary matrix U, overwriting A. A may optionally be */
+/* >    initialized to the identity matrix before multiplying by U. */
+/* >    U is generated using the method of G.W. Stewart */
+/* >    ( SIAM J. Numer. Anal. 17, 1980, pp. 403-409 ). */
+/* >    (BLAS-2 version) */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] SIDE */
+/* > \verbatim */
+/* >          SIDE is CHARACTER*1 */
+/* >           SIDE specifies whether A is multiplied on the left or right */
+/* >           by U. */
+/* >       SIDE = 'L'   Multiply A on the left (premultiply) by U */
+/* >       SIDE = 'R'   Multiply A on the right (postmultiply) by UC>       SIDE = 'C'   Multiply A on the lef
+t by U and the right by UC>       SIDE = 'T'   Multiply A on the left by U and the right by U' */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] INIT */
+/* > \verbatim */
+/* >          INIT is CHARACTER*1 */
+/* >           INIT specifies whether or not A should be initialized to */
+/* >           the identity matrix. */
+/* >              INIT = 'I'   Initialize A to (a section of) the */
+/* >                           identity matrix before applying U. */
+/* >              INIT = 'N'   No initialization.  Apply U to the */
+/* >                           input matrix A. */
+/* > */
+/* >           INIT = 'I' may be used to generate square (i.e., unitary) */
+/* >           or rectangular orthogonal matrices (orthogonality being */
+/* >           in the sense of ZDOTC): */
+/* > */
+/* >           For square matrices, M=N, and SIDE many be either 'L' or */
+/* >           'R'; the rows will be orthogonal to each other, as will the */
+/* >           columns. */
+/* >           For rectangular matrices where M < N, SIDE = 'R' will */
+/* >           produce a dense matrix whose rows will be orthogonal and */
+/* >           whose columns will not, while SIDE = 'L' will produce a */
+/* >           matrix whose rows will be orthogonal, and whose first M */
+/* >           columns will be orthogonal, the remaining columns being */
+/* >           zero. */
+/* >           For matrices where M > N, just use the previous */
+/* >           explanation, interchanging 'L' and 'R' and "rows" and */
+/* >           "columns". */
+/* > */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >           Number of rows of A. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >           Number of columns of A. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >           A is COMPLEX*16 array, dimension ( LDA, N ) */
+/* >           Input and output array. Overwritten by U A ( if SIDE = 'L' ) */
+/* >           or by A U ( if SIDE = 'R' ) */
+/* >           or by U A U* ( if SIDE = 'C') */
+/* >           or by U A U' ( if SIDE = 'T') on exit. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >           Leading dimension of A. Must be at least MAX ( 1, M ). */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension ( 4 ) */
+/* >           On entry ISEED specifies the seed of the random number */
+/* >           generator. The array elements should be between 0 and 4095; */
+/* >           if not they will be reduced mod 4096.  Also, ISEED(4) must */
+/* >           be odd.  The random number generator uses a linear */
+/* >           congruential sequence limited to small integers, and so */
+/* >           should produce machine independent random numbers. The */
+/* >           values of ISEED are changed on exit, and can be used in the */
+/* >           next call to ZLAROR to continue the same random number */
+/* >           sequence. */
+/* >           Modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] X */
+/* > \verbatim */
+/* >          X is COMPLEX*16 array, dimension ( 3*MAX( M, N ) ) */
+/* >           Workspace. Of length: */
+/* >               2*M + N if SIDE = 'L', */
+/* >               2*N + M if SIDE = 'R', */
+/* >               3*N     if SIDE = 'C' or 'T'. */
+/* >           Modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >           An error flag.  It is set to: */
+/* >            0  if no error. */
+/* >            1  if ZLARND returned a bad random number (installation */
+/* >               problem) */
+/* >           -1  if SIDE is not L, R, C, or T. */
+/* >           -3  if M is negative. */
+/* >           -4  if N is negative or if SIDE is C or T and N is not equal */
+/* >               to M. */
+/* >           -6  if LDA is less than M. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complex16_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int zlaror_(char *side, char *init, integer *m, integer *n, 
+	doublecomplex *a, integer *lda, integer *iseed, doublecomplex *x, 
+	integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+    doublecomplex z__1, z__2;
+
+    /* Local variables */
+    integer kbeg, jcol;
+    doublereal xabs;
+    integer irow, j;
+    extern logical lsame_(char *, char *);
+    doublecomplex csign;
+    extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *, 
+	    doublecomplex *, integer *, doublecomplex *, integer *, 
+	    doublecomplex *, integer *), zscal_(integer *, doublecomplex *, 
+	    doublecomplex *, integer *);
+    integer ixfrm;
+    extern /* Subroutine */ int zgemv_(char *, integer *, integer *, 
+	    doublecomplex *, doublecomplex *, integer *, doublecomplex *, 
+	    integer *, doublecomplex *, doublecomplex *, integer *);
+    integer itype, nxfrm;
+    doublereal xnorm;
+    extern doublereal dznrm2_(integer *, doublecomplex *, integer *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    doublereal factor;
+    extern /* Subroutine */ int zlacgv_(integer *, doublecomplex *, integer *)
+	    ;
+    //extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *, 
+    extern doublecomplex zlarnd_(integer *, 
+	    integer *);
+    extern /* Subroutine */ int zlaset_(char *, integer *, integer *, 
+	    doublecomplex *, doublecomplex *, doublecomplex *, integer *);
+    doublecomplex xnorms;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --iseed;
+    --x;
+
+    /* Function Body */
+    *info = 0;
+    if (*n == 0 || *m == 0) {
+	return 0;
+    }
+
+    itype = 0;
+    if (lsame_(side, "L")) {
+	itype = 1;
+    } else if (lsame_(side, "R")) {
+	itype = 2;
+    } else if (lsame_(side, "C")) {
+	itype = 3;
+    } else if (lsame_(side, "T")) {
+	itype = 4;
+    }
+
+/*     Check for argument errors. */
+
+    if (itype == 0) {
+	*info = -1;
+    } else if (*m < 0) {
+	*info = -3;
+    } else if (*n < 0 || itype == 3 && *n != *m) {
+	*info = -4;
+    } else if (*lda < *m) {
+	*info = -6;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("ZLAROR", &i__1);
+	return 0;
+    }
+
+    if (itype == 1) {
+	nxfrm = *m;
+    } else {
+	nxfrm = *n;
+    }
+
+/*     Initialize A to the identity matrix if desired */
+
+    if (lsame_(init, "I")) {
+	zlaset_("Full", m, n, &c_b1, &c_b2, &a[a_offset], lda);
+    }
+
+/*     If no rotation possible, still multiply by */
+/*     a random complex number from the circle |x| = 1 */
+
+/*      2)      Compute Rotation by computing Householder */
+/*              Transformations H(2), H(3), ..., H(n).  Note that the */
+/*              order in which they are computed is irrelevant. */
+
+    i__1 = nxfrm;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = j;
+	x[i__2].r = 0., x[i__2].i = 0.;
+/* L10: */
+    }
+
+    i__1 = nxfrm;
+    for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) {
+	kbeg = nxfrm - ixfrm + 1;
+
+/*        Generate independent normal( 0, 1 ) random numbers */
+
+	i__2 = nxfrm;
+	for (j = kbeg; j <= i__2; ++j) {
+	    i__3 = j;
+	    //zlarnd_(&z__1, &c__3, &iseed[1]);
+	    z__1=zlarnd_(&c__3, &iseed[1]);
+	    x[i__3].r = z__1.r, x[i__3].i = z__1.i;
+/* L20: */
+	}
+
+/*        Generate a Householder transformation from the random vector X */
+
+	xnorm = dznrm2_(&ixfrm, &x[kbeg], &c__1);
+	xabs = z_abs(&x[kbeg]);
+	if (xabs != 0.) {
+	    i__2 = kbeg;
+	    z__1.r = x[i__2].r / xabs, z__1.i = x[i__2].i / xabs;
+	    csign.r = z__1.r, csign.i = z__1.i;
+	} else {
+	    csign.r = 1., csign.i = 0.;
+	}
+	z__1.r = xnorm * csign.r, z__1.i = xnorm * csign.i;
+	xnorms.r = z__1.r, xnorms.i = z__1.i;
+	i__2 = nxfrm + kbeg;
+	z__1.r = -csign.r, z__1.i = -csign.i;
+	x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+	factor = xnorm * (xnorm + xabs);
+	if (abs(factor) < 1e-20) {
+	    *info = 1;
+	    i__2 = -(*info);
+	    xerbla_("ZLAROR", &i__2);
+	    return 0;
+	} else {
+	    factor = 1. / factor;
+	}
+	i__2 = kbeg;
+	i__3 = kbeg;
+	z__1.r = x[i__3].r + xnorms.r, z__1.i = x[i__3].i + xnorms.i;
+	x[i__2].r = z__1.r, x[i__2].i = z__1.i;
+
+/*        Apply Householder transformation to A */
+
+	if (itype == 1 || itype == 3 || itype == 4) {
+
+/*           Apply H(k) on the left of A */
+
+	    zgemv_("C", &ixfrm, n, &c_b2, &a[kbeg + a_dim1], lda, &x[kbeg], &
+		    c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1);
+	    z__2.r = factor, z__2.i = 0.;
+	    z__1.r = -z__2.r, z__1.i = -z__2.i;
+	    zgerc_(&ixfrm, n, &z__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], &
+		    c__1, &a[kbeg + a_dim1], lda);
+
+	}
+
+	if (itype >= 2 && itype <= 4) {
+
+/*           Apply H(k)* (or H(k)') on the right of A */
+
+	    if (itype == 4) {
+		zlacgv_(&ixfrm, &x[kbeg], &c__1);
+	    }
+
+	    zgemv_("N", m, &ixfrm, &c_b2, &a[kbeg * a_dim1 + 1], lda, &x[kbeg]
+		    , &c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1);
+	    z__2.r = factor, z__2.i = 0.;
+	    z__1.r = -z__2.r, z__1.i = -z__2.i;
+	    zgerc_(m, &ixfrm, &z__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], &
+		    c__1, &a[kbeg * a_dim1 + 1], lda);
+
+	}
+/* L30: */
+    }
+
+    //zlarnd_(&z__1, &c__3, &iseed[1]);
+    z__1=zlarnd_(&c__3, &iseed[1]);
+    x[1].r = z__1.r, x[1].i = z__1.i;
+    xabs = z_abs(&x[1]);
+    if (xabs != 0.) {
+	z__1.r = x[1].r / xabs, z__1.i = x[1].i / xabs;
+	csign.r = z__1.r, csign.i = z__1.i;
+    } else {
+	csign.r = 1., csign.i = 0.;
+    }
+    i__1 = nxfrm << 1;
+    x[i__1].r = csign.r, x[i__1].i = csign.i;
+
+/*     Scale the matrix A by D. */
+
+    if (itype == 1 || itype == 3 || itype == 4) {
+	i__1 = *m;
+	for (irow = 1; irow <= i__1; ++irow) {
+	    d_cnjg(&z__1, &x[nxfrm + irow]);
+	    zscal_(n, &z__1, &a[irow + a_dim1], lda);
+/* L40: */
+	}
+    }
+
+    if (itype == 2 || itype == 3) {
+	i__1 = *n;
+	for (jcol = 1; jcol <= i__1; ++jcol) {
+	    zscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1);
+/* L50: */
+	}
+    }
+
+    if (itype == 4) {
+	i__1 = *n;
+	for (jcol = 1; jcol <= i__1; ++jcol) {
+	    d_cnjg(&z__1, &x[nxfrm + jcol]);
+	    zscal_(m, &z__1, &a[jcol * a_dim1 + 1], &c__1);
+/* L60: */
+	}
+    }
+    return 0;
+
+/*     End of ZLAROR */
+
+} /* zlaror_ */
+

lapack-netlib/TESTING/MATGEN/zlarot.c

@@ -0,0 +1,771 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__4 = 4;
+static integer c__8 = 8;
+
+/* > \brief \b ZLAROT */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE ZLAROT( LROWS, LLEFT, LRIGHT, NL, C, S, A, LDA, XLEFT, */
+/*                          XRIGHT ) */
+
+/*       LOGICAL            LLEFT, LRIGHT, LROWS */
+/*       INTEGER            LDA, NL */
+/*       COMPLEX*16         C, S, XLEFT, XRIGHT */
+/*       COMPLEX*16         A( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* >    ZLAROT applies a (Givens) rotation to two adjacent rows or */
+/* >    columns, where one element of the first and/or last column/row */
+/* >    for use on matrices stored in some format other than GE, so */
+/* >    that elements of the matrix may be used or modified for which */
+/* >    no array element is provided. */
+/* > */
+/* >    One example is a symmetric matrix in SB format (bandwidth=4), for */
+/* >    which UPLO='L':  Two adjacent rows will have the format: */
+/* > */
+/* >    row j:     C> C> C> C> C> .  .  .  . */
+/* >    row j+1:      C> C> C> C> C> .  .  .  . */
+/* > */
+/* >    '*' indicates elements for which storage is provided, */
+/* >    '.' indicates elements for which no storage is provided, but */
+/* >    are not necessarily zero; their values are determined by */
+/* >    symmetry.  ' ' indicates elements which are necessarily zero, */
+/* >     and have no storage provided. */
+/* > */
+/* >    Those columns which have two '*'s can be handled by DROT. */
+/* >    Those columns which have no '*'s can be ignored, since as long */
+/* >    as the Givens rotations are carefully applied to preserve */
+/* >    symmetry, their values are determined. */
+/* >    Those columns which have one '*' have to be handled separately, */
+/* >    by using separate variables "p" and "q": */
+/* > */
+/* >    row j:     C> C> C> C> C> p  .  .  . */
+/* >    row j+1:   q  C> C> C> C> C> .  .  .  . */
+/* > */
+/* >    The element p would have to be set correctly, then that column */
+/* >    is rotated, setting p to its new value.  The next call to */
+/* >    ZLAROT would rotate columns j and j+1, using p, and restore */
+/* >    symmetry.  The element q would start out being zero, and be */
+/* >    made non-zero by the rotation.  Later, rotations would presumably */
+/* >    be chosen to zero q out. */
+/* > */
+/* >    Typical Calling Sequences: rotating the i-th and (i+1)-st rows. */
+/* >    ------- ------- --------- */
+/* > */
+/* >      General dense matrix: */
+/* > */
+/* >              CALL ZLAROT(.TRUE.,.FALSE.,.FALSE., N, C,S, */
+/* >                      A(i,1),LDA, DUMMY, DUMMY) */
+/* > */
+/* >      General banded matrix in GB format: */
+/* > */
+/* >              j = MAX(1, i-KL ) */
+/* >              NL = MIN( N, i+KU+1 ) + 1-j */
+/* >              CALL ZLAROT( .TRUE., i-KL.GE.1, i+KU.LT.N, NL, C,S, */
+/* >                      A(KU+i+1-j,j),LDA-1, XLEFT, XRIGHT ) */
+/* > */
+/* >              [ note that i+1-j is just MIN(i,KL+1) ] */
+/* > */
+/* >      Symmetric banded matrix in SY format, bandwidth K, */
+/* >      lower triangle only: */
+/* > */
+/* >              j = MAX(1, i-K ) */
+/* >              NL = MIN( K+1, i ) + 1 */
+/* >              CALL ZLAROT( .TRUE., i-K.GE.1, .TRUE., NL, C,S, */
+/* >                      A(i,j), LDA, XLEFT, XRIGHT ) */
+/* > */
+/* >      Same, but upper triangle only: */
+/* > */
+/* >              NL = MIN( K+1, N-i ) + 1 */
+/* >              CALL ZLAROT( .TRUE., .TRUE., i+K.LT.N, NL, C,S, */
+/* >                      A(i,i), LDA, XLEFT, XRIGHT ) */
+/* > */
+/* >      Symmetric banded matrix in SB format, bandwidth K, */
+/* >      lower triangle only: */
+/* > */
+/* >              [ same as for SY, except:] */
+/* >                  . . . . */
+/* >                      A(i+1-j,j), LDA-1, XLEFT, XRIGHT ) */
+/* > */
+/* >              [ note that i+1-j is just MIN(i,K+1) ] */
+/* > */
+/* >      Same, but upper triangle only: */
+/* >                  . . . */
+/* >                      A(K+1,i), LDA-1, XLEFT, XRIGHT ) */
+/* > */
+/* >      Rotating columns is just the transpose of rotating rows, except */
+/* >      for GB and SB: (rotating columns i and i+1) */
+/* > */
+/* >      GB: */
+/* >              j = MAX(1, i-KU ) */
+/* >              NL = MIN( N, i+KL+1 ) + 1-j */
+/* >              CALL ZLAROT( .TRUE., i-KU.GE.1, i+KL.LT.N, NL, C,S, */
+/* >                      A(KU+j+1-i,i),LDA-1, XTOP, XBOTTM ) */
+/* > */
+/* >              [note that KU+j+1-i is just MAX(1,KU+2-i)] */
+/* > */
+/* >      SB: (upper triangle) */
+/* > */
+/* >                   . . . . . . */
+/* >                      A(K+j+1-i,i),LDA-1, XTOP, XBOTTM ) */
+/* > */
+/* >      SB: (lower triangle) */
+/* > */
+/* >                   . . . . . . */
+/* >                      A(1,i),LDA-1, XTOP, XBOTTM ) */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \verbatim */
+/* >  LROWS  - LOGICAL */
+/* >           If .TRUE., then ZLAROT will rotate two rows.  If .FALSE., */
+/* >           then it will rotate two columns. */
+/* >           Not modified. */
+/* > */
+/* >  LLEFT  - LOGICAL */
+/* >           If .TRUE., then XLEFT will be used instead of the */
+/* >           corresponding element of A for the first element in the */
+/* >           second row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) */
+/* >           If .FALSE., then the corresponding element of A will be */
+/* >           used. */
+/* >           Not modified. */
+/* > */
+/* >  LRIGHT - LOGICAL */
+/* >           If .TRUE., then XRIGHT will be used instead of the */
+/* >           corresponding element of A for the last element in the */
+/* >           first row (if LROWS=.FALSE.) or column (if LROWS=.TRUE.) If */
+/* >           .FALSE., then the corresponding element of A will be used. */
+/* >           Not modified. */
+/* > */
+/* >  NL     - INTEGER */
+/* >           The length of the rows (if LROWS=.TRUE.) or columns (if */
+/* >           LROWS=.FALSE.) to be rotated.  If XLEFT and/or XRIGHT are */
+/* >           used, the columns/rows they are in should be included in */
+/* >           NL, e.g., if LLEFT = LRIGHT = .TRUE., then NL must be at */
+/* >           least 2.  The number of rows/columns to be rotated */
+/* >           exclusive of those involving XLEFT and/or XRIGHT may */
+/* >           not be negative, i.e., NL minus how many of LLEFT and */
+/* >           LRIGHT are .TRUE. must be at least zero; if not, XERBLA */
+/* >           will be called. */
+/* >           Not modified. */
+/* > */
+/* >  C, S   - COMPLEX*16 */
+/* >           Specify the Givens rotation to be applied.  If LROWS is */
+/* >           true, then the matrix ( c  s ) */
+/* >                                 ( _  _ ) */
+/* >                                 (-s  c )  is applied from the left; */
+/* >           if false, then the transpose (not conjugated) thereof is */
+/* >           applied from the right.  Note that in contrast to the */
+/* >           output of ZROTG or to most versions of ZROT, both C and S */
+/* >           are complex.  For a Givens rotation, |C|**2 + |S|**2 should */
+/* >           be 1, but this is not checked. */
+/* >           Not modified. */
+/* > */
+/* >  A      - COMPLEX*16 array. */
+/* >           The array containing the rows/columns to be rotated.  The */
+/* >           first element of A should be the upper left element to */
+/* >           be rotated. */
+/* >           Read and modified. */
+/* > */
+/* >  LDA    - INTEGER */
+/* >           The "effective" leading dimension of A.  If A contains */
+/* >           a matrix stored in GE, HE, or SY format, then this is just */
+/* >           the leading dimension of A as dimensioned in the calling */
+/* >           routine.  If A contains a matrix stored in band (GB, HB, or */
+/* >           SB) format, then this should be *one less* than the leading */
+/* >           dimension used in the calling routine.  Thus, if A were */
+/* >           dimensioned A(LDA,*) in ZLAROT, then A(1,j) would be the */
+/* >           j-th element in the first of the two rows to be rotated, */
+/* >           and A(2,j) would be the j-th in the second, regardless of */
+/* >           how the array may be stored in the calling routine.  [A */
+/* >           cannot, however, actually be dimensioned thus, since for */
+/* >           band format, the row number may exceed LDA, which is not */
+/* >           legal FORTRAN.] */
+/* >           If LROWS=.TRUE., then LDA must be at least 1, otherwise */
+/* >           it must be at least NL minus the number of .TRUE. values */
+/* >           in XLEFT and XRIGHT. */
+/* >           Not modified. */
+/* > */
+/* >  XLEFT  - COMPLEX*16 */
+/* >           If LLEFT is .TRUE., then XLEFT will be used and modified */
+/* >           instead of A(2,1) (if LROWS=.TRUE.) or A(1,2) */
+/* >           (if LROWS=.FALSE.). */
+/* >           Read and modified. */
+/* > */
+/* >  XRIGHT - COMPLEX*16 */
+/* >           If LRIGHT is .TRUE., then XRIGHT will be used and modified */
+/* >           instead of A(1,NL) (if LROWS=.TRUE.) or A(NL,1) */
+/* >           (if LROWS=.FALSE.). */
+/* >           Read and modified. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complex16_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int zlarot_(logical *lrows, logical *lleft, logical *lright, 
+	integer *nl, doublecomplex *c__, doublecomplex *s, doublecomplex *a, 
+	integer *lda, doublecomplex *xleft, doublecomplex *xright)
+{
+    /* System generated locals */
+    integer i__1, i__2, i__3, i__4;
+    doublecomplex z__1, z__2, z__3, z__4, z__5, z__6;
+
+    /* Local variables */
+    integer iinc, j, inext;
+    doublecomplex tempx;
+    integer ix, iy, nt;
+    doublecomplex xt[2], yt[2];
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    integer iyt;
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Set up indices, arrays for ends */
+
+    /* Parameter adjustments */
+    --a;
+
+    /* Function Body */
+    if (*lrows) {
+	iinc = *lda;
+	inext = 1;
+    } else {
+	iinc = 1;
+	inext = *lda;
+    }
+
+    if (*lleft) {
+	nt = 1;
+	ix = iinc + 1;
+	iy = *lda + 2;
+	xt[0].r = a[1].r, xt[0].i = a[1].i;
+	yt[0].r = xleft->r, yt[0].i = xleft->i;
+    } else {
+	nt = 0;
+	ix = 1;
+	iy = inext + 1;
+    }
+
+    if (*lright) {
+	iyt = inext + 1 + (*nl - 1) * iinc;
+	++nt;
+	i__1 = nt - 1;
+	xt[i__1].r = xright->r, xt[i__1].i = xright->i;
+	i__1 = nt - 1;
+	i__2 = iyt;
+	yt[i__1].r = a[i__2].r, yt[i__1].i = a[i__2].i;
+    }
+
+/*     Check for errors */
+
+    if (*nl < nt) {
+	xerbla_("ZLAROT", &c__4);
+	return 0;
+    }
+    if (*lda <= 0 || ! (*lrows) && *lda < *nl - nt) {
+	xerbla_("ZLAROT", &c__8);
+	return 0;
+    }
+
+/*     Rotate */
+
+/*     ZROT( NL-NT, A(IX),IINC, A(IY),IINC, C, S ) with complex C, S */
+
+    i__1 = *nl - nt - 1;
+    for (j = 0; j <= i__1; ++j) {
+	i__2 = ix + j * iinc;
+	z__2.r = c__->r * a[i__2].r - c__->i * a[i__2].i, z__2.i = c__->r * a[
+		i__2].i + c__->i * a[i__2].r;
+	i__3 = iy + j * iinc;
+	z__3.r = s->r * a[i__3].r - s->i * a[i__3].i, z__3.i = s->r * a[i__3]
+		.i + s->i * a[i__3].r;
+	z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+	tempx.r = z__1.r, tempx.i = z__1.i;
+	i__2 = iy + j * iinc;
+	d_cnjg(&z__4, s);
+	z__3.r = -z__4.r, z__3.i = -z__4.i;
+	i__3 = ix + j * iinc;
+	z__2.r = z__3.r * a[i__3].r - z__3.i * a[i__3].i, z__2.i = z__3.r * a[
+		i__3].i + z__3.i * a[i__3].r;
+	d_cnjg(&z__6, c__);
+	i__4 = iy + j * iinc;
+	z__5.r = z__6.r * a[i__4].r - z__6.i * a[i__4].i, z__5.i = z__6.r * a[
+		i__4].i + z__6.i * a[i__4].r;
+	z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+	a[i__2].r = z__1.r, a[i__2].i = z__1.i;
+	i__2 = ix + j * iinc;
+	a[i__2].r = tempx.r, a[i__2].i = tempx.i;
+/* L10: */
+    }
+
+/*     ZROT( NT, XT,1, YT,1, C, S ) with complex C, S */
+
+    i__1 = nt;
+    for (j = 1; j <= i__1; ++j) {
+	i__2 = j - 1;
+	z__2.r = c__->r * xt[i__2].r - c__->i * xt[i__2].i, z__2.i = c__->r * 
+		xt[i__2].i + c__->i * xt[i__2].r;
+	i__3 = j - 1;
+	z__3.r = s->r * yt[i__3].r - s->i * yt[i__3].i, z__3.i = s->r * yt[
+		i__3].i + s->i * yt[i__3].r;
+	z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+	tempx.r = z__1.r, tempx.i = z__1.i;
+	i__2 = j - 1;
+	d_cnjg(&z__4, s);
+	z__3.r = -z__4.r, z__3.i = -z__4.i;
+	i__3 = j - 1;
+	z__2.r = z__3.r * xt[i__3].r - z__3.i * xt[i__3].i, z__2.i = z__3.r * 
+		xt[i__3].i + z__3.i * xt[i__3].r;
+	d_cnjg(&z__6, c__);
+	i__4 = j - 1;
+	z__5.r = z__6.r * yt[i__4].r - z__6.i * yt[i__4].i, z__5.i = z__6.r * 
+		yt[i__4].i + z__6.i * yt[i__4].r;
+	z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i;
+	yt[i__2].r = z__1.r, yt[i__2].i = z__1.i;
+	i__2 = j - 1;
+	xt[i__2].r = tempx.r, xt[i__2].i = tempx.i;
+/* L20: */
+    }
+
+/*     Stuff values back into XLEFT, XRIGHT, etc. */
+
+    if (*lleft) {
+	a[1].r = xt[0].r, a[1].i = xt[0].i;
+	xleft->r = yt[0].r, xleft->i = yt[0].i;
+    }
+
+    if (*lright) {
+	i__1 = nt - 1;
+	xright->r = xt[i__1].r, xright->i = xt[i__1].i;
+	i__1 = iyt;
+	i__2 = nt - 1;
+	a[i__1].r = yt[i__2].r, a[i__1].i = yt[i__2].i;
+    }
+
+    return 0;
+
+/*     End of ZLAROT */
+
+} /* zlarot_ */
+

lapack-netlib/TESTING/MATGEN/zlatm1.c

@@ -0,0 +1,731 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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__3 = 3;
+
+/* > \brief \b ZLATM1 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE ZLATM1( MODE, COND, IRSIGN, IDIST, ISEED, D, N, INFO ) */
+
+/*       INTEGER            IDIST, INFO, IRSIGN, MODE, N */
+/*       DOUBLE PRECISION   COND */
+/*       INTEGER            ISEED( 4 ) */
+/*       COMPLEX*16         D( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* >    ZLATM1 computes the entries of D(1..N) as specified by */
+/* >    MODE, COND and IRSIGN. IDIST and ISEED determine the generation */
+/* >    of random numbers. ZLATM1 is called by ZLATMR to generate */
+/* >    random test matrices for LAPACK programs. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] MODE */
+/* > \verbatim */
+/* >          MODE is INTEGER */
+/* >           On entry describes how D is to be computed: */
+/* >           MODE = 0 means do not change D. */
+/* >           MODE = 1 sets D(1)=1 and D(2:N)=1.0/COND */
+/* >           MODE = 2 sets D(1:N-1)=1 and D(N)=1.0/COND */
+/* >           MODE = 3 sets D(I)=COND**(-(I-1)/(N-1)) */
+/* >           MODE = 4 sets D(i)=1 - (i-1)/(N-1)*(1 - 1/COND) */
+/* >           MODE = 5 sets D to random numbers in the range */
+/* >                    ( 1/COND , 1 ) such that their logarithms */
+/* >                    are uniformly distributed. */
+/* >           MODE = 6 set D to random numbers from same distribution */
+/* >                    as the rest of the matrix. */
+/* >           MODE < 0 has the same meaning as ABS(MODE), except that */
+/* >              the order of the elements of D is reversed. */
+/* >           Thus if MODE is positive, D has entries ranging from */
+/* >              1 to 1/COND, if negative, from 1/COND to 1, */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] COND */
+/* > \verbatim */
+/* >          COND is DOUBLE PRECISION */
+/* >           On entry, used as described under MODE above. */
+/* >           If used, it must be >= 1. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IRSIGN */
+/* > \verbatim */
+/* >          IRSIGN is INTEGER */
+/* >           On entry, if MODE neither -6, 0 nor 6, determines sign of */
+/* >           entries of D */
+/* >           0 => leave entries of D unchanged */
+/* >           1 => multiply each entry of D by random complex number */
+/* >                uniformly distributed with absolute value 1 */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IDIST */
+/* > \verbatim */
+/* >          IDIST is INTEGER */
+/* >           On entry, IDIST specifies the type of distribution to be */
+/* >           used to generate a random matrix . */
+/* >           1 => real and imaginary parts each UNIFORM( 0, 1 ) */
+/* >           2 => real and imaginary parts each UNIFORM( -1, 1 ) */
+/* >           3 => real and imaginary parts each NORMAL( 0, 1 ) */
+/* >           4 => complex number uniform in DISK( 0, 1 ) */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array, dimension ( 4 ) */
+/* >           On entry ISEED specifies the seed of the random number */
+/* >           generator. The random number generator uses a */
+/* >           linear congruential sequence limited to small */
+/* >           integers, and so should produce machine independent */
+/* >           random numbers. The values of ISEED are changed on */
+/* >           exit, and can be used in the next call to ZLATM1 */
+/* >           to continue the same random number sequence. */
+/* >           Changed on exit. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] D */
+/* > \verbatim */
+/* >          D is COMPLEX*16 array, dimension ( N ) */
+/* >           Array to be computed according to MODE, COND and IRSIGN. */
+/* >           May be changed on exit if MODE is nonzero. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >           Number of entries of D. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >            0  => normal termination */
+/* >           -1  => if MODE not in range -6 to 6 */
+/* >           -2  => if MODE neither -6, 0 nor 6, and */
+/* >                  IRSIGN neither 0 nor 1 */
+/* >           -3  => if MODE neither -6, 0 nor 6 and COND less than 1 */
+/* >           -4  => if MODE equals 6 or -6 and IDIST not in range 1 to 4 */
+/* >           -7  => if N negative */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complex16_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int zlatm1_(integer *mode, doublereal *cond, integer *irsign,
+	 integer *idist, integer *iseed, doublecomplex *d__, integer *n, 
+	integer *info)
+{
+    /* System generated locals */
+    integer i__1, i__2, i__3;
+    doublereal d__1;
+    doublecomplex z__1, z__2;
+
+    /* Local variables */
+    doublereal temp;
+    integer i__;
+    doublereal alpha;
+    doublecomplex ctemp;
+    extern doublereal dlaran_(integer *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    //extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *, 
+    extern doublecomplex zlarnd_(integer *, 
+	    integer *);
+    extern /* Subroutine */ int zlarnv_(integer *, integer *, integer *, 
+	    doublecomplex *);
+
+
+/*  -- 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Decode and Test the input parameters. Initialize flags & seed. */
+
+    /* Parameter adjustments */
+    --d__;
+    --iseed;
+
+    /* Function Body */
+    *info = 0;
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+/*     Set INFO if an error */
+
+    if (*mode < -6 || *mode > 6) {
+	*info = -1;
+    } else if (*mode != -6 && *mode != 0 && *mode != 6 && (*irsign != 0 && *
+	    irsign != 1)) {
+	*info = -2;
+    } else if (*mode != -6 && *mode != 0 && *mode != 6 && *cond < 1.) {
+	*info = -3;
+    } else if ((*mode == 6 || *mode == -6) && (*idist < 1 || *idist > 4)) {
+	*info = -4;
+    } else if (*n < 0) {
+	*info = -7;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("ZLATM1", &i__1);
+	return 0;
+    }
+
+/*     Compute D according to COND and MODE */
+
+    if (*mode != 0) {
+	switch (abs(*mode)) {
+	    case 1:  goto L10;
+	    case 2:  goto L30;
+	    case 3:  goto L50;
+	    case 4:  goto L70;
+	    case 5:  goto L90;
+	    case 6:  goto L110;
+	}
+
+/*        One large D value: */
+
+L10:
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = i__;
+	    d__1 = 1. / *cond;
+	    d__[i__2].r = d__1, d__[i__2].i = 0.;
+/* L20: */
+	}
+	d__[1].r = 1., d__[1].i = 0.;
+	goto L120;
+
+/*        One small D value: */
+
+L30:
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = i__;
+	    d__[i__2].r = 1., d__[i__2].i = 0.;
+/* L40: */
+	}
+	i__1 = *n;
+	d__1 = 1. / *cond;
+	d__[i__1].r = d__1, d__[i__1].i = 0.;
+	goto L120;
+
+/*        Exponentially distributed D values: */
+
+L50:
+	d__[1].r = 1., d__[1].i = 0.;
+	if (*n > 1) {
+	    d__1 = -1. / (doublereal) (*n - 1);
+	    alpha = pow_dd(cond, &d__1);
+	    i__1 = *n;
+	    for (i__ = 2; i__ <= i__1; ++i__) {
+		i__2 = i__;
+		i__3 = i__ - 1;
+		d__1 = pow_di(&alpha, &i__3);
+		d__[i__2].r = d__1, d__[i__2].i = 0.;
+/* L60: */
+	    }
+	}
+	goto L120;
+
+/*        Arithmetically distributed D values: */
+
+L70:
+	d__[1].r = 1., d__[1].i = 0.;
+	if (*n > 1) {
+	    temp = 1. / *cond;
+	    alpha = (1. - temp) / (doublereal) (*n - 1);
+	    i__1 = *n;
+	    for (i__ = 2; i__ <= i__1; ++i__) {
+		i__2 = i__;
+		d__1 = (doublereal) (*n - i__) * alpha + temp;
+		d__[i__2].r = d__1, d__[i__2].i = 0.;
+/* L80: */
+	    }
+	}
+	goto L120;
+
+/*        Randomly distributed D values on ( 1/COND , 1): */
+
+L90:
+	alpha = log(1. / *cond);
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i__2 = i__;
+	    d__1 = exp(alpha * dlaran_(&iseed[1]));
+	    d__[i__2].r = d__1, d__[i__2].i = 0.;
+/* L100: */
+	}
+	goto L120;
+
+/*        Randomly distributed D values from IDIST */
+
+L110:
+	zlarnv_(idist, &iseed[1], n, &d__[1]);
+
+L120:
+
+/*        If MODE neither -6 nor 0 nor 6, and IRSIGN = 1, assign */
+/*        random signs to D */
+
+	if (*mode != -6 && *mode != 0 && *mode != 6 && *irsign == 1) {
+	    i__1 = *n;
+	    for (i__ = 1; i__ <= i__1; ++i__) {
+		//zlarnd_(&z__1, &c__3, &iseed[1]);
+		z__1=zlarnd_(&c__3, &iseed[1]);
+		ctemp.r = z__1.r, ctemp.i = z__1.i;
+		i__2 = i__;
+		i__3 = i__;
+		d__1 = z_abs(&ctemp);
+		z__2.r = ctemp.r / d__1, z__2.i = ctemp.i / d__1;
+		z__1.r = d__[i__3].r * z__2.r - d__[i__3].i * z__2.i, z__1.i =
+			 d__[i__3].r * z__2.i + d__[i__3].i * z__2.r;
+		d__[i__2].r = z__1.r, d__[i__2].i = z__1.i;
+/* L130: */
+	    }
+	}
+
+/*        Reverse if MODE < 0 */
+
+	if (*mode < 0) {
+	    i__1 = *n / 2;
+	    for (i__ = 1; i__ <= i__1; ++i__) {
+		i__2 = i__;
+		ctemp.r = d__[i__2].r, ctemp.i = d__[i__2].i;
+		i__2 = i__;
+		i__3 = *n + 1 - i__;
+		d__[i__2].r = d__[i__3].r, d__[i__2].i = d__[i__3].i;
+		i__2 = *n + 1 - i__;
+		d__[i__2].r = ctemp.r, d__[i__2].i = ctemp.i;
+/* L140: */
+	    }
+	}
+
+    }
+
+    return 0;
+
+/*     End of ZLATM1 */
+
+} /* zlatm1_ */
+

lapack-netlib/TESTING/MATGEN/zlatm2.c

@@ -0,0 +1,741 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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)
+*/
+
+
+
+/* > \brief \b ZLATM2 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       COMPLEX*16   FUNCTION ZLATM2( M, N, I, J, KL, KU, IDIST, */
+/*                        ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, SPARSE ) */
+
+
+/*       INTEGER            I, IDIST, IGRADE, IPVTNG, J, KL, KU, M, N */
+/*       DOUBLE PRECISION   SPARSE */
+
+
+/*       INTEGER            ISEED( 4 ), IWORK( * ) */
+/*       COMPLEX*16         D( * ), DL( * ), DR( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* >    ZLATM2 returns the (I,J) entry of a random matrix of dimension */
+/* >    (M, N) described by the other parameters. It is called by the */
+/* >    ZLATMR routine in order to build random test matrices. No error */
+/* >    checking on parameters is done, because this routine is called in */
+/* >    a tight loop by ZLATMR which has already checked the parameters. */
+/* > */
+/* >    Use of ZLATM2 differs from CLATM3 in the order in which the random */
+/* >    number generator is called to fill in random matrix entries. */
+/* >    With ZLATM2, the generator is called to fill in the pivoted matrix */
+/* >    columnwise. With ZLATM3, the generator is called to fill in the */
+/* >    matrix columnwise, after which it is pivoted. Thus, ZLATM3 can */
+/* >    be used to construct random matrices which differ only in their */
+/* >    order of rows and/or columns. ZLATM2 is used to construct band */
+/* >    matrices while avoiding calling the random number generator for */
+/* >    entries outside the band (and therefore generating random numbers */
+/* > */
+/* >    The matrix whose (I,J) entry is returned is constructed as */
+/* >    follows (this routine only computes one entry): */
+/* > */
+/* >      If I is outside (1..M) or J is outside (1..N), return zero */
+/* >         (this is convenient for generating matrices in band format). */
+/* > */
+/* >      Generate a matrix A with random entries of distribution IDIST. */
+/* > */
+/* >      Set the diagonal to D. */
+/* > */
+/* >      Grade the matrix, if desired, from the left (by DL) and/or */
+/* >         from the right (by DR or DL) as specified by IGRADE. */
+/* > */
+/* >      Permute, if desired, the rows and/or columns as specified by */
+/* >         IPVTNG and IWORK. */
+/* > */
+/* >      Band the matrix to have lower bandwidth KL and upper */
+/* >         bandwidth KU. */
+/* > */
+/* >      Set random entries to zero as specified by SPARSE. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >           Number of rows of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >           Number of columns of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] I */
+/* > \verbatim */
+/* >          I is INTEGER */
+/* >           Row of entry to be returned. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] J */
+/* > \verbatim */
+/* >          J is INTEGER */
+/* >           Column of entry to be returned. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KL */
+/* > \verbatim */
+/* >          KL is INTEGER */
+/* >           Lower bandwidth. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KU */
+/* > \verbatim */
+/* >          KU is INTEGER */
+/* >           Upper bandwidth. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IDIST */
+/* > \verbatim */
+/* >          IDIST is INTEGER */
+/* >           On entry, IDIST specifies the type of distribution to be */
+/* >           used to generate a random matrix . */
+/* >           1 => real and imaginary parts each UNIFORM( 0, 1 ) */
+/* >           2 => real and imaginary parts each UNIFORM( -1, 1 ) */
+/* >           3 => real and imaginary parts each NORMAL( 0, 1 ) */
+/* >           4 => complex number uniform in DISK( 0 , 1 ) */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array of dimension ( 4 ) */
+/* >           Seed for random number generator. */
+/* >           Changed on exit. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is COMPLEX*16 array of dimension ( MIN( I , J ) ) */
+/* >           Diagonal entries of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IGRADE */
+/* > \verbatim */
+/* >          IGRADE is INTEGER */
+/* >           Specifies grading of matrix as follows: */
+/* >           0  => no grading */
+/* >           1  => matrix premultiplied by diag( DL ) */
+/* >           2  => matrix postmultiplied by diag( DR ) */
+/* >           3  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by diag( DR ) */
+/* >           4  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by inv( diag( DL ) ) */
+/* >           5  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by diag( CONJG(DL) ) */
+/* >           6  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by diag( DL ) */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] DL */
+/* > \verbatim */
+/* >          DL is COMPLEX*16 array ( I or J, as appropriate ) */
+/* >           Left scale factors for grading matrix.  Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] DR */
+/* > \verbatim */
+/* >          DR is COMPLEX*16 array ( I or J, as appropriate ) */
+/* >           Right scale factors for grading matrix.  Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPVTNG */
+/* > \verbatim */
+/* >          IPVTNG is INTEGER */
+/* >           On entry specifies pivoting permutations as follows: */
+/* >           0 => none. */
+/* >           1 => row pivoting. */
+/* >           2 => column pivoting. */
+/* >           3 => full pivoting, i.e., on both sides. */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array ( I or J, as appropriate ) */
+/* >           This array specifies the permutation used. The */
+/* >           row (or column) in position K was originally in */
+/* >           position IWORK( K ). */
+/* >           This differs from IWORK for ZLATM3. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] SPARSE */
+/* > \verbatim */
+/* >          SPARSE is DOUBLE PRECISION between 0. and 1. */
+/* >           On entry specifies the sparsity of the matrix */
+/* >           if sparse matrix is to be generated. */
+/* >           SPARSE should lie between 0 and 1. */
+/* >           A uniform ( 0, 1 ) random number x is generated and */
+/* >           compared to SPARSE; if x is larger the matrix entry */
+/* >           is unchanged and if x is smaller the entry is set */
+/* >           to zero. Thus on the average a fraction SPARSE of the */
+/* >           entries will be set to zero. */
+/* >           Not modified. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date June 2016 */
+
+/* > \ingroup complex16_matgen */
+
+/*  ===================================================================== */
+/* Double Complex */ VOID zlatm2_(doublecomplex * ret_val, integer *m, 
+	integer *n, integer *i__, integer *j, integer *kl, integer *ku, 
+	integer *idist, integer *iseed, doublecomplex *d__, integer *igrade, 
+	doublecomplex *dl, doublecomplex *dr, integer *ipvtng, integer *iwork,
+	 doublereal *sparse)
+{
+    /* System generated locals */
+    integer i__1, i__2;
+    doublecomplex z__1, z__2, z__3;
+
+    /* Local variables */
+    integer isub, jsub;
+    doublecomplex ctemp;
+    extern doublereal dlaran_(integer *);
+    //extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *, 
+    extern doublecomplex zlarnd_(integer *, 
+	    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..-- */
+/*     June 2016 */
+
+
+
+
+
+/*  ===================================================================== */
+
+
+
+
+
+
+
+
+
+/* ----------------------------------------------------------------------- */
+
+
+
+/*     Check for I and J in range */
+
+    /* Parameter adjustments */
+    --iwork;
+    --dr;
+    --dl;
+    --d__;
+    --iseed;
+
+    /* Function Body */
+    if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) {
+	 ret_val->r = 0.,  ret_val->i = 0.;
+	return ;
+    }
+
+/*     Check for banding */
+
+    if (*j > *i__ + *ku || *j < *i__ - *kl) {
+	 ret_val->r = 0.,  ret_val->i = 0.;
+	return ;
+    }
+
+/*     Check for sparsity */
+
+    if (*sparse > 0.) {
+	if (dlaran_(&iseed[1]) < *sparse) {
+	     ret_val->r = 0.,  ret_val->i = 0.;
+	    return ;
+	}
+    }
+
+/*     Compute subscripts depending on IPVTNG */
+
+    if (*ipvtng == 0) {
+	isub = *i__;
+	jsub = *j;
+    } else if (*ipvtng == 1) {
+	isub = iwork[*i__];
+	jsub = *j;
+    } else if (*ipvtng == 2) {
+	isub = *i__;
+	jsub = iwork[*j];
+    } else if (*ipvtng == 3) {
+	isub = iwork[*i__];
+	jsub = iwork[*j];
+    }
+
+/*     Compute entry and grade it according to IGRADE */
+
+    if (isub == jsub) {
+	i__1 = isub;
+	ctemp.r = d__[i__1].r, ctemp.i = d__[i__1].i;
+    } else {
+	//zlarnd_(&z__1, idist, &iseed[1]);
+	z__1=zlarnd_(idist, &iseed[1]);
+	ctemp.r = z__1.r, ctemp.i = z__1.i;
+    }
+    if (*igrade == 1) {
+	i__1 = isub;
+	z__1.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__1.i = 
+		ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+	ctemp.r = z__1.r, ctemp.i = z__1.i;
+    } else if (*igrade == 2) {
+	i__1 = jsub;
+	z__1.r = ctemp.r * dr[i__1].r - ctemp.i * dr[i__1].i, z__1.i = 
+		ctemp.r * dr[i__1].i + ctemp.i * dr[i__1].r;
+	ctemp.r = z__1.r, ctemp.i = z__1.i;
+    } else if (*igrade == 3) {
+	i__1 = isub;
+	z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i = 
+		ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+	i__2 = jsub;
+	z__1.r = z__2.r * dr[i__2].r - z__2.i * dr[i__2].i, z__1.i = z__2.r * 
+		dr[i__2].i + z__2.i * dr[i__2].r;
+	ctemp.r = z__1.r, ctemp.i = z__1.i;
+    } else if (*igrade == 4 && isub != jsub) {
+	i__1 = isub;
+	z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i = 
+		ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+	z_div(&z__1, &z__2, &dl[jsub]);
+	ctemp.r = z__1.r, ctemp.i = z__1.i;
+    } else if (*igrade == 5) {
+	i__1 = isub;
+	z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i = 
+		ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+	d_cnjg(&z__3, &dl[jsub]);
+	z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i 
+		+ z__2.i * z__3.r;
+	ctemp.r = z__1.r, ctemp.i = z__1.i;
+    } else if (*igrade == 6) {
+	i__1 = isub;
+	z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i = 
+		ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+	i__2 = jsub;
+	z__1.r = z__2.r * dl[i__2].r - z__2.i * dl[i__2].i, z__1.i = z__2.r * 
+		dl[i__2].i + z__2.i * dl[i__2].r;
+	ctemp.r = z__1.r, ctemp.i = z__1.i;
+    }
+     ret_val->r = ctemp.r,  ret_val->i = ctemp.i;
+    return ;
+
+/*     End of ZLATM2 */
+
+} /* zlatm2_ */
+

lapack-netlib/TESTING/MATGEN/zlatm3.c

@@ -0,0 +1,759 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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)
+*/
+
+
+
+/* > \brief \b ZLATM3 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       COMPLEX*16   FUNCTION ZLATM3( M, N, I, J, ISUB, JSUB, KL, KU, */
+/*                        IDIST, ISEED, D, IGRADE, DL, DR, IPVTNG, IWORK, */
+/*                        SPARSE ) */
+
+
+/*       INTEGER            I, IDIST, IGRADE, IPVTNG, ISUB, J, JSUB, KL, */
+/*      $                   KU, M, N */
+/*       DOUBLE PRECISION   SPARSE */
+
+
+/*       INTEGER            ISEED( 4 ), IWORK( * ) */
+/*       COMPLEX*16         D( * ), DL( * ), DR( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* >    ZLATM3 returns the (ISUB,JSUB) entry of a random matrix of */
+/* >    dimension (M, N) described by the other parameters. (ISUB,JSUB) */
+/* >    is the final position of the (I,J) entry after pivoting */
+/* >    according to IPVTNG and IWORK. ZLATM3 is called by the */
+/* >    ZLATMR routine in order to build random test matrices. No error */
+/* >    checking on parameters is done, because this routine is called in */
+/* >    a tight loop by ZLATMR which has already checked the parameters. */
+/* > */
+/* >    Use of ZLATM3 differs from CLATM2 in the order in which the random */
+/* >    number generator is called to fill in random matrix entries. */
+/* >    With ZLATM2, the generator is called to fill in the pivoted matrix */
+/* >    columnwise. With ZLATM3, the generator is called to fill in the */
+/* >    matrix columnwise, after which it is pivoted. Thus, ZLATM3 can */
+/* >    be used to construct random matrices which differ only in their */
+/* >    order of rows and/or columns. ZLATM2 is used to construct band */
+/* >    matrices while avoiding calling the random number generator for */
+/* >    entries outside the band (and therefore generating random numbers */
+/* >    in different orders for different pivot orders). */
+/* > */
+/* >    The matrix whose (ISUB,JSUB) entry is returned is constructed as */
+/* >    follows (this routine only computes one entry): */
+/* > */
+/* >      If ISUB is outside (1..M) or JSUB is outside (1..N), return zero */
+/* >         (this is convenient for generating matrices in band format). */
+/* > */
+/* >      Generate a matrix A with random entries of distribution IDIST. */
+/* > */
+/* >      Set the diagonal to D. */
+/* > */
+/* >      Grade the matrix, if desired, from the left (by DL) and/or */
+/* >         from the right (by DR or DL) as specified by IGRADE. */
+/* > */
+/* >      Permute, if desired, the rows and/or columns as specified by */
+/* >         IPVTNG and IWORK. */
+/* > */
+/* >      Band the matrix to have lower bandwidth KL and upper */
+/* >         bandwidth KU. */
+/* > */
+/* >      Set random entries to zero as specified by SPARSE. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >           Number of rows of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >           Number of columns of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] I */
+/* > \verbatim */
+/* >          I is INTEGER */
+/* >           Row of unpivoted entry to be returned. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] J */
+/* > \verbatim */
+/* >          J is INTEGER */
+/* >           Column of unpivoted entry to be returned. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISUB */
+/* > \verbatim */
+/* >          ISUB is INTEGER */
+/* >           Row of pivoted entry to be returned. Changed on exit. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] JSUB */
+/* > \verbatim */
+/* >          JSUB is INTEGER */
+/* >           Column of pivoted entry to be returned. Changed on exit. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KL */
+/* > \verbatim */
+/* >          KL is INTEGER */
+/* >           Lower bandwidth. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KU */
+/* > \verbatim */
+/* >          KU is INTEGER */
+/* >           Upper bandwidth. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IDIST */
+/* > \verbatim */
+/* >          IDIST is INTEGER */
+/* >           On entry, IDIST specifies the type of distribution to be */
+/* >           used to generate a random matrix . */
+/* >           1 => real and imaginary parts each UNIFORM( 0, 1 ) */
+/* >           2 => real and imaginary parts each UNIFORM( -1, 1 ) */
+/* >           3 => real and imaginary parts each NORMAL( 0, 1 ) */
+/* >           4 => complex number uniform in DISK( 0 , 1 ) */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] ISEED */
+/* > \verbatim */
+/* >          ISEED is INTEGER array of dimension ( 4 ) */
+/* >           Seed for random number generator. */
+/* >           Changed on exit. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is COMPLEX*16 array of dimension ( MIN( I , J ) ) */
+/* >           Diagonal entries of matrix. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IGRADE */
+/* > \verbatim */
+/* >          IGRADE is INTEGER */
+/* >           Specifies grading of matrix as follows: */
+/* >           0  => no grading */
+/* >           1  => matrix premultiplied by diag( DL ) */
+/* >           2  => matrix postmultiplied by diag( DR ) */
+/* >           3  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by diag( DR ) */
+/* >           4  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by inv( diag( DL ) ) */
+/* >           5  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by diag( CONJG(DL) ) */
+/* >           6  => matrix premultiplied by diag( DL ) and */
+/* >                         postmultiplied by diag( DL ) */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] DL */
+/* > \verbatim */
+/* >          DL is COMPLEX*16 array ( I or J, as appropriate ) */
+/* >           Left scale factors for grading matrix.  Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] DR */
+/* > \verbatim */
+/* >          DR is COMPLEX*16 array ( I or J, as appropriate ) */
+/* >           Right scale factors for grading matrix.  Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPVTNG */
+/* > \verbatim */
+/* >          IPVTNG is INTEGER */
+/* >           On entry specifies pivoting permutations as follows: */
+/* >           0 => none. */
+/* >           1 => row pivoting. */
+/* >           2 => column pivoting. */
+/* >           3 => full pivoting, i.e., on both sides. */
+/* >           Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array ( I or J, as appropriate ) */
+/* >           This array specifies the permutation used. The */
+/* >           row (or column) originally in position K is in */
+/* >           position IWORK( K ) after pivoting. */
+/* >           This differs from IWORK for ZLATM2. Not modified. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] SPARSE */
+/* > \verbatim */
+/* >          SPARSE is DOUBLE PRECISION between 0. and 1. */
+/* >           On entry specifies the sparsity of the matrix */
+/* >           if sparse matrix is to be generated. */
+/* >           SPARSE should lie between 0 and 1. */
+/* >           A uniform ( 0, 1 ) random number x is generated and */
+/* >           compared to SPARSE; if x is larger the matrix entry */
+/* >           is unchanged and if x is smaller the entry is set */
+/* >           to zero. Thus on the average a fraction SPARSE of the */
+/* >           entries will be set to zero. */
+/* >           Not modified. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date June 2016 */
+
+/* > \ingroup complex16_matgen */
+
+/*  ===================================================================== */
+/* Double Complex */ VOID zlatm3_(doublecomplex * ret_val, integer *m, 
+	integer *n, integer *i__, integer *j, integer *isub, integer *jsub, 
+	integer *kl, integer *ku, integer *idist, integer *iseed, 
+	doublecomplex *d__, integer *igrade, doublecomplex *dl, doublecomplex 
+	*dr, integer *ipvtng, integer *iwork, doublereal *sparse)
+{
+    /* System generated locals */
+    integer i__1, i__2;
+    doublecomplex z__1, z__2, z__3;
+
+    /* Local variables */
+    doublecomplex ctemp;
+    extern doublereal dlaran_(integer *);
+    //extern /* Double Complex */ VOID zlarnd_(doublecomplex *, integer *, 
+    extern doublecomplex zlarnd_(integer *, 
+	    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..-- */
+/*     June 2016 */
+
+
+
+
+
+/*  ===================================================================== */
+
+
+
+
+
+
+
+
+
+/* ----------------------------------------------------------------------- */
+
+
+
+/*     Check for I and J in range */
+
+    /* Parameter adjustments */
+    --iwork;
+    --dr;
+    --dl;
+    --d__;
+    --iseed;
+
+    /* Function Body */
+    if (*i__ < 1 || *i__ > *m || *j < 1 || *j > *n) {
+	*isub = *i__;
+	*jsub = *j;
+	 ret_val->r = 0.,  ret_val->i = 0.;
+	return ;
+    }
+
+/*     Compute subscripts depending on IPVTNG */
+
+    if (*ipvtng == 0) {
+	*isub = *i__;
+	*jsub = *j;
+    } else if (*ipvtng == 1) {
+	*isub = iwork[*i__];
+	*jsub = *j;
+    } else if (*ipvtng == 2) {
+	*isub = *i__;
+	*jsub = iwork[*j];
+    } else if (*ipvtng == 3) {
+	*isub = iwork[*i__];
+	*jsub = iwork[*j];
+    }
+
+/*     Check for banding */
+
+    if (*jsub > *isub + *ku || *jsub < *isub - *kl) {
+	 ret_val->r = 0.,  ret_val->i = 0.;
+	return ;
+    }
+
+/*     Check for sparsity */
+
+    if (*sparse > 0.) {
+	if (dlaran_(&iseed[1]) < *sparse) {
+	     ret_val->r = 0.,  ret_val->i = 0.;
+	    return ;
+	}
+    }
+
+/*     Compute entry and grade it according to IGRADE */
+
+    if (*i__ == *j) {
+	i__1 = *i__;
+	ctemp.r = d__[i__1].r, ctemp.i = d__[i__1].i;
+    } else {
+	//zlarnd_(&z__1, idist, &iseed[1]);
+	z__1=zlarnd_(idist, &iseed[1]);
+	ctemp.r = z__1.r, ctemp.i = z__1.i;
+    }
+    if (*igrade == 1) {
+	i__1 = *i__;
+	z__1.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__1.i = 
+		ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+	ctemp.r = z__1.r, ctemp.i = z__1.i;
+    } else if (*igrade == 2) {
+	i__1 = *j;
+	z__1.r = ctemp.r * dr[i__1].r - ctemp.i * dr[i__1].i, z__1.i = 
+		ctemp.r * dr[i__1].i + ctemp.i * dr[i__1].r;
+	ctemp.r = z__1.r, ctemp.i = z__1.i;
+    } else if (*igrade == 3) {
+	i__1 = *i__;
+	z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i = 
+		ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+	i__2 = *j;
+	z__1.r = z__2.r * dr[i__2].r - z__2.i * dr[i__2].i, z__1.i = z__2.r * 
+		dr[i__2].i + z__2.i * dr[i__2].r;
+	ctemp.r = z__1.r, ctemp.i = z__1.i;
+    } else if (*igrade == 4 && *i__ != *j) {
+	i__1 = *i__;
+	z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i = 
+		ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+	z_div(&z__1, &z__2, &dl[*j]);
+	ctemp.r = z__1.r, ctemp.i = z__1.i;
+    } else if (*igrade == 5) {
+	i__1 = *i__;
+	z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i = 
+		ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+	d_cnjg(&z__3, &dl[*j]);
+	z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * z__3.i 
+		+ z__2.i * z__3.r;
+	ctemp.r = z__1.r, ctemp.i = z__1.i;
+    } else if (*igrade == 6) {
+	i__1 = *i__;
+	z__2.r = ctemp.r * dl[i__1].r - ctemp.i * dl[i__1].i, z__2.i = 
+		ctemp.r * dl[i__1].i + ctemp.i * dl[i__1].r;
+	i__2 = *j;
+	z__1.r = z__2.r * dl[i__2].r - z__2.i * dl[i__2].i, z__1.i = z__2.r * 
+		dl[i__2].i + z__2.i * dl[i__2].r;
+	ctemp.r = z__1.r, ctemp.i = z__1.i;
+    }
+     ret_val->r = ctemp.r,  ret_val->i = ctemp.i;
+    return ;
+
+/*     End of ZLATM3 */
+
+} /* zlatm3_ */
+

lapack-netlib/TESTING/MATGEN/zlatm6.c

@@ -0,0 +1,817 @@
+/* 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 r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
+#define d_log(x) (log(*(x)))
+#define d_mod(x, y) (fmod(*(x), *(y)))
+#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
+#define d_nint(x) u_nint(*(x))
+#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
+#define d_sign(a,b) u_sign(*(a),*(b))
+#define r_sign(a,b) u_sign(*(a),*(b))
+#define d_sin(x) (sin(*(x)))
+#define d_sinh(x) (sinh(*(x)))
+#define d_sqrt(x) (sqrt(*(x)))
+#define d_tan(x) (tan(*(x)))
+#define d_tanh(x) (tanh(*(x)))
+#define i_abs(x) abs(*(x))
+#define i_dnnt(x) ((integer)u_nint(*(x)))
+#define i_len(s, n) (n)
+#define i_nint(x) ((integer)u_nint(*(x)))
+#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
+#define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
+#define pow_si(B,E) spow_ui(*(B),*(E))
+#define pow_ri(B,E) spow_ui(*(B),*(E))
+#define pow_di(B,E) dpow_ui(*(B),*(E))
+#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
+#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
+#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
+#define s_cat(lpp, rpp, rnp, np, llp) { 	ftnlen i, nc, ll; char *f__rp, *lp; 	ll = (llp); lp = (lpp); 	for(i=0; i < (int)*(np); ++i) {         	nc = ll; 	        if((rnp)[i] < nc) nc = (rnp)[i]; 	        ll -= nc;         	f__rp = (rpp)[i]; 	        while(--nc >= 0) *lp++ = *(f__rp)++;         } 	while(--ll >= 0) *lp++ = ' '; }
+#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
+#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
+#define sig_die(s, kill) { exit(1); }
+#define s_stop(s, n) {exit(0);}
+static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n";
+#define z_abs(z) (cabs(Cd(z)))
+#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
+#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
+#define myexit_() break;
+#define mycycle_() continue;
+#define myceiling_(w) ceil(w)
+#define myhuge_(w) HUGE_VAL
+//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
+#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n)
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef logical (*L_fp)(...);
+#else
+typedef logical (*L_fp)();
+#endif
+
+static float spow_ui(float x, integer n) {
+	float pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+static double dpow_ui(double x, integer n) {
+	double pow=1.0; unsigned long int u;
+	if(n != 0) {
+		if(n < 0) n = -n, x = 1/x;
+		for(u = n; ; ) {
+			if(u & 01) pow *= x;
+			if(u >>= 1) x *= x;
+			else break;
+		}
+	}
+	return pow;
+}
+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 integer c__4 = 4;
+static integer c__8 = 8;
+static integer c__24 = 24;
+
+/* > \brief \b ZLATM6 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE ZLATM6( TYPE, N, A, LDA, B, X, LDX, Y, LDY, ALPHA, */
+/*                          BETA, WX, WY, S, DIF ) */
+
+/*       INTEGER            LDA, LDX, LDY, N, TYPE */
+/*       COMPLEX*16         ALPHA, BETA, WX, WY */
+/*       DOUBLE PRECISION   DIF( * ), S( * ) */
+/*       COMPLEX*16         A( LDA, * ), B( LDA, * ), X( LDX, * ), */
+/*      $                   Y( LDY, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > ZLATM6 generates test matrices for the generalized eigenvalue */
+/* > problem, their corresponding right and left eigenvector matrices, */
+/* > and also reciprocal condition numbers for all eigenvalues and */
+/* > the reciprocal condition numbers of eigenvectors corresponding to */
+/* > the 1th and 5th eigenvalues. */
+/* > */
+/* > Test Matrices */
+/* > ============= */
+/* > */
+/* > Two kinds of test matrix pairs */
+/* >          (A, B) = inverse(YH) * (Da, Db) * inverse(X) */
+/* > are used in the tests: */
+/* > */
+/* > Type 1: */
+/* >    Da = 1+a   0    0    0    0    Db = 1   0   0   0   0 */
+/* >          0   2+a   0    0    0         0   1   0   0   0 */
+/* >          0    0   3+a   0    0         0   0   1   0   0 */
+/* >          0    0    0   4+a   0         0   0   0   1   0 */
+/* >          0    0    0    0   5+a ,      0   0   0   0   1 */
+/* > and Type 2: */
+/* >    Da = 1+i   0    0       0       0    Db = 1   0   0   0   0 */
+/* >          0   1-i   0       0       0         0   1   0   0   0 */
+/* >          0    0    1       0       0         0   0   1   0   0 */
+/* >          0    0    0 (1+a)+(1+b)i  0         0   0   0   1   0 */
+/* >          0    0    0       0 (1+a)-(1+b)i,   0   0   0   0   1 . */
+/* > */
+/* > In both cases the same inverse(YH) and inverse(X) are used to compute */
+/* > (A, B), giving the exact eigenvectors to (A,B) as (YH, X): */
+/* > */
+/* > YH:  =  1    0   -y    y   -y    X =  1   0  -x  -x   x */
+/* >         0    1   -y    y   -y         0   1   x  -x  -x */
+/* >         0    0    1    0    0         0   0   1   0   0 */
+/* >         0    0    0    1    0         0   0   0   1   0 */
+/* >         0    0    0    0    1,        0   0   0   0   1 , where */
+/* > */
+/* > a, b, x and y will have all values independently of each other. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] TYPE */
+/* > \verbatim */
+/* >          TYPE is INTEGER */
+/* >          Specifies the problem type (see further details). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          Size of the matrices A and B. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] A */
+/* > \verbatim */
+/* >          A is COMPLEX*16 array, dimension (LDA, N). */
+/* >          On exit A N-by-N is initialized according to TYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of A and of B. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] B */
+/* > \verbatim */
+/* >          B is COMPLEX*16 array, dimension (LDA, N). */
+/* >          On exit B N-by-N is initialized according to TYPE. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] X */
+/* > \verbatim */
+/* >          X is COMPLEX*16 array, dimension (LDX, N). */
+/* >          On exit X is the N-by-N matrix of right eigenvectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDX */
+/* > \verbatim */
+/* >          LDX is INTEGER */
+/* >          The leading dimension of X. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Y */
+/* > \verbatim */
+/* >          Y is COMPLEX*16 array, dimension (LDY, N). */
+/* >          On exit Y is the N-by-N matrix of left eigenvectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDY */
+/* > \verbatim */
+/* >          LDY is INTEGER */
+/* >          The leading dimension of Y. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] ALPHA */
+/* > \verbatim */
+/* >          ALPHA is COMPLEX*16 */
+/* > \endverbatim */
+/* > */
+/* > \param[in] BETA */
+/* > \verbatim */
+/* >          BETA is COMPLEX*16 */
+/* > \verbatim */
+/* >          Weighting constants for matrix A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] WX */
+/* > \verbatim */
+/* >          WX is COMPLEX*16 */
+/* >          Constant for right eigenvector matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] WY */
+/* > \verbatim */
+/* >          WY is COMPLEX*16 */
+/* >          Constant for left eigenvector matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] S */
+/* > \verbatim */
+/* >          S is DOUBLE PRECISION array, dimension (N) */
+/* >          S(i) is the reciprocal condition number for eigenvalue i. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] DIF */
+/* > \verbatim */
+/* >          DIF is DOUBLE PRECISION array, dimension (N) */
+/* >          DIF(i) is the reciprocal condition number for eigenvector i. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup complex16_matgen */
+
+/*  ===================================================================== */
+/* Subroutine */ int zlatm6_(integer *type__, integer *n, doublecomplex *a, 
+	integer *lda, doublecomplex *b, doublecomplex *x, integer *ldx, 
+	doublecomplex *y, integer *ldy, doublecomplex *alpha, doublecomplex *
+	beta, doublecomplex *wx, doublecomplex *wy, doublereal *s, doublereal 
+	*dif)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, y_dim1, 
+	    y_offset, i__1, i__2, i__3;
+    doublereal d__1, d__2;
+    doublecomplex z__1, z__2, z__3, z__4;
+
+    /* Local variables */
+    integer info;
+    doublecomplex work[26];
+    integer i__, j;
+    doublecomplex z__[64]	/* was [8][8] */;
+    doublereal rwork[50];
+    extern /* Subroutine */ int zlakf2_(integer *, integer *, doublecomplex *,
+	     integer *, doublecomplex *, doublecomplex *, doublecomplex *, 
+	    doublecomplex *, integer *), zgesvd_(char *, char *, integer *, 
+	    integer *, doublecomplex *, integer *, doublereal *, 
+	    doublecomplex *, integer *, doublecomplex *, integer *, 
+	    doublecomplex *, integer *, doublereal *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, 
+	    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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Generate test problem ... */
+/*     (Da, Db) ... */
+
+    /* Parameter adjustments */
+    b_dim1 = *lda;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    x_dim1 = *ldx;
+    x_offset = 1 + x_dim1 * 1;
+    x -= x_offset;
+    y_dim1 = *ldy;
+    y_offset = 1 + y_dim1 * 1;
+    y -= y_offset;
+    --s;
+    --dif;
+
+    /* Function Body */
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	i__2 = *n;
+	for (j = 1; j <= i__2; ++j) {
+
+	    if (i__ == j) {
+		i__3 = i__ + i__ * a_dim1;
+		z__2.r = (doublereal) i__, z__2.i = 0.;
+		z__1.r = z__2.r + alpha->r, z__1.i = z__2.i + alpha->i;
+		a[i__3].r = z__1.r, a[i__3].i = z__1.i;
+		i__3 = i__ + i__ * b_dim1;
+		b[i__3].r = 1., b[i__3].i = 0.;
+	    } else {
+		i__3 = i__ + j * a_dim1;
+		a[i__3].r = 0., a[i__3].i = 0.;
+		i__3 = i__ + j * b_dim1;
+		b[i__3].r = 0., b[i__3].i = 0.;
+	    }
+
+/* L10: */
+	}
+/* L20: */
+    }
+    if (*type__ == 2) {
+	i__1 = a_dim1 + 1;
+	a[i__1].r = 1., a[i__1].i = 1.;
+	i__1 = (a_dim1 << 1) + 2;
+	d_cnjg(&z__1, &a[a_dim1 + 1]);
+	a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+	i__1 = a_dim1 * 3 + 3;
+	a[i__1].r = 1., a[i__1].i = 0.;
+	i__1 = (a_dim1 << 2) + 4;
+	z__2.r = alpha->r + 1., z__2.i = alpha->i + 0.;
+	d__1 = z__2.r;
+	z__3.r = beta->r + 1., z__3.i = beta->i + 0.;
+	d__2 = z__3.r;
+	z__1.r = d__1, z__1.i = d__2;
+	a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+	i__1 = a_dim1 * 5 + 5;
+	d_cnjg(&z__1, &a[(a_dim1 << 2) + 4]);
+	a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+    }
+
+/*     Form X and Y */
+
+    zlacpy_("F", n, n, &b[b_offset], lda, &y[y_offset], ldy);
+    i__1 = y_dim1 + 3;
+    d_cnjg(&z__2, wy);
+    z__1.r = -z__2.r, z__1.i = -z__2.i;
+    y[i__1].r = z__1.r, y[i__1].i = z__1.i;
+    i__1 = y_dim1 + 4;
+    d_cnjg(&z__1, wy);
+    y[i__1].r = z__1.r, y[i__1].i = z__1.i;
+    i__1 = y_dim1 + 5;
+    d_cnjg(&z__2, wy);
+    z__1.r = -z__2.r, z__1.i = -z__2.i;
+    y[i__1].r = z__1.r, y[i__1].i = z__1.i;
+    i__1 = (y_dim1 << 1) + 3;
+    d_cnjg(&z__2, wy);
+    z__1.r = -z__2.r, z__1.i = -z__2.i;
+    y[i__1].r = z__1.r, y[i__1].i = z__1.i;
+    i__1 = (y_dim1 << 1) + 4;
+    d_cnjg(&z__1, wy);
+    y[i__1].r = z__1.r, y[i__1].i = z__1.i;
+    i__1 = (y_dim1 << 1) + 5;
+    d_cnjg(&z__2, wy);
+    z__1.r = -z__2.r, z__1.i = -z__2.i;
+    y[i__1].r = z__1.r, y[i__1].i = z__1.i;
+
+    zlacpy_("F", n, n, &b[b_offset], lda, &x[x_offset], ldx);
+    i__1 = x_dim1 * 3 + 1;
+    z__1.r = -wx->r, z__1.i = -wx->i;
+    x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+    i__1 = (x_dim1 << 2) + 1;
+    z__1.r = -wx->r, z__1.i = -wx->i;
+    x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+    i__1 = x_dim1 * 5 + 1;
+    x[i__1].r = wx->r, x[i__1].i = wx->i;
+    i__1 = x_dim1 * 3 + 2;
+    x[i__1].r = wx->r, x[i__1].i = wx->i;
+    i__1 = (x_dim1 << 2) + 2;
+    z__1.r = -wx->r, z__1.i = -wx->i;
+    x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+    i__1 = x_dim1 * 5 + 2;
+    z__1.r = -wx->r, z__1.i = -wx->i;
+    x[i__1].r = z__1.r, x[i__1].i = z__1.i;
+
+/*     Form (A, B) */
+
+    i__1 = b_dim1 * 3 + 1;
+    z__1.r = wx->r + wy->r, z__1.i = wx->i + wy->i;
+    b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+    i__1 = b_dim1 * 3 + 2;
+    z__2.r = -wx->r, z__2.i = -wx->i;
+    z__1.r = z__2.r + wy->r, z__1.i = z__2.i + wy->i;
+    b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+    i__1 = (b_dim1 << 2) + 1;
+    z__1.r = wx->r - wy->r, z__1.i = wx->i - wy->i;
+    b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+    i__1 = (b_dim1 << 2) + 2;
+    z__1.r = wx->r - wy->r, z__1.i = wx->i - wy->i;
+    b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+    i__1 = b_dim1 * 5 + 1;
+    z__2.r = -wx->r, z__2.i = -wx->i;
+    z__1.r = z__2.r + wy->r, z__1.i = z__2.i + wy->i;
+    b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+    i__1 = b_dim1 * 5 + 2;
+    z__1.r = wx->r + wy->r, z__1.i = wx->i + wy->i;
+    b[i__1].r = z__1.r, b[i__1].i = z__1.i;
+    i__1 = a_dim1 * 3 + 1;
+    i__2 = a_dim1 + 1;
+    z__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, z__2.i = wx->r * a[i__2]
+	    .i + wx->i * a[i__2].r;
+    i__3 = a_dim1 * 3 + 3;
+    z__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__3.i = wy->r * a[i__3]
+	    .i + wy->i * a[i__3].r;
+    z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+    a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+    i__1 = a_dim1 * 3 + 2;
+    z__3.r = -wx->r, z__3.i = -wx->i;
+    i__2 = (a_dim1 << 1) + 2;
+    z__2.r = z__3.r * a[i__2].r - z__3.i * a[i__2].i, z__2.i = z__3.r * a[
+	    i__2].i + z__3.i * a[i__2].r;
+    i__3 = a_dim1 * 3 + 3;
+    z__4.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__4.i = wy->r * a[i__3]
+	    .i + wy->i * a[i__3].r;
+    z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+    a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+    i__1 = (a_dim1 << 2) + 1;
+    i__2 = a_dim1 + 1;
+    z__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, z__2.i = wx->r * a[i__2]
+	    .i + wx->i * a[i__2].r;
+    i__3 = (a_dim1 << 2) + 4;
+    z__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__3.i = wy->r * a[i__3]
+	    .i + wy->i * a[i__3].r;
+    z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+    a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+    i__1 = (a_dim1 << 2) + 2;
+    i__2 = (a_dim1 << 1) + 2;
+    z__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, z__2.i = wx->r * a[i__2]
+	    .i + wx->i * a[i__2].r;
+    i__3 = (a_dim1 << 2) + 4;
+    z__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__3.i = wy->r * a[i__3]
+	    .i + wy->i * a[i__3].r;
+    z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i;
+    a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+    i__1 = a_dim1 * 5 + 1;
+    z__3.r = -wx->r, z__3.i = -wx->i;
+    i__2 = a_dim1 + 1;
+    z__2.r = z__3.r * a[i__2].r - z__3.i * a[i__2].i, z__2.i = z__3.r * a[
+	    i__2].i + z__3.i * a[i__2].r;
+    i__3 = a_dim1 * 5 + 5;
+    z__4.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__4.i = wy->r * a[i__3]
+	    .i + wy->i * a[i__3].r;
+    z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i;
+    a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+    i__1 = a_dim1 * 5 + 2;
+    i__2 = (a_dim1 << 1) + 2;
+    z__2.r = wx->r * a[i__2].r - wx->i * a[i__2].i, z__2.i = wx->r * a[i__2]
+	    .i + wx->i * a[i__2].r;
+    i__3 = a_dim1 * 5 + 5;
+    z__3.r = wy->r * a[i__3].r - wy->i * a[i__3].i, z__3.i = wy->r * a[i__3]
+	    .i + wy->i * a[i__3].r;
+    z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i;
+    a[i__1].r = z__1.r, a[i__1].i = z__1.i;
+
+/*     Compute condition numbers */
+
+    s[1] = 1. / sqrt((z_abs(wy) * 3. * z_abs(wy) + 1.) / (z_abs(&a[a_dim1 + 1]
+	    ) * z_abs(&a[a_dim1 + 1]) + 1.));
+    s[2] = 1. / sqrt((z_abs(wy) * 3. * z_abs(wy) + 1.) / (z_abs(&a[(a_dim1 << 
+	    1) + 2]) * z_abs(&a[(a_dim1 << 1) + 2]) + 1.));
+    s[3] = 1. / sqrt((z_abs(wx) * 2. * z_abs(wx) + 1.) / (z_abs(&a[a_dim1 * 3 
+	    + 3]) * z_abs(&a[a_dim1 * 3 + 3]) + 1.));
+    s[4] = 1. / sqrt((z_abs(wx) * 2. * z_abs(wx) + 1.) / (z_abs(&a[(a_dim1 << 
+	    2) + 4]) * z_abs(&a[(a_dim1 << 2) + 4]) + 1.));
+    s[5] = 1. / sqrt((z_abs(wx) * 2. * z_abs(wx) + 1.) / (z_abs(&a[a_dim1 * 5 
+	    + 5]) * z_abs(&a[a_dim1 * 5 + 5]) + 1.));
+
+    zlakf2_(&c__1, &c__4, &a[a_offset], lda, &a[(a_dim1 << 1) + 2], &b[
+	    b_offset], &b[(b_dim1 << 1) + 2], z__, &c__8);
+    zgesvd_("N", "N", &c__8, &c__8, z__, &c__8, rwork, work, &c__1, &work[1], 
+	    &c__1, &work[2], &c__24, &rwork[8], &info);
+    dif[1] = rwork[7];
+
+    zlakf2_(&c__4, &c__1, &a[a_offset], lda, &a[a_dim1 * 5 + 5], &b[b_offset],
+	     &b[b_dim1 * 5 + 5], z__, &c__8);
+    zgesvd_("N", "N", &c__8, &c__8, z__, &c__8, rwork, work, &c__1, &work[1], 
+	    &c__1, &work[2], &c__24, &rwork[8], &info);
+    dif[5] = rwork[7];
+
+    return 0;
+
+/*     End of ZLATM6 */
+
+} /* zlatm6_ */
+