Add C versions as fallback

lapack-netlib/SRC/sspevx.c

@@ -0,0 +1,933 @@
+/* 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;
+
+/* > \brief <b> SSPEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER 
+matrices</b> */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSPEVX + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sspevx.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sspevx.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sspevx.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, */
+/*                          ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, */
+/*                          INFO ) */
+
+/*       CHARACTER          JOBZ, RANGE, UPLO */
+/*       INTEGER            IL, INFO, IU, LDZ, M, N */
+/*       REAL               ABSTOL, VL, VU */
+/*       INTEGER            IFAIL( * ), IWORK( * ) */
+/*       REAL               AP( * ), W( * ), WORK( * ), Z( LDZ, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSPEVX computes selected eigenvalues and, optionally, eigenvectors */
+/* > of a real symmetric matrix A in packed storage.  Eigenvalues/vectors */
+/* > can be selected by specifying either a range of values or a range of */
+/* > indices for the desired eigenvalues. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] JOBZ */
+/* > \verbatim */
+/* >          JOBZ is CHARACTER*1 */
+/* >          = 'N':  Compute eigenvalues only; */
+/* >          = 'V':  Compute eigenvalues and eigenvectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] RANGE */
+/* > \verbatim */
+/* >          RANGE is CHARACTER*1 */
+/* >          = 'A': all eigenvalues will be found; */
+/* >          = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* >                 will be found; */
+/* >          = 'I': the IL-th through IU-th eigenvalues will be found. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] AP */
+/* > \verbatim */
+/* >          AP is REAL array, dimension (N*(N+1)/2) */
+/* >          On entry, the upper or lower triangle of the symmetric matrix */
+/* >          A, packed columnwise in a linear array.  The j-th column of A */
+/* >          is stored in the array AP as follows: */
+/* >          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* >          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* > */
+/* >          On exit, AP is overwritten by values generated during the */
+/* >          reduction to tridiagonal form.  If UPLO = 'U', the diagonal */
+/* >          and first superdiagonal of the tridiagonal matrix T overwrite */
+/* >          the corresponding elements of A, and if UPLO = 'L', the */
+/* >          diagonal and first subdiagonal of T overwrite the */
+/* >          corresponding elements of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] VL */
+/* > \verbatim */
+/* >          VL is REAL */
+/* >          If RANGE='V', the lower bound of the interval to */
+/* >          be searched for eigenvalues. VL < VU. */
+/* >          Not referenced if RANGE = 'A' or 'I'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] VU */
+/* > \verbatim */
+/* >          VU is REAL */
+/* >          If RANGE='V', the upper bound of the interval to */
+/* >          be searched for eigenvalues. VL < VU. */
+/* >          Not referenced if RANGE = 'A' or 'I'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IL */
+/* > \verbatim */
+/* >          IL is INTEGER */
+/* >          If RANGE='I', the index of the */
+/* >          smallest eigenvalue to be returned. */
+/* >          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* >          Not referenced if RANGE = 'A' or 'V'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IU */
+/* > \verbatim */
+/* >          IU is INTEGER */
+/* >          If RANGE='I', the index of the */
+/* >          largest eigenvalue to be returned. */
+/* >          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* >          Not referenced if RANGE = 'A' or 'V'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] ABSTOL */
+/* > \verbatim */
+/* >          ABSTOL is REAL */
+/* >          The absolute error tolerance for the eigenvalues. */
+/* >          An approximate eigenvalue is accepted as converged */
+/* >          when it is determined to lie in an interval [a,b] */
+/* >          of width less than or equal to */
+/* > */
+/* >                  ABSTOL + EPS *   f2cmax( |a|,|b| ) , */
+/* > */
+/* >          where EPS is the machine precision.  If ABSTOL is less than */
+/* >          or equal to zero, then  EPS*|T|  will be used in its place, */
+/* >          where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* >          by reducing AP to tridiagonal form. */
+/* > */
+/* >          Eigenvalues will be computed most accurately when ABSTOL is */
+/* >          set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
+/* >          If this routine returns with INFO>0, indicating that some */
+/* >          eigenvectors did not converge, try setting ABSTOL to */
+/* >          2*SLAMCH('S'). */
+/* > */
+/* >          See "Computing Small Singular Values of Bidiagonal Matrices */
+/* >          with Guaranteed High Relative Accuracy," by Demmel and */
+/* >          Kahan, LAPACK Working Note #3. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The total number of eigenvalues found.  0 <= M <= N. */
+/* >          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] W */
+/* > \verbatim */
+/* >          W is REAL array, dimension (N) */
+/* >          If INFO = 0, the selected eigenvalues in ascending order. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Z */
+/* > \verbatim */
+/* >          Z is REAL array, dimension (LDZ, f2cmax(1,M)) */
+/* >          If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* >          contain the orthonormal eigenvectors of the matrix A */
+/* >          corresponding to the selected eigenvalues, with the i-th */
+/* >          column of Z holding the eigenvector associated with W(i). */
+/* >          If an eigenvector fails to converge, then that column of Z */
+/* >          contains the latest approximation to the eigenvector, and the */
+/* >          index of the eigenvector is returned in IFAIL. */
+/* >          If JOBZ = 'N', then Z is not referenced. */
+/* >          Note: the user must ensure that at least f2cmax(1,M) columns are */
+/* >          supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* >          is not known in advance and an upper bound must be used. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDZ */
+/* > \verbatim */
+/* >          LDZ is INTEGER */
+/* >          The leading dimension of the array Z.  LDZ >= 1, and if */
+/* >          JOBZ = 'V', LDZ >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (8*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (5*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IFAIL */
+/* > \verbatim */
+/* >          IFAIL is INTEGER array, dimension (N) */
+/* >          If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* >          IFAIL are zero.  If INFO > 0, then IFAIL contains the */
+/* >          indices of the eigenvectors that failed to converge. */
+/* >          If JOBZ = 'N', then IFAIL is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0:  if INFO = i, then i eigenvectors failed to converge. */
+/* >                Their indices are stored in array IFAIL. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date June 2016 */
+
+/* > \ingroup realOTHEReigen */
+
+/*  ===================================================================== */
+/* Subroutine */ int sspevx_(char *jobz, char *range, char *uplo, integer *n, 
+	real *ap, real *vl, real *vu, integer *il, integer *iu, real *abstol, 
+	integer *m, real *w, real *z__, integer *ldz, real *work, integer *
+	iwork, integer *ifail, integer *info)
+{
+    /* System generated locals */
+    integer z_dim1, z_offset, i__1, i__2;
+    real r__1, r__2;
+
+    /* Local variables */
+    integer indd, inde;
+    real anrm;
+    integer imax;
+    real rmin, rmax;
+    logical test;
+    integer itmp1, i__, j, indee;
+    real sigma;
+    extern logical lsame_(char *, char *);
+    integer iinfo;
+    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+    char order[1];
+    extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, 
+	    integer *), sswap_(integer *, real *, integer *, real *, integer *
+	    );
+    logical wantz;
+    integer jj;
+    logical alleig, indeig;
+    integer iscale, indibl;
+    logical valeig;
+    extern real slamch_(char *);
+    real safmin;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    real abstll, bignum;
+    integer indtau, indisp, indiwo, indwrk;
+    extern real slansp_(char *, char *, integer *, real *, real *);
+    extern /* Subroutine */ int sstein_(integer *, real *, real *, integer *, 
+	    real *, integer *, integer *, real *, integer *, real *, integer *
+	    , integer *, integer *), ssterf_(integer *, real *, real *, 
+	    integer *);
+    integer nsplit;
+    extern /* Subroutine */ int sstebz_(char *, char *, integer *, real *, 
+	    real *, integer *, integer *, real *, real *, real *, integer *, 
+	    integer *, real *, integer *, integer *, real *, integer *, 
+	    integer *);
+    real smlnum;
+    extern /* Subroutine */ int sopgtr_(char *, integer *, real *, real *, 
+	    real *, integer *, real *, integer *), ssptrd_(char *, 
+	    integer *, real *, real *, real *, real *, integer *), 
+	    ssteqr_(char *, integer *, real *, real *, real *, integer *, 
+	    real *, integer *), sopmtr_(char *, char *, char *, 
+	    integer *, integer *, real *, real *, real *, integer *, real *, 
+	    integer *);
+    real eps, vll, vuu, tmp1;
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     June 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --ap;
+    --w;
+    z_dim1 = *ldz;
+    z_offset = 1 + z_dim1 * 1;
+    z__ -= z_offset;
+    --work;
+    --iwork;
+    --ifail;
+
+    /* Function Body */
+    wantz = lsame_(jobz, "V");
+    alleig = lsame_(range, "A");
+    valeig = lsame_(range, "V");
+    indeig = lsame_(range, "I");
+
+    *info = 0;
+    if (! (wantz || lsame_(jobz, "N"))) {
+	*info = -1;
+    } else if (! (alleig || valeig || indeig)) {
+	*info = -2;
+    } else if (! (lsame_(uplo, "L") || lsame_(uplo, 
+	    "U"))) {
+	*info = -3;
+    } else if (*n < 0) {
+	*info = -4;
+    } else {
+	if (valeig) {
+	    if (*n > 0 && *vu <= *vl) {
+		*info = -7;
+	    }
+	} else if (indeig) {
+	    if (*il < 1 || *il > f2cmax(1,*n)) {
+		*info = -8;
+	    } else if (*iu < f2cmin(*n,*il) || *iu > *n) {
+		*info = -9;
+	    }
+	}
+    }
+    if (*info == 0) {
+	if (*ldz < 1 || wantz && *ldz < *n) {
+	    *info = -14;
+	}
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSPEVX", &i__1, (ftnlen)6);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    *m = 0;
+    if (*n == 0) {
+	return 0;
+    }
+
+    if (*n == 1) {
+	if (alleig || indeig) {
+	    *m = 1;
+	    w[1] = ap[1];
+	} else {
+	    if (*vl < ap[1] && *vu >= ap[1]) {
+		*m = 1;
+		w[1] = ap[1];
+	    }
+	}
+	if (wantz) {
+	    z__[z_dim1 + 1] = 1.f;
+	}
+	return 0;
+    }
+
+/*     Get machine constants. */
+
+    safmin = slamch_("Safe minimum");
+    eps = slamch_("Precision");
+    smlnum = safmin / eps;
+    bignum = 1.f / smlnum;
+    rmin = sqrt(smlnum);
+/* Computing MIN */
+    r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
+    rmax = f2cmin(r__1,r__2);
+
+/*     Scale matrix to allowable range, if necessary. */
+
+    iscale = 0;
+    abstll = *abstol;
+    if (valeig) {
+	vll = *vl;
+	vuu = *vu;
+    } else {
+	vll = 0.f;
+	vuu = 0.f;
+    }
+    anrm = slansp_("M", uplo, n, &ap[1], &work[1]);
+    if (anrm > 0.f && anrm < rmin) {
+	iscale = 1;
+	sigma = rmin / anrm;
+    } else if (anrm > rmax) {
+	iscale = 1;
+	sigma = rmax / anrm;
+    }
+    if (iscale == 1) {
+	i__1 = *n * (*n + 1) / 2;
+	sscal_(&i__1, &sigma, &ap[1], &c__1);
+	if (*abstol > 0.f) {
+	    abstll = *abstol * sigma;
+	}
+	if (valeig) {
+	    vll = *vl * sigma;
+	    vuu = *vu * sigma;
+	}
+    }
+
+/*     Call SSPTRD to reduce symmetric packed matrix to tridiagonal form. */
+
+    indtau = 1;
+    inde = indtau + *n;
+    indd = inde + *n;
+    indwrk = indd + *n;
+    ssptrd_(uplo, n, &ap[1], &work[indd], &work[inde], &work[indtau], &iinfo);
+
+/*     If all eigenvalues are desired and ABSTOL is less than or equal */
+/*     to zero, then call SSTERF or SOPGTR and SSTEQR.  If this fails */
+/*     for some eigenvalue, then try SSTEBZ. */
+
+    test = FALSE_;
+    if (indeig) {
+	if (*il == 1 && *iu == *n) {
+	    test = TRUE_;
+	}
+    }
+    if ((alleig || test) && *abstol <= 0.f) {
+	scopy_(n, &work[indd], &c__1, &w[1], &c__1);
+	indee = indwrk + (*n << 1);
+	if (! wantz) {
+	    i__1 = *n - 1;
+	    scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
+	    ssterf_(n, &w[1], &work[indee], info);
+	} else {
+	    sopgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &
+		    work[indwrk], &iinfo);
+	    i__1 = *n - 1;
+	    scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
+	    ssteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[
+		    indwrk], info);
+	    if (*info == 0) {
+		i__1 = *n;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    ifail[i__] = 0;
+/* L10: */
+		}
+	    }
+	}
+	if (*info == 0) {
+	    *m = *n;
+	    goto L20;
+	}
+	*info = 0;
+    }
+
+/*     Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. */
+
+    if (wantz) {
+	*(unsigned char *)order = 'B';
+    } else {
+	*(unsigned char *)order = 'E';
+    }
+    indibl = 1;
+    indisp = indibl + *n;
+    indiwo = indisp + *n;
+    sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[
+	    inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[
+	    indwrk], &iwork[indiwo], info);
+
+    if (wantz) {
+	sstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
+		indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &
+		ifail[1], info);
+
+/*        Apply orthogonal matrix used in reduction to tridiagonal */
+/*        form to eigenvectors returned by SSTEIN. */
+
+	sopmtr_("L", uplo, "N", n, m, &ap[1], &work[indtau], &z__[z_offset], 
+		ldz, &work[indwrk], &iinfo);
+    }
+
+/*     If matrix was scaled, then rescale eigenvalues appropriately. */
+
+L20:
+    if (iscale == 1) {
+	if (*info == 0) {
+	    imax = *m;
+	} else {
+	    imax = *info - 1;
+	}
+	r__1 = 1.f / sigma;
+	sscal_(&imax, &r__1, &w[1], &c__1);
+    }
+
+/*     If eigenvalues are not in order, then sort them, along with */
+/*     eigenvectors. */
+
+    if (wantz) {
+	i__1 = *m - 1;
+	for (j = 1; j <= i__1; ++j) {
+	    i__ = 0;
+	    tmp1 = w[j];
+	    i__2 = *m;
+	    for (jj = j + 1; jj <= i__2; ++jj) {
+		if (w[jj] < tmp1) {
+		    i__ = jj;
+		    tmp1 = w[jj];
+		}
+/* L30: */
+	    }
+
+	    if (i__ != 0) {
+		itmp1 = iwork[indibl + i__ - 1];
+		w[i__] = w[j];
+		iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
+		w[j] = tmp1;
+		iwork[indibl + j - 1] = itmp1;
+		sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+			 &c__1);
+		if (*info != 0) {
+		    itmp1 = ifail[i__];
+		    ifail[i__] = ifail[j];
+		    ifail[j] = itmp1;
+		}
+	    }
+/* L40: */
+	}
+    }
+
+    return 0;
+
+/*     End of SSPEVX */
+
+} /* sspevx_ */
+

lapack-netlib/SRC/sspgst.c

@@ -0,0 +1,710 @@
+/* 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 real c_b9 = -1.f;
+static real c_b11 = 1.f;
+
+/* > \brief \b SSPGST */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSPGST + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sspgst.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sspgst.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sspgst.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSPGST( ITYPE, UPLO, N, AP, BP, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, ITYPE, N */
+/*       REAL               AP( * ), BP( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSPGST reduces a real symmetric-definite generalized eigenproblem */
+/* > to standard form, using packed storage. */
+/* > */
+/* > If ITYPE = 1, the problem is A*x = lambda*B*x, */
+/* > and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) */
+/* > */
+/* > If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
+/* > B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L. */
+/* > */
+/* > B must have been previously factorized as U**T*U or L*L**T by SPPTRF. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] ITYPE */
+/* > \verbatim */
+/* >          ITYPE is INTEGER */
+/* >          = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); */
+/* >          = 2 or 3: compute U*A*U**T or L**T*A*L. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored and B is factored as */
+/* >                  U**T*U; */
+/* >          = 'L':  Lower triangle of A is stored and B is factored as */
+/* >                  L*L**T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrices A and B.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] AP */
+/* > \verbatim */
+/* >          AP is REAL array, dimension (N*(N+1)/2) */
+/* >          On entry, the upper or lower triangle of the symmetric matrix */
+/* >          A, packed columnwise in a linear array.  The j-th column of A */
+/* >          is stored in the array AP as follows: */
+/* >          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* >          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* > */
+/* >          On exit, if INFO = 0, the transformed matrix, stored in the */
+/* >          same format as A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] BP */
+/* > \verbatim */
+/* >          BP is REAL array, dimension (N*(N+1)/2) */
+/* >          The triangular factor from the Cholesky factorization of B, */
+/* >          stored in the same format as A, as returned by SPPTRF. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realOTHERcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int sspgst_(integer *itype, char *uplo, integer *n, real *ap,
+	 real *bp, integer *info)
+{
+    /* System generated locals */
+    integer i__1, i__2;
+    real r__1;
+
+    /* Local variables */
+    extern real sdot_(integer *, real *, integer *, real *, integer *);
+    extern /* Subroutine */ int sspr2_(char *, integer *, real *, real *, 
+	    integer *, real *, integer *, real *);
+    integer j, k;
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+    logical upper;
+    integer j1, k1;
+    extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, 
+	    real *, integer *), sspmv_(char *, integer *, real *, real *, 
+	    real *, integer *, real *, real *, integer *), stpmv_(
+	    char *, char *, char *, integer *, real *, real *, integer *), stpsv_(char *, char *, char *, integer *,
+	     real *, real *, integer *);
+    integer jj, kk;
+    real ct;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    real ajj;
+    integer j1j1;
+    real akk;
+    integer k1k1;
+    real bjj, bkk;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --bp;
+    --ap;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    if (*itype < 1 || *itype > 3) {
+	*info = -1;
+    } else if (! upper && ! lsame_(uplo, "L")) {
+	*info = -2;
+    } else if (*n < 0) {
+	*info = -3;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSPGST", &i__1, (ftnlen)6);
+	return 0;
+    }
+
+    if (*itype == 1) {
+	if (upper) {
+
+/*           Compute inv(U**T)*A*inv(U) */
+
+/*           J1 and JJ are the indices of A(1,j) and A(j,j) */
+
+	    jj = 0;
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		j1 = jj + 1;
+		jj += j;
+
+/*              Compute the j-th column of the upper triangle of A */
+
+		bjj = bp[jj];
+		stpsv_(uplo, "Transpose", "Nonunit", &j, &bp[1], &ap[j1], &
+			c__1);
+		i__2 = j - 1;
+		sspmv_(uplo, &i__2, &c_b9, &ap[1], &bp[j1], &c__1, &c_b11, &
+			ap[j1], &c__1);
+		i__2 = j - 1;
+		r__1 = 1.f / bjj;
+		sscal_(&i__2, &r__1, &ap[j1], &c__1);
+		i__2 = j - 1;
+		ap[jj] = (ap[jj] - sdot_(&i__2, &ap[j1], &c__1, &bp[j1], &
+			c__1)) / bjj;
+/* L10: */
+	    }
+	} else {
+
+/*           Compute inv(L)*A*inv(L**T) */
+
+/*           KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */
+
+	    kk = 1;
+	    i__1 = *n;
+	    for (k = 1; k <= i__1; ++k) {
+		k1k1 = kk + *n - k + 1;
+
+/*              Update the lower triangle of A(k:n,k:n) */
+
+		akk = ap[kk];
+		bkk = bp[kk];
+/* Computing 2nd power */
+		r__1 = bkk;
+		akk /= r__1 * r__1;
+		ap[kk] = akk;
+		if (k < *n) {
+		    i__2 = *n - k;
+		    r__1 = 1.f / bkk;
+		    sscal_(&i__2, &r__1, &ap[kk + 1], &c__1);
+		    ct = akk * -.5f;
+		    i__2 = *n - k;
+		    saxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
+			    ;
+		    i__2 = *n - k;
+		    sspr2_(uplo, &i__2, &c_b9, &ap[kk + 1], &c__1, &bp[kk + 1]
+			    , &c__1, &ap[k1k1]);
+		    i__2 = *n - k;
+		    saxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1)
+			    ;
+		    i__2 = *n - k;
+		    stpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1],
+			     &ap[kk + 1], &c__1);
+		}
+		kk = k1k1;
+/* L20: */
+	    }
+	}
+    } else {
+	if (upper) {
+
+/*           Compute U*A*U**T */
+
+/*           K1 and KK are the indices of A(1,k) and A(k,k) */
+
+	    kk = 0;
+	    i__1 = *n;
+	    for (k = 1; k <= i__1; ++k) {
+		k1 = kk + 1;
+		kk += k;
+
+/*              Update the upper triangle of A(1:k,1:k) */
+
+		akk = ap[kk];
+		bkk = bp[kk];
+		i__2 = k - 1;
+		stpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[
+			k1], &c__1);
+		ct = akk * .5f;
+		i__2 = k - 1;
+		saxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
+		i__2 = k - 1;
+		sspr2_(uplo, &i__2, &c_b11, &ap[k1], &c__1, &bp[k1], &c__1, &
+			ap[1]);
+		i__2 = k - 1;
+		saxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1);
+		i__2 = k - 1;
+		sscal_(&i__2, &bkk, &ap[k1], &c__1);
+/* Computing 2nd power */
+		r__1 = bkk;
+		ap[kk] = akk * (r__1 * r__1);
+/* L30: */
+	    }
+	} else {
+
+/*           Compute L**T *A*L */
+
+/*           JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */
+
+	    jj = 1;
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		j1j1 = jj + *n - j + 1;
+
+/*              Compute the j-th column of the lower triangle of A */
+
+		ajj = ap[jj];
+		bjj = bp[jj];
+		i__2 = *n - j;
+		ap[jj] = ajj * bjj + sdot_(&i__2, &ap[jj + 1], &c__1, &bp[jj 
+			+ 1], &c__1);
+		i__2 = *n - j;
+		sscal_(&i__2, &bjj, &ap[jj + 1], &c__1);
+		i__2 = *n - j;
+		sspmv_(uplo, &i__2, &c_b11, &ap[j1j1], &bp[jj + 1], &c__1, &
+			c_b11, &ap[jj + 1], &c__1);
+		i__2 = *n - j + 1;
+		stpmv_(uplo, "Transpose", "Non-unit", &i__2, &bp[jj], &ap[jj],
+			 &c__1);
+		jj = j1j1;
+/* L40: */
+	    }
+	}
+    }
+    return 0;
+
+/*     End of SSPGST */
+
+} /* sspgst_ */
+

lapack-netlib/SRC/sspgv.c

@@ -0,0 +1,684 @@
+/* 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;
+
+/* > \brief \b SSPGV */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSPGV + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sspgv.f
+"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sspgv.f
+"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sspgv.f
+"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, */
+/*                         INFO ) */
+
+/*       CHARACTER          JOBZ, UPLO */
+/*       INTEGER            INFO, ITYPE, LDZ, N */
+/*       REAL               AP( * ), BP( * ), W( * ), WORK( * ), */
+/*      $                   Z( LDZ, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSPGV computes all the eigenvalues and, optionally, the eigenvectors */
+/* > of a real generalized symmetric-definite eigenproblem, of the form */
+/* > A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x. */
+/* > Here A and B are assumed to be symmetric, stored in packed format, */
+/* > and B is also positive definite. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] ITYPE */
+/* > \verbatim */
+/* >          ITYPE is INTEGER */
+/* >          Specifies the problem type to be solved: */
+/* >          = 1:  A*x = (lambda)*B*x */
+/* >          = 2:  A*B*x = (lambda)*x */
+/* >          = 3:  B*A*x = (lambda)*x */
+/* > \endverbatim */
+/* > */
+/* > \param[in] JOBZ */
+/* > \verbatim */
+/* >          JOBZ is CHARACTER*1 */
+/* >          = 'N':  Compute eigenvalues only; */
+/* >          = 'V':  Compute eigenvalues and eigenvectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangles of A and B are stored; */
+/* >          = 'L':  Lower triangles of A and B are stored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrices A and B.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] AP */
+/* > \verbatim */
+/* >          AP is REAL array, dimension (N*(N+1)/2) */
+/* >          On entry, the upper or lower triangle of the symmetric matrix */
+/* >          A, packed columnwise in a linear array.  The j-th column of A */
+/* >          is stored in the array AP as follows: */
+/* >          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* >          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* > */
+/* >          On exit, the contents of AP are destroyed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] BP */
+/* > \verbatim */
+/* >          BP is REAL array, dimension (N*(N+1)/2) */
+/* >          On entry, the upper or lower triangle of the symmetric matrix */
+/* >          B, packed columnwise in a linear array.  The j-th column of B */
+/* >          is stored in the array BP as follows: */
+/* >          if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */
+/* >          if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */
+/* > */
+/* >          On exit, the triangular factor U or L from the Cholesky */
+/* >          factorization B = U**T*U or B = L*L**T, in the same storage */
+/* >          format as B. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] W */
+/* > \verbatim */
+/* >          W is REAL array, dimension (N) */
+/* >          If INFO = 0, the eigenvalues in ascending order. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Z */
+/* > \verbatim */
+/* >          Z is REAL array, dimension (LDZ, N) */
+/* >          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
+/* >          eigenvectors.  The eigenvectors are normalized as follows: */
+/* >          if ITYPE = 1 or 2, Z**T*B*Z = I; */
+/* >          if ITYPE = 3, Z**T*inv(B)*Z = I. */
+/* >          If JOBZ = 'N', then Z is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDZ */
+/* > \verbatim */
+/* >          LDZ is INTEGER */
+/* >          The leading dimension of the array Z.  LDZ >= 1, and if */
+/* >          JOBZ = 'V', LDZ >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (3*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0:  SPPTRF or SSPEV returned an error code: */
+/* >             <= N:  if INFO = i, SSPEV failed to converge; */
+/* >                    i off-diagonal elements of an intermediate */
+/* >                    tridiagonal form did not converge to zero. */
+/* >             > N:   if INFO = n + i, for 1 <= i <= n, then the leading */
+/* >                    minor of order i of B is not positive definite. */
+/* >                    The factorization of B could not be completed and */
+/* >                    no eigenvalues or eigenvectors were computed. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date June 2017 */
+
+/* > \ingroup realOTHEReigen */
+
+/*  ===================================================================== */
+/* Subroutine */ int sspgv_(integer *itype, char *jobz, char *uplo, integer *
+	n, real *ap, real *bp, real *w, real *z__, integer *ldz, real *work, 
+	integer *info)
+{
+    /* System generated locals */
+    integer z_dim1, z_offset, i__1;
+
+    /* Local variables */
+    integer neig, j;
+    extern logical lsame_(char *, char *);
+    char trans[1];
+    logical upper;
+    extern /* Subroutine */ int sspev_(char *, char *, integer *, real *, 
+	    real *, real *, integer *, real *, integer *);
+    logical wantz;
+    extern /* Subroutine */ int stpmv_(char *, char *, char *, integer *, 
+	    real *, real *, integer *), stpsv_(char *,
+	     char *, char *, integer *, real *, real *, integer *), xerbla_(char *, integer *, ftnlen), spptrf_(char 
+	    *, integer *, real *, integer *), sspgst_(integer *, char 
+	    *, integer *, real *, real *, integer *);
+
+
+/*  -- LAPACK driver routine (version 3.7.1) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     June 2017 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --ap;
+    --bp;
+    --w;
+    z_dim1 = *ldz;
+    z_offset = 1 + z_dim1 * 1;
+    z__ -= z_offset;
+    --work;
+
+    /* Function Body */
+    wantz = lsame_(jobz, "V");
+    upper = lsame_(uplo, "U");
+
+    *info = 0;
+    if (*itype < 1 || *itype > 3) {
+	*info = -1;
+    } else if (! (wantz || lsame_(jobz, "N"))) {
+	*info = -2;
+    } else if (! (upper || lsame_(uplo, "L"))) {
+	*info = -3;
+    } else if (*n < 0) {
+	*info = -4;
+    } else if (*ldz < 1 || wantz && *ldz < *n) {
+	*info = -9;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSPGV ", &i__1, (ftnlen)6);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+/*     Form a Cholesky factorization of B. */
+
+    spptrf_(uplo, n, &bp[1], info);
+    if (*info != 0) {
+	*info = *n + *info;
+	return 0;
+    }
+
+/*     Transform problem to standard eigenvalue problem and solve. */
+
+    sspgst_(itype, uplo, n, &ap[1], &bp[1], info);
+    sspev_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], info);
+
+    if (wantz) {
+
+/*        Backtransform eigenvectors to the original problem. */
+
+	neig = *n;
+	if (*info > 0) {
+	    neig = *info - 1;
+	}
+	if (*itype == 1 || *itype == 2) {
+
+/*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/*           backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y */
+
+	    if (upper) {
+		*(unsigned char *)trans = 'N';
+	    } else {
+		*(unsigned char *)trans = 'T';
+	    }
+
+	    i__1 = neig;
+	    for (j = 1; j <= i__1; ++j) {
+		stpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 
+			1], &c__1);
+/* L10: */
+	    }
+
+	} else if (*itype == 3) {
+
+/*           For B*A*x=(lambda)*x; */
+/*           backtransform eigenvectors: x = L*y or U**T*y */
+
+	    if (upper) {
+		*(unsigned char *)trans = 'T';
+	    } else {
+		*(unsigned char *)trans = 'N';
+	    }
+
+	    i__1 = neig;
+	    for (j = 1; j <= i__1; ++j) {
+		stpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 
+			1], &c__1);
+/* L20: */
+	    }
+	}
+    }
+    return 0;
+
+/*     End of SSPGV */
+
+} /* sspgv_ */
+

lapack-netlib/SRC/sspgvd.c

@@ -0,0 +1,779 @@
+/* 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;
+
+/* > \brief \b SSPGVD */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSPGVD + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sspgvd.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sspgvd.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sspgvd.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, */
+/*                          LWORK, IWORK, LIWORK, INFO ) */
+
+/*       CHARACTER          JOBZ, UPLO */
+/*       INTEGER            INFO, ITYPE, LDZ, LIWORK, LWORK, N */
+/*       INTEGER            IWORK( * ) */
+/*       REAL               AP( * ), BP( * ), W( * ), WORK( * ), */
+/*      $                   Z( LDZ, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSPGVD computes all the eigenvalues, and optionally, the eigenvectors */
+/* > of a real generalized symmetric-definite eigenproblem, of the form */
+/* > A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A and */
+/* > B are assumed to be symmetric, stored in packed format, and B is also */
+/* > positive definite. */
+/* > If eigenvectors are desired, it uses a divide and conquer algorithm. */
+/* > */
+/* > The divide and conquer algorithm makes very mild assumptions about */
+/* > floating point arithmetic. It will work on machines with a guard */
+/* > digit in add/subtract, or on those binary machines without guard */
+/* > digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* > Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* > without guard digits, but we know of none. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] ITYPE */
+/* > \verbatim */
+/* >          ITYPE is INTEGER */
+/* >          Specifies the problem type to be solved: */
+/* >          = 1:  A*x = (lambda)*B*x */
+/* >          = 2:  A*B*x = (lambda)*x */
+/* >          = 3:  B*A*x = (lambda)*x */
+/* > \endverbatim */
+/* > */
+/* > \param[in] JOBZ */
+/* > \verbatim */
+/* >          JOBZ is CHARACTER*1 */
+/* >          = 'N':  Compute eigenvalues only; */
+/* >          = 'V':  Compute eigenvalues and eigenvectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangles of A and B are stored; */
+/* >          = 'L':  Lower triangles of A and B are stored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrices A and B.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] AP */
+/* > \verbatim */
+/* >          AP is REAL array, dimension (N*(N+1)/2) */
+/* >          On entry, the upper or lower triangle of the symmetric matrix */
+/* >          A, packed columnwise in a linear array.  The j-th column of A */
+/* >          is stored in the array AP as follows: */
+/* >          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* >          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* > */
+/* >          On exit, the contents of AP are destroyed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] BP */
+/* > \verbatim */
+/* >          BP is REAL array, dimension (N*(N+1)/2) */
+/* >          On entry, the upper or lower triangle of the symmetric matrix */
+/* >          B, packed columnwise in a linear array.  The j-th column of B */
+/* >          is stored in the array BP as follows: */
+/* >          if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */
+/* >          if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */
+/* > */
+/* >          On exit, the triangular factor U or L from the Cholesky */
+/* >          factorization B = U**T*U or B = L*L**T, in the same storage */
+/* >          format as B. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] W */
+/* > \verbatim */
+/* >          W is REAL array, dimension (N) */
+/* >          If INFO = 0, the eigenvalues in ascending order. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Z */
+/* > \verbatim */
+/* >          Z is REAL array, dimension (LDZ, N) */
+/* >          If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
+/* >          eigenvectors.  The eigenvectors are normalized as follows: */
+/* >          if ITYPE = 1 or 2, Z**T*B*Z = I; */
+/* >          if ITYPE = 3, Z**T*inv(B)*Z = I. */
+/* >          If JOBZ = 'N', then Z is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDZ */
+/* > \verbatim */
+/* >          LDZ is INTEGER */
+/* >          The leading dimension of the array Z.  LDZ >= 1, and if */
+/* >          JOBZ = 'V', LDZ >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (MAX(1,LWORK)) */
+/* >          On exit, if INFO = 0, WORK(1) returns the required LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The dimension of the array WORK. */
+/* >          If N <= 1,               LWORK >= 1. */
+/* >          If JOBZ = 'N' and N > 1, LWORK >= 2*N. */
+/* >          If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. */
+/* > */
+/* >          If LWORK = -1, then a workspace query is assumed; the routine */
+/* >          only calculates the required sizes of the WORK and IWORK */
+/* >          arrays, returns these values as the first entries of the WORK */
+/* >          and IWORK arrays, and no error message related to LWORK or */
+/* >          LIWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */
+/* >          On exit, if INFO = 0, IWORK(1) returns the required LIWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LIWORK */
+/* > \verbatim */
+/* >          LIWORK is INTEGER */
+/* >          The dimension of the array IWORK. */
+/* >          If JOBZ  = 'N' or N <= 1, LIWORK >= 1. */
+/* >          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N. */
+/* > */
+/* >          If LIWORK = -1, then a workspace query is assumed; the */
+/* >          routine only calculates the required sizes of the WORK and */
+/* >          IWORK arrays, returns these values as the first entries of */
+/* >          the WORK and IWORK arrays, and no error message related to */
+/* >          LWORK or LIWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0:  SPPTRF or SSPEVD returned an error code: */
+/* >             <= N:  if INFO = i, SSPEVD failed to converge; */
+/* >                    i off-diagonal elements of an intermediate */
+/* >                    tridiagonal form did not converge to zero; */
+/* >             > N:   if INFO = N + i, for 1 <= i <= N, then the leading */
+/* >                    minor of order i of B is not positive definite. */
+/* >                    The factorization of B could not be completed and */
+/* >                    no eigenvalues or eigenvectors were computed. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realOTHEReigen */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > */
+/* >     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/*  ===================================================================== */
+/* Subroutine */ int sspgvd_(integer *itype, char *jobz, char *uplo, integer *
+	n, real *ap, real *bp, real *w, real *z__, integer *ldz, real *work, 
+	integer *lwork, integer *iwork, integer *liwork, integer *info)
+{
+    /* System generated locals */
+    integer z_dim1, z_offset, i__1;
+    real r__1, r__2;
+
+    /* Local variables */
+    integer neig, j;
+    extern logical lsame_(char *, char *);
+    integer lwmin;
+    char trans[1];
+    logical upper, wantz;
+    extern /* Subroutine */ int stpmv_(char *, char *, char *, integer *, 
+	    real *, real *, integer *), stpsv_(char *,
+	     char *, char *, integer *, real *, real *, integer *), xerbla_(char *, integer *, ftnlen);
+    integer liwmin;
+    extern /* Subroutine */ int sspevd_(char *, char *, integer *, real *, 
+	    real *, real *, integer *, real *, integer *, integer *, integer *
+	    , integer *), spptrf_(char *, integer *, real *, 
+	    integer *);
+    logical lquery;
+    extern /* Subroutine */ int sspgst_(integer *, char *, integer *, real *, 
+	    real *, integer *);
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --ap;
+    --bp;
+    --w;
+    z_dim1 = *ldz;
+    z_offset = 1 + z_dim1 * 1;
+    z__ -= z_offset;
+    --work;
+    --iwork;
+
+    /* Function Body */
+    wantz = lsame_(jobz, "V");
+    upper = lsame_(uplo, "U");
+    lquery = *lwork == -1 || *liwork == -1;
+
+    *info = 0;
+    if (*itype < 1 || *itype > 3) {
+	*info = -1;
+    } else if (! (wantz || lsame_(jobz, "N"))) {
+	*info = -2;
+    } else if (! (upper || lsame_(uplo, "L"))) {
+	*info = -3;
+    } else if (*n < 0) {
+	*info = -4;
+    } else if (*ldz < 1 || wantz && *ldz < *n) {
+	*info = -9;
+    }
+
+    if (*info == 0) {
+	if (*n <= 1) {
+	    liwmin = 1;
+	    lwmin = 1;
+	} else {
+	    if (wantz) {
+		liwmin = *n * 5 + 3;
+/* Computing 2nd power */
+		i__1 = *n;
+		lwmin = *n * 6 + 1 + (i__1 * i__1 << 1);
+	    } else {
+		liwmin = 1;
+		lwmin = *n << 1;
+	    }
+	}
+	work[1] = (real) lwmin;
+	iwork[1] = liwmin;
+	if (*lwork < lwmin && ! lquery) {
+	    *info = -11;
+	} else if (*liwork < liwmin && ! lquery) {
+	    *info = -13;
+	}
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSPGVD", &i__1, (ftnlen)6);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+/*     Form a Cholesky factorization of BP. */
+
+    spptrf_(uplo, n, &bp[1], info);
+    if (*info != 0) {
+	*info = *n + *info;
+	return 0;
+    }
+
+/*     Transform problem to standard eigenvalue problem and solve. */
+
+    sspgst_(itype, uplo, n, &ap[1], &bp[1], info);
+    sspevd_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], 
+	    lwork, &iwork[1], liwork, info);
+/* Computing MAX */
+    r__1 = (real) lwmin;
+    lwmin = f2cmax(r__1,work[1]);
+/* Computing MAX */
+    r__1 = (real) liwmin, r__2 = (real) iwork[1];
+    liwmin = f2cmax(r__1,r__2);
+
+    if (wantz) {
+
+/*        Backtransform eigenvectors to the original problem. */
+
+	neig = *n;
+	if (*info > 0) {
+	    neig = *info - 1;
+	}
+	if (*itype == 1 || *itype == 2) {
+
+/*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/*           backtransform eigenvectors: x = inv(L)**T *y or inv(U)*y */
+
+	    if (upper) {
+		*(unsigned char *)trans = 'N';
+	    } else {
+		*(unsigned char *)trans = 'T';
+	    }
+
+	    i__1 = neig;
+	    for (j = 1; j <= i__1; ++j) {
+		stpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 
+			1], &c__1);
+/* L10: */
+	    }
+
+	} else if (*itype == 3) {
+
+/*           For B*A*x=(lambda)*x; */
+/*           backtransform eigenvectors: x = L*y or U**T *y */
+
+	    if (upper) {
+		*(unsigned char *)trans = 'T';
+	    } else {
+		*(unsigned char *)trans = 'N';
+	    }
+
+	    i__1 = neig;
+	    for (j = 1; j <= i__1; ++j) {
+		stpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 
+			1], &c__1);
+/* L20: */
+	    }
+	}
+    }
+
+    work[1] = (real) lwmin;
+    iwork[1] = liwmin;
+
+    return 0;
+
+/*     End of SSPGVD */
+
+} /* sspgvd_ */
+

lapack-netlib/SRC/sspgvx.c

@@ -0,0 +1,824 @@
+/* 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;
+
+/* > \brief \b SSPGVX */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSPGVX + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sspgvx.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sspgvx.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sspgvx.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, */
+/*                          IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, */
+/*                          IFAIL, INFO ) */
+
+/*       CHARACTER          JOBZ, RANGE, UPLO */
+/*       INTEGER            IL, INFO, ITYPE, IU, LDZ, M, N */
+/*       REAL               ABSTOL, VL, VU */
+/*       INTEGER            IFAIL( * ), IWORK( * ) */
+/*       REAL               AP( * ), BP( * ), W( * ), WORK( * ), */
+/*      $                   Z( LDZ, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSPGVX computes selected eigenvalues, and optionally, eigenvectors */
+/* > of a real generalized symmetric-definite eigenproblem, of the form */
+/* > A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A */
+/* > and B are assumed to be symmetric, stored in packed storage, and B */
+/* > is also positive definite.  Eigenvalues and eigenvectors can be */
+/* > selected by specifying either a range of values or a range of indices */
+/* > for the desired eigenvalues. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] ITYPE */
+/* > \verbatim */
+/* >          ITYPE is INTEGER */
+/* >          Specifies the problem type to be solved: */
+/* >          = 1:  A*x = (lambda)*B*x */
+/* >          = 2:  A*B*x = (lambda)*x */
+/* >          = 3:  B*A*x = (lambda)*x */
+/* > \endverbatim */
+/* > */
+/* > \param[in] JOBZ */
+/* > \verbatim */
+/* >          JOBZ is CHARACTER*1 */
+/* >          = 'N':  Compute eigenvalues only; */
+/* >          = 'V':  Compute eigenvalues and eigenvectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] RANGE */
+/* > \verbatim */
+/* >          RANGE is CHARACTER*1 */
+/* >          = 'A': all eigenvalues will be found. */
+/* >          = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* >                 will be found. */
+/* >          = 'I': the IL-th through IU-th eigenvalues will be found. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A and B are stored; */
+/* >          = 'L':  Lower triangle of A and B are stored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix pencil (A,B).  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] AP */
+/* > \verbatim */
+/* >          AP is REAL array, dimension (N*(N+1)/2) */
+/* >          On entry, the upper or lower triangle of the symmetric matrix */
+/* >          A, packed columnwise in a linear array.  The j-th column of A */
+/* >          is stored in the array AP as follows: */
+/* >          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* >          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* > */
+/* >          On exit, the contents of AP are destroyed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] BP */
+/* > \verbatim */
+/* >          BP is REAL array, dimension (N*(N+1)/2) */
+/* >          On entry, the upper or lower triangle of the symmetric matrix */
+/* >          B, packed columnwise in a linear array.  The j-th column of B */
+/* >          is stored in the array BP as follows: */
+/* >          if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */
+/* >          if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */
+/* > */
+/* >          On exit, the triangular factor U or L from the Cholesky */
+/* >          factorization B = U**T*U or B = L*L**T, in the same storage */
+/* >          format as B. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] VL */
+/* > \verbatim */
+/* >          VL is REAL */
+/* > */
+/* >          If RANGE='V', the lower bound of the interval to */
+/* >          be searched for eigenvalues. VL < VU. */
+/* >          Not referenced if RANGE = 'A' or 'I'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] VU */
+/* > \verbatim */
+/* >          VU is REAL */
+/* > */
+/* >          If RANGE='V', the upper bound of the interval to */
+/* >          be searched for eigenvalues. VL < VU. */
+/* >          Not referenced if RANGE = 'A' or 'I'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IL */
+/* > \verbatim */
+/* >          IL is INTEGER */
+/* > */
+/* >          If RANGE='I', the index of the */
+/* >          smallest eigenvalue to be returned. */
+/* >          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* >          Not referenced if RANGE = 'A' or 'V'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IU */
+/* > \verbatim */
+/* >          IU is INTEGER */
+/* > */
+/* >          If RANGE='I', the index of the */
+/* >          largest eigenvalue to be returned. */
+/* >          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* >          Not referenced if RANGE = 'A' or 'V'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] ABSTOL */
+/* > \verbatim */
+/* >          ABSTOL is REAL */
+/* >          The absolute error tolerance for the eigenvalues. */
+/* >          An approximate eigenvalue is accepted as converged */
+/* >          when it is determined to lie in an interval [a,b] */
+/* >          of width less than or equal to */
+/* > */
+/* >                  ABSTOL + EPS *   f2cmax( |a|,|b| ) , */
+/* > */
+/* >          where EPS is the machine precision.  If ABSTOL is less than */
+/* >          or equal to zero, then  EPS*|T|  will be used in its place, */
+/* >          where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* >          by reducing A to tridiagonal form. */
+/* > */
+/* >          Eigenvalues will be computed most accurately when ABSTOL is */
+/* >          set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
+/* >          If this routine returns with INFO>0, indicating that some */
+/* >          eigenvectors did not converge, try setting ABSTOL to */
+/* >          2*SLAMCH('S'). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The total number of eigenvalues found.  0 <= M <= N. */
+/* >          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] W */
+/* > \verbatim */
+/* >          W is REAL array, dimension (N) */
+/* >          On normal exit, the first M elements contain the selected */
+/* >          eigenvalues in ascending order. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Z */
+/* > \verbatim */
+/* >          Z is REAL array, dimension (LDZ, f2cmax(1,M)) */
+/* >          If JOBZ = 'N', then Z is not referenced. */
+/* >          If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* >          contain the orthonormal eigenvectors of the matrix A */
+/* >          corresponding to the selected eigenvalues, with the i-th */
+/* >          column of Z holding the eigenvector associated with W(i). */
+/* >          The eigenvectors are normalized as follows: */
+/* >          if ITYPE = 1 or 2, Z**T*B*Z = I; */
+/* >          if ITYPE = 3, Z**T*inv(B)*Z = I. */
+/* > */
+/* >          If an eigenvector fails to converge, then that column of Z */
+/* >          contains the latest approximation to the eigenvector, and the */
+/* >          index of the eigenvector is returned in IFAIL. */
+/* >          Note: the user must ensure that at least f2cmax(1,M) columns are */
+/* >          supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* >          is not known in advance and an upper bound must be used. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDZ */
+/* > \verbatim */
+/* >          LDZ is INTEGER */
+/* >          The leading dimension of the array Z.  LDZ >= 1, and if */
+/* >          JOBZ = 'V', LDZ >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (8*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (5*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IFAIL */
+/* > \verbatim */
+/* >          IFAIL is INTEGER array, dimension (N) */
+/* >          If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* >          IFAIL are zero.  If INFO > 0, then IFAIL contains the */
+/* >          indices of the eigenvectors that failed to converge. */
+/* >          If JOBZ = 'N', then IFAIL is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0:  SPPTRF or SSPEVX returned an error code: */
+/* >             <= N:  if INFO = i, SSPEVX failed to converge; */
+/* >                    i eigenvectors failed to converge.  Their indices */
+/* >                    are stored in array IFAIL. */
+/* >             > N:   if INFO = N + i, for 1 <= i <= N, then the leading */
+/* >                    minor of order i of B is not positive definite. */
+/* >                    The factorization of B could not be completed and */
+/* >                    no eigenvalues or eigenvectors were computed. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date June 2016 */
+
+/* > \ingroup realOTHEReigen */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > */
+/* >     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/*  ===================================================================== */
+/* Subroutine */ int sspgvx_(integer *itype, char *jobz, char *range, char *
+	uplo, integer *n, real *ap, real *bp, real *vl, real *vu, integer *il,
+	 integer *iu, real *abstol, integer *m, real *w, real *z__, integer *
+	ldz, real *work, integer *iwork, integer *ifail, integer *info)
+{
+    /* System generated locals */
+    integer z_dim1, z_offset, i__1;
+
+    /* Local variables */
+    integer j;
+    extern logical lsame_(char *, char *);
+    char trans[1];
+    logical upper, wantz;
+    extern /* Subroutine */ int stpmv_(char *, char *, char *, integer *, 
+	    real *, real *, integer *), stpsv_(char *,
+	     char *, char *, integer *, real *, real *, integer *);
+    logical alleig, indeig, valeig;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), spptrf_(
+	    char *, integer *, real *, integer *), sspgst_(integer *, 
+	    char *, integer *, real *, real *, integer *), sspevx_(
+	    char *, char *, char *, integer *, real *, real *, real *, 
+	    integer *, integer *, real *, integer *, real *, real *, integer *
+	    , real *, integer *, integer *, integer *)
+	    ;
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     June 2016 */
+
+
+/* ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --ap;
+    --bp;
+    --w;
+    z_dim1 = *ldz;
+    z_offset = 1 + z_dim1 * 1;
+    z__ -= z_offset;
+    --work;
+    --iwork;
+    --ifail;
+
+    /* Function Body */
+    upper = lsame_(uplo, "U");
+    wantz = lsame_(jobz, "V");
+    alleig = lsame_(range, "A");
+    valeig = lsame_(range, "V");
+    indeig = lsame_(range, "I");
+
+    *info = 0;
+    if (*itype < 1 || *itype > 3) {
+	*info = -1;
+    } else if (! (wantz || lsame_(jobz, "N"))) {
+	*info = -2;
+    } else if (! (alleig || valeig || indeig)) {
+	*info = -3;
+    } else if (! (upper || lsame_(uplo, "L"))) {
+	*info = -4;
+    } else if (*n < 0) {
+	*info = -5;
+    } else {
+	if (valeig) {
+	    if (*n > 0 && *vu <= *vl) {
+		*info = -9;
+	    }
+	} else if (indeig) {
+	    if (*il < 1) {
+		*info = -10;
+	    } else if (*iu < f2cmin(*n,*il) || *iu > *n) {
+		*info = -11;
+	    }
+	}
+    }
+    if (*info == 0) {
+	if (*ldz < 1 || wantz && *ldz < *n) {
+	    *info = -16;
+	}
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSPGVX", &i__1, (ftnlen)6);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    *m = 0;
+    if (*n == 0) {
+	return 0;
+    }
+
+/*     Form a Cholesky factorization of B. */
+
+    spptrf_(uplo, n, &bp[1], info);
+    if (*info != 0) {
+	*info = *n + *info;
+	return 0;
+    }
+
+/*     Transform problem to standard eigenvalue problem and solve. */
+
+    sspgst_(itype, uplo, n, &ap[1], &bp[1], info);
+    sspevx_(jobz, range, uplo, n, &ap[1], vl, vu, il, iu, abstol, m, &w[1], &
+	    z__[z_offset], ldz, &work[1], &iwork[1], &ifail[1], info);
+
+    if (wantz) {
+
+/*        Backtransform eigenvectors to the original problem. */
+
+	if (*info > 0) {
+	    *m = *info - 1;
+	}
+	if (*itype == 1 || *itype == 2) {
+
+/*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/*           backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y */
+
+	    if (upper) {
+		*(unsigned char *)trans = 'N';
+	    } else {
+		*(unsigned char *)trans = 'T';
+	    }
+
+	    i__1 = *m;
+	    for (j = 1; j <= i__1; ++j) {
+		stpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 
+			1], &c__1);
+/* L10: */
+	    }
+
+	} else if (*itype == 3) {
+
+/*           For B*A*x=(lambda)*x; */
+/*           backtransform eigenvectors: x = L*y or U**T*y */
+
+	    if (upper) {
+		*(unsigned char *)trans = 'T';
+	    } else {
+		*(unsigned char *)trans = 'N';
+	    }
+
+	    i__1 = *m;
+	    for (j = 1; j <= i__1; ++j) {
+		stpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + 
+			1], &c__1);
+/* L20: */
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of SSPGVX */
+
+} /* sspgvx_ */
+

lapack-netlib/SRC/ssprfs.c

@@ -0,0 +1,869 @@
+/* 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 real c_b12 = -1.f;
+static real c_b14 = 1.f;
+
+/* > \brief \b SSPRFS */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSPRFS + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssprfs.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssprfs.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssprfs.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, */
+/*                          FERR, BERR, WORK, IWORK, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDB, LDX, N, NRHS */
+/*       INTEGER            IPIV( * ), IWORK( * ) */
+/*       REAL               AFP( * ), AP( * ), B( LDB, * ), BERR( * ), */
+/*      $                   FERR( * ), WORK( * ), X( LDX, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSPRFS improves the computed solution to a system of linear */
+/* > equations when the coefficient matrix is symmetric indefinite */
+/* > and packed, and provides error bounds and backward error estimates */
+/* > for the solution. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The number of right hand sides, i.e., the number of columns */
+/* >          of the matrices B and X.  NRHS >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] AP */
+/* > \verbatim */
+/* >          AP is REAL array, dimension (N*(N+1)/2) */
+/* >          The upper or lower triangle of the symmetric matrix A, packed */
+/* >          columnwise in a linear array.  The j-th column of A is stored */
+/* >          in the array AP as follows: */
+/* >          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* >          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] AFP */
+/* > \verbatim */
+/* >          AFP is REAL array, dimension (N*(N+1)/2) */
+/* >          The factored form of the matrix A.  AFP contains the block */
+/* >          diagonal matrix D and the multipliers used to obtain the */
+/* >          factor U or L from the factorization A = U*D*U**T or */
+/* >          A = L*D*L**T as computed by SSPTRF, stored as a packed */
+/* >          triangular matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges and the block structure of D */
+/* >          as determined by SSPTRF. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB,NRHS) */
+/* >          The right hand side matrix B. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] X */
+/* > \verbatim */
+/* >          X is REAL array, dimension (LDX,NRHS) */
+/* >          On entry, the solution matrix X, as computed by SSPTRS. */
+/* >          On exit, the improved solution matrix X. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDX */
+/* > \verbatim */
+/* >          LDX is INTEGER */
+/* >          The leading dimension of the array X.  LDX >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] FERR */
+/* > \verbatim */
+/* >          FERR is REAL array, dimension (NRHS) */
+/* >          The estimated forward error bound for each solution vector */
+/* >          X(j) (the j-th column of the solution matrix X). */
+/* >          If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* >          is an estimated upper bound for the magnitude of the largest */
+/* >          element in (X(j) - XTRUE) divided by the magnitude of the */
+/* >          largest element in X(j).  The estimate is as reliable as */
+/* >          the estimate for RCOND, and is almost always a slight */
+/* >          overestimate of the true error. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] BERR */
+/* > \verbatim */
+/* >          BERR is REAL array, dimension (NRHS) */
+/* >          The componentwise relative backward error of each solution */
+/* >          vector X(j) (i.e., the smallest relative change in */
+/* >          any element of A or B that makes X(j) an exact solution). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (3*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/* > \par Internal Parameters: */
+/*  ========================= */
+/* > */
+/* > \verbatim */
+/* >  ITMAX is the maximum number of steps of iterative refinement. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realOTHERcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssprfs_(char *uplo, integer *n, integer *nrhs, real *ap, 
+	real *afp, integer *ipiv, real *b, integer *ldb, real *x, integer *
+	ldx, real *ferr, real *berr, real *work, integer *iwork, integer *
+	info)
+{
+    /* System generated locals */
+    integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3;
+    real r__1, r__2, r__3;
+
+    /* Local variables */
+    integer kase;
+    real safe1, safe2;
+    integer i__, j, k;
+    real s;
+    extern logical lsame_(char *, char *);
+    integer isave[3], count;
+    logical upper;
+    extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, 
+	    integer *), saxpy_(integer *, real *, real *, integer *, real *, 
+	    integer *), sspmv_(char *, integer *, real *, real *, real *, 
+	    integer *, real *, real *, integer *), slacn2_(integer *, 
+	    real *, real *, integer *, real *, integer *, integer *);
+    integer ik, kk;
+    real xk;
+    extern real slamch_(char *);
+    integer nz;
+    real safmin;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    real lstres;
+    extern /* Subroutine */ int ssptrs_(char *, integer *, integer *, real *, 
+	    integer *, real *, integer *, integer *);
+    real eps;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --ap;
+    --afp;
+    --ipiv;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    x_dim1 = *ldx;
+    x_offset = 1 + x_dim1 * 1;
+    x -= x_offset;
+    --ferr;
+    --berr;
+    --work;
+    --iwork;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*nrhs < 0) {
+	*info = -3;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -8;
+    } else if (*ldx < f2cmax(1,*n)) {
+	*info = -10;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSPRFS", &i__1, (ftnlen)6);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0 || *nrhs == 0) {
+	i__1 = *nrhs;
+	for (j = 1; j <= i__1; ++j) {
+	    ferr[j] = 0.f;
+	    berr[j] = 0.f;
+/* L10: */
+	}
+	return 0;
+    }
+
+/*     NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+    nz = *n + 1;
+    eps = slamch_("Epsilon");
+    safmin = slamch_("Safe minimum");
+    safe1 = nz * safmin;
+    safe2 = safe1 / eps;
+
+/*     Do for each right hand side */
+
+    i__1 = *nrhs;
+    for (j = 1; j <= i__1; ++j) {
+
+	count = 1;
+	lstres = 3.f;
+L20:
+
+/*        Loop until stopping criterion is satisfied. */
+
+/*        Compute residual R = B - A * X */
+
+	scopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+	sspmv_(uplo, n, &c_b12, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b14, &
+		work[*n + 1], &c__1);
+
+/*        Compute componentwise relative backward error from formula */
+
+/*        f2cmax(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/*        where abs(Z) is the componentwise absolute value of the matrix */
+/*        or vector Z.  If the i-th component of the denominator is less */
+/*        than SAFE2, then SAFE1 is added to the i-th components of the */
+/*        numerator and denominator before dividing. */
+
+	i__2 = *n;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    work[i__] = (r__1 = b[i__ + j * b_dim1], abs(r__1));
+/* L30: */
+	}
+
+/*        Compute abs(A)*abs(X) + abs(B). */
+
+	kk = 1;
+	if (upper) {
+	    i__2 = *n;
+	    for (k = 1; k <= i__2; ++k) {
+		s = 0.f;
+		xk = (r__1 = x[k + j * x_dim1], abs(r__1));
+		ik = kk;
+		i__3 = k - 1;
+		for (i__ = 1; i__ <= i__3; ++i__) {
+		    work[i__] += (r__1 = ap[ik], abs(r__1)) * xk;
+		    s += (r__1 = ap[ik], abs(r__1)) * (r__2 = x[i__ + j * 
+			    x_dim1], abs(r__2));
+		    ++ik;
+/* L40: */
+		}
+		work[k] = work[k] + (r__1 = ap[kk + k - 1], abs(r__1)) * xk + 
+			s;
+		kk += k;
+/* L50: */
+	    }
+	} else {
+	    i__2 = *n;
+	    for (k = 1; k <= i__2; ++k) {
+		s = 0.f;
+		xk = (r__1 = x[k + j * x_dim1], abs(r__1));
+		work[k] += (r__1 = ap[kk], abs(r__1)) * xk;
+		ik = kk + 1;
+		i__3 = *n;
+		for (i__ = k + 1; i__ <= i__3; ++i__) {
+		    work[i__] += (r__1 = ap[ik], abs(r__1)) * xk;
+		    s += (r__1 = ap[ik], abs(r__1)) * (r__2 = x[i__ + j * 
+			    x_dim1], abs(r__2));
+		    ++ik;
+/* L60: */
+		}
+		work[k] += s;
+		kk += *n - k + 1;
+/* L70: */
+	    }
+	}
+	s = 0.f;
+	i__2 = *n;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    if (work[i__] > safe2) {
+/* Computing MAX */
+		r__2 = s, r__3 = (r__1 = work[*n + i__], abs(r__1)) / work[
+			i__];
+		s = f2cmax(r__2,r__3);
+	    } else {
+/* Computing MAX */
+		r__2 = s, r__3 = ((r__1 = work[*n + i__], abs(r__1)) + safe1) 
+			/ (work[i__] + safe1);
+		s = f2cmax(r__2,r__3);
+	    }
+/* L80: */
+	}
+	berr[j] = s;
+
+/*        Test stopping criterion. Continue iterating if */
+/*           1) The residual BERR(J) is larger than machine epsilon, and */
+/*           2) BERR(J) decreased by at least a factor of 2 during the */
+/*              last iteration, and */
+/*           3) At most ITMAX iterations tried. */
+
+	if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
+
+/*           Update solution and try again. */
+
+	    ssptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n, info);
+	    saxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
+		    ;
+	    lstres = berr[j];
+	    ++count;
+	    goto L20;
+	}
+
+/*        Bound error from formula */
+
+/*        norm(X - XTRUE) / norm(X) .le. FERR = */
+/*        norm( abs(inv(A))* */
+/*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/*        where */
+/*          norm(Z) is the magnitude of the largest component of Z */
+/*          inv(A) is the inverse of A */
+/*          abs(Z) is the componentwise absolute value of the matrix or */
+/*             vector Z */
+/*          NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/*          EPS is machine epsilon */
+
+/*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/*        is incremented by SAFE1 if the i-th component of */
+/*        abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/*        Use SLACN2 to estimate the infinity-norm of the matrix */
+/*           inv(A) * diag(W), */
+/*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+	i__2 = *n;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    if (work[i__] > safe2) {
+		work[i__] = (r__1 = work[*n + i__], abs(r__1)) + nz * eps * 
+			work[i__];
+	    } else {
+		work[i__] = (r__1 = work[*n + i__], abs(r__1)) + nz * eps * 
+			work[i__] + safe1;
+	    }
+/* L90: */
+	}
+
+	kase = 0;
+L100:
+	slacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+		kase, isave);
+	if (kase != 0) {
+	    if (kase == 1) {
+
+/*              Multiply by diag(W)*inv(A**T). */
+
+		ssptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n, 
+			info);
+		i__2 = *n;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    work[*n + i__] = work[i__] * work[*n + i__];
+/* L110: */
+		}
+	    } else if (kase == 2) {
+
+/*              Multiply by inv(A)*diag(W). */
+
+		i__2 = *n;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    work[*n + i__] = work[i__] * work[*n + i__];
+/* L120: */
+		}
+		ssptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[*n + 1], n, 
+			info);
+	    }
+	    goto L100;
+	}
+
+/*        Normalize error. */
+
+	lstres = 0.f;
+	i__2 = *n;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+	    r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], abs(r__1));
+	    lstres = f2cmax(r__2,r__3);
+/* L130: */
+	}
+	if (lstres != 0.f) {
+	    ferr[j] /= lstres;
+	}
+
+/* L140: */
+    }
+
+    return 0;
+
+/*     End of SSPRFS */
+
+} /* ssprfs_ */
+

lapack-netlib/SRC/sspsv.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)
+*/
+
+
+
+/* > \brief <b> SSPSV computes the solution to system of linear equations A * X = B for OTHER matrices</b> */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSPSV + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sspsv.f
+"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sspsv.f
+"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sspsv.f
+"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDB, N, NRHS */
+/*       INTEGER            IPIV( * ) */
+/*       REAL               AP( * ), B( LDB, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSPSV computes the solution to a real system of linear equations */
+/* >    A * X = B, */
+/* > where A is an N-by-N symmetric matrix stored in packed format and X */
+/* > and B are N-by-NRHS matrices. */
+/* > */
+/* > The diagonal pivoting method is used to factor A as */
+/* >    A = U * D * U**T,  if UPLO = 'U', or */
+/* >    A = L * D * L**T,  if UPLO = 'L', */
+/* > where U (or L) is a product of permutation and unit upper (lower) */
+/* > triangular matrices, D is symmetric and block diagonal with 1-by-1 */
+/* > and 2-by-2 diagonal blocks.  The factored form of A is then used to */
+/* > solve the system of equations A * X = B. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of linear equations, i.e., the order of the */
+/* >          matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The number of right hand sides, i.e., the number of columns */
+/* >          of the matrix B.  NRHS >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] AP */
+/* > \verbatim */
+/* >          AP is REAL array, dimension (N*(N+1)/2) */
+/* >          On entry, the upper or lower triangle of the symmetric matrix */
+/* >          A, packed columnwise in a linear array.  The j-th column of A */
+/* >          is stored in the array AP as follows: */
+/* >          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* >          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
+/* >          See below for further details. */
+/* > */
+/* >          On exit, the block diagonal matrix D and the multipliers used */
+/* >          to obtain the factor U or L from the factorization */
+/* >          A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as */
+/* >          a packed triangular matrix in the same storage format as A. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges and the block structure of D, as */
+/* >          determined by SSPTRF.  If IPIV(k) > 0, then rows and columns */
+/* >          k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 */
+/* >          diagonal block.  If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, */
+/* >          then rows and columns k-1 and -IPIV(k) were interchanged and */
+/* >          D(k-1:k,k-1:k) is a 2-by-2 diagonal block.  If UPLO = 'L' and */
+/* >          IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and */
+/* >          -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 */
+/* >          diagonal block. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB,NRHS) */
+/* >          On entry, the N-by-NRHS right hand side matrix B. */
+/* >          On exit, if INFO = 0, the N-by-NRHS solution matrix X. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0:  if INFO = i, D(i,i) is exactly zero.  The factorization */
+/* >                has been completed, but the block diagonal matrix D is */
+/* >                exactly singular, so the solution could not be */
+/* >                computed. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realOTHERsolve */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  The packed storage scheme is illustrated by the following example */
+/* >  when N = 4, UPLO = 'U': */
+/* > */
+/* >  Two-dimensional storage of the symmetric matrix A: */
+/* > */
+/* >     a11 a12 a13 a14 */
+/* >         a22 a23 a24 */
+/* >             a33 a34     (aij = aji) */
+/* >                 a44 */
+/* > */
+/* >  Packed storage of the upper triangle of A: */
+/* > */
+/* >  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int sspsv_(char *uplo, integer *n, integer *nrhs, real *ap, 
+	integer *ipiv, real *b, integer *ldb, integer *info)
+{
+    /* System generated locals */
+    integer b_dim1, b_offset, i__1;
+
+    /* Local variables */
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), ssptrf_(
+	    char *, integer *, real *, integer *, integer *), ssptrs_(
+	    char *, integer *, integer *, real *, integer *, real *, integer *
+	    , integer *);
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --ap;
+    --ipiv;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+
+    /* Function Body */
+    *info = 0;
+    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*nrhs < 0) {
+	*info = -3;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -7;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSPSV ", &i__1, (ftnlen)6);
+	return 0;
+    }
+
+/*     Compute the factorization A = U*D*U**T or A = L*D*L**T. */
+
+    ssptrf_(uplo, n, &ap[1], &ipiv[1], info);
+    if (*info == 0) {
+
+/*        Solve the system A*X = B, overwriting B with X. */
+
+	ssptrs_(uplo, n, nrhs, &ap[1], &ipiv[1], &b[b_offset], ldb, info);
+
+    }
+    return 0;
+
+/*     End of SSPSV */
+
+} /* sspsv_ */
+

lapack-netlib/SRC/sspsvx.c

@@ -0,0 +1,791 @@
+/* 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;
+
+/* > \brief <b> SSPSVX computes the solution to system of linear equations A * X = B for OTHER matrices</b> */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSPSVX + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sspsvx.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sspsvx.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sspsvx.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, */
+/*                          LDX, RCOND, FERR, BERR, WORK, IWORK, INFO ) */
+
+/*       CHARACTER          FACT, UPLO */
+/*       INTEGER            INFO, LDB, LDX, N, NRHS */
+/*       REAL               RCOND */
+/*       INTEGER            IPIV( * ), IWORK( * ) */
+/*       REAL               AFP( * ), AP( * ), B( LDB, * ), BERR( * ), */
+/*      $                   FERR( * ), WORK( * ), X( LDX, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSPSVX uses the diagonal pivoting factorization A = U*D*U**T or */
+/* > A = L*D*L**T to compute the solution to a real system of linear */
+/* > equations A * X = B, where A is an N-by-N symmetric matrix stored */
+/* > in packed format and X and B are N-by-NRHS matrices. */
+/* > */
+/* > Error bounds on the solution and a condition estimate are also */
+/* > provided. */
+/* > \endverbatim */
+
+/* > \par Description: */
+/*  ================= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > The following steps are performed: */
+/* > */
+/* > 1. If FACT = 'N', the diagonal pivoting method is used to factor A as */
+/* >       A = U * D * U**T,  if UPLO = 'U', or */
+/* >       A = L * D * L**T,  if UPLO = 'L', */
+/* >    where U (or L) is a product of permutation and unit upper (lower) */
+/* >    triangular matrices and D is symmetric and block diagonal with */
+/* >    1-by-1 and 2-by-2 diagonal blocks. */
+/* > */
+/* > 2. If some D(i,i)=0, so that D is exactly singular, then the routine */
+/* >    returns with INFO = i. Otherwise, the factored form of A is used */
+/* >    to estimate the condition number of the matrix A.  If the */
+/* >    reciprocal of the condition number is less than machine precision, */
+/* >    INFO = N+1 is returned as a warning, but the routine still goes on */
+/* >    to solve for X and compute error bounds as described below. */
+/* > */
+/* > 3. The system of equations is solved for X using the factored form */
+/* >    of A. */
+/* > */
+/* > 4. Iterative refinement is applied to improve the computed solution */
+/* >    matrix and calculate error bounds and backward error estimates */
+/* >    for it. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] FACT */
+/* > \verbatim */
+/* >          FACT is CHARACTER*1 */
+/* >          Specifies whether or not the factored form of A has been */
+/* >          supplied on entry. */
+/* >          = 'F':  On entry, AFP and IPIV contain the factored form of */
+/* >                  A.  AP, AFP and IPIV will not be modified. */
+/* >          = 'N':  The matrix A will be copied to AFP and factored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of linear equations, i.e., the order of the */
+/* >          matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The number of right hand sides, i.e., the number of columns */
+/* >          of the matrices B and X.  NRHS >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] AP */
+/* > \verbatim */
+/* >          AP is REAL array, dimension (N*(N+1)/2) */
+/* >          The upper or lower triangle of the symmetric matrix A, packed */
+/* >          columnwise in a linear array.  The j-th column of A is stored */
+/* >          in the array AP as follows: */
+/* >          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* >          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* >          See below for further details. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] AFP */
+/* > \verbatim */
+/* >          AFP is REAL array, dimension (N*(N+1)/2) */
+/* >          If FACT = 'F', then AFP is an input argument and on entry */
+/* >          contains the block diagonal matrix D and the multipliers used */
+/* >          to obtain the factor U or L from the factorization */
+/* >          A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as */
+/* >          a packed triangular matrix in the same storage format as A. */
+/* > */
+/* >          If FACT = 'N', then AFP is an output argument and on exit */
+/* >          contains the block diagonal matrix D and the multipliers used */
+/* >          to obtain the factor U or L from the factorization */
+/* >          A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as */
+/* >          a packed triangular matrix in the same storage format as A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          If FACT = 'F', then IPIV is an input argument and on entry */
+/* >          contains details of the interchanges and the block structure */
+/* >          of D, as determined by SSPTRF. */
+/* >          If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* >          interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* >          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* >          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* >          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) = */
+/* >          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* >          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+/* > */
+/* >          If FACT = 'N', then IPIV is an output argument and on exit */
+/* >          contains details of the interchanges and the block structure */
+/* >          of D, as determined by SSPTRF. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB,NRHS) */
+/* >          The N-by-NRHS right hand side matrix B. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] X */
+/* > \verbatim */
+/* >          X is REAL array, dimension (LDX,NRHS) */
+/* >          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDX */
+/* > \verbatim */
+/* >          LDX is INTEGER */
+/* >          The leading dimension of the array X.  LDX >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] RCOND */
+/* > \verbatim */
+/* >          RCOND is REAL */
+/* >          The estimate of the reciprocal condition number of the matrix */
+/* >          A.  If RCOND is less than the machine precision (in */
+/* >          particular, if RCOND = 0), the matrix is singular to working */
+/* >          precision.  This condition is indicated by a return code of */
+/* >          INFO > 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] FERR */
+/* > \verbatim */
+/* >          FERR is REAL array, dimension (NRHS) */
+/* >          The estimated forward error bound for each solution vector */
+/* >          X(j) (the j-th column of the solution matrix X). */
+/* >          If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* >          is an estimated upper bound for the magnitude of the largest */
+/* >          element in (X(j) - XTRUE) divided by the magnitude of the */
+/* >          largest element in X(j).  The estimate is as reliable as */
+/* >          the estimate for RCOND, and is almost always a slight */
+/* >          overestimate of the true error. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] BERR */
+/* > \verbatim */
+/* >          BERR is REAL array, dimension (NRHS) */
+/* >          The componentwise relative backward error of each solution */
+/* >          vector X(j) (i.e., the smallest relative change in */
+/* >          any element of A or B that makes X(j) an exact solution). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (3*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit */
+/* >          < 0: if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0:  if INFO = i, and i is */
+/* >                <= N:  D(i,i) is exactly zero.  The factorization */
+/* >                       has been completed but the factor D is exactly */
+/* >                       singular, so the solution and error bounds could */
+/* >                       not be computed. RCOND = 0 is returned. */
+/* >                = N+1: D is nonsingular, but RCOND is less than machine */
+/* >                       precision, meaning that the matrix is singular */
+/* >                       to working precision.  Nevertheless, the */
+/* >                       solution and error bounds are computed because */
+/* >                       there are a number of situations where the */
+/* >                       computed solution can be more accurate than the */
+/* >                       value of RCOND would suggest. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date April 2012 */
+
+/* > \ingroup realOTHERsolve */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  The packed storage scheme is illustrated by the following example */
+/* >  when N = 4, UPLO = 'U': */
+/* > */
+/* >  Two-dimensional storage of the symmetric matrix A: */
+/* > */
+/* >     a11 a12 a13 a14 */
+/* >         a22 a23 a24 */
+/* >             a33 a34     (aij = aji) */
+/* >                 a44 */
+/* > */
+/* >  Packed storage of the upper triangle of A: */
+/* > */
+/* >  AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int sspsvx_(char *fact, char *uplo, integer *n, integer *
+	nrhs, real *ap, real *afp, integer *ipiv, real *b, integer *ldb, real 
+	*x, integer *ldx, real *rcond, real *ferr, real *berr, real *work, 
+	integer *iwork, integer *info)
+{
+    /* System generated locals */
+    integer b_dim1, b_offset, x_dim1, x_offset, i__1;
+
+    /* Local variables */
+    extern logical lsame_(char *, char *);
+    real anorm;
+    extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, 
+	    integer *);
+    extern real slamch_(char *);
+    logical nofact;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slacpy_(
+	    char *, integer *, integer *, real *, integer *, real *, integer *
+	    );
+    extern real slansp_(char *, char *, integer *, real *, real *);
+    extern /* Subroutine */ int sspcon_(char *, integer *, real *, integer *, 
+	    real *, real *, real *, integer *, integer *), ssprfs_(
+	    char *, integer *, integer *, real *, real *, integer *, real *, 
+	    integer *, real *, integer *, real *, real *, real *, integer *, 
+	    integer *), ssptrf_(char *, integer *, real *, integer *, 
+	    integer *), ssptrs_(char *, integer *, integer *, real *, 
+	    integer *, real *, integer *, integer *);
+
+
+/*  -- LAPACK driver routine (version 3.7.1) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     April 2012 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --ap;
+    --afp;
+    --ipiv;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    x_dim1 = *ldx;
+    x_offset = 1 + x_dim1 * 1;
+    x -= x_offset;
+    --ferr;
+    --berr;
+    --work;
+    --iwork;
+
+    /* Function Body */
+    *info = 0;
+    nofact = lsame_(fact, "N");
+    if (! nofact && ! lsame_(fact, "F")) {
+	*info = -1;
+    } else if (! lsame_(uplo, "U") && ! lsame_(uplo, 
+	    "L")) {
+	*info = -2;
+    } else if (*n < 0) {
+	*info = -3;
+    } else if (*nrhs < 0) {
+	*info = -4;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -9;
+    } else if (*ldx < f2cmax(1,*n)) {
+	*info = -11;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSPSVX", &i__1, (ftnlen)6);
+	return 0;
+    }
+
+    if (nofact) {
+
+/*        Compute the factorization A = U*D*U**T or A = L*D*L**T. */
+
+	i__1 = *n * (*n + 1) / 2;
+	scopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1);
+	ssptrf_(uplo, n, &afp[1], &ipiv[1], info);
+
+/*        Return if INFO is non-zero. */
+
+	if (*info > 0) {
+	    *rcond = 0.f;
+	    return 0;
+	}
+    }
+
+/*     Compute the norm of the matrix A. */
+
+    anorm = slansp_("I", uplo, n, &ap[1], &work[1]);
+
+/*     Compute the reciprocal of the condition number of A. */
+
+    sspcon_(uplo, n, &afp[1], &ipiv[1], &anorm, rcond, &work[1], &iwork[1], 
+	    info);
+
+/*     Compute the solution vectors X. */
+
+    slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+    ssptrs_(uplo, n, nrhs, &afp[1], &ipiv[1], &x[x_offset], ldx, info);
+
+/*     Use iterative refinement to improve the computed solutions and */
+/*     compute error bounds and backward error estimates for them. */
+
+    ssprfs_(uplo, n, nrhs, &ap[1], &afp[1], &ipiv[1], &b[b_offset], ldb, &x[
+	    x_offset], ldx, &ferr[1], &berr[1], &work[1], &iwork[1], info);
+
+/*     Set INFO = N+1 if the matrix is singular to working precision. */
+
+    if (*rcond < slamch_("Epsilon")) {
+	*info = *n + 1;
+    }
+
+    return 0;
+
+/*     End of SSPSVX */
+
+} /* sspsvx_ */
+

lapack-netlib/SRC/ssptrd.c

@@ -0,0 +1,710 @@
+/* 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 real c_b8 = 0.f;
+static real c_b14 = -1.f;
+
+/* > \brief \b SSPTRD */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSPTRD + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssptrd.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssptrd.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssptrd.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSPTRD( UPLO, N, AP, D, E, TAU, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, N */
+/*       REAL               AP( * ), D( * ), E( * ), TAU( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSPTRD reduces a real symmetric matrix A stored in packed form to */
+/* > symmetric tridiagonal form T by an orthogonal similarity */
+/* > transformation: Q**T * A * Q = T. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] AP */
+/* > \verbatim */
+/* >          AP is REAL array, dimension (N*(N+1)/2) */
+/* >          On entry, the upper or lower triangle of the symmetric matrix */
+/* >          A, packed columnwise in a linear array.  The j-th column of A */
+/* >          is stored in the array AP as follows: */
+/* >          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
+/* >          if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
+/* >          On exit, if UPLO = 'U', the diagonal and first superdiagonal */
+/* >          of A are overwritten by the corresponding elements of the */
+/* >          tridiagonal matrix T, and the elements above the first */
+/* >          superdiagonal, with the array TAU, represent the orthogonal */
+/* >          matrix Q as a product of elementary reflectors; if UPLO */
+/* >          = 'L', the diagonal and first subdiagonal of A are over- */
+/* >          written by the corresponding elements of the tridiagonal */
+/* >          matrix T, and the elements below the first subdiagonal, with */
+/* >          the array TAU, represent the orthogonal matrix Q as a product */
+/* >          of elementary reflectors. See Further Details. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] D */
+/* > \verbatim */
+/* >          D is REAL array, dimension (N) */
+/* >          The diagonal elements of the tridiagonal matrix T: */
+/* >          D(i) = A(i,i). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] E */
+/* > \verbatim */
+/* >          E is REAL array, dimension (N-1) */
+/* >          The off-diagonal elements of the tridiagonal matrix T: */
+/* >          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] TAU */
+/* > \verbatim */
+/* >          TAU is REAL array, dimension (N-1) */
+/* >          The scalar factors of the elementary reflectors (see Further */
+/* >          Details). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realOTHERcomputational */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  If UPLO = 'U', the matrix Q is represented as a product of elementary */
+/* >  reflectors */
+/* > */
+/* >     Q = H(n-1) . . . H(2) H(1). */
+/* > */
+/* >  Each H(i) has the form */
+/* > */
+/* >     H(i) = I - tau * v * v**T */
+/* > */
+/* >  where tau is a real scalar, and v is a real vector with */
+/* >  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP, */
+/* >  overwriting A(1:i-1,i+1), and tau is stored in TAU(i). */
+/* > */
+/* >  If UPLO = 'L', the matrix Q is represented as a product of elementary */
+/* >  reflectors */
+/* > */
+/* >     Q = H(1) H(2) . . . H(n-1). */
+/* > */
+/* >  Each H(i) has the form */
+/* > */
+/* >     H(i) = I - tau * v * v**T */
+/* > */
+/* >  where tau is a real scalar, and v is a real vector with */
+/* >  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP, */
+/* >  overwriting A(i+2:n,i), and tau is stored in TAU(i). */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int ssptrd_(char *uplo, integer *n, real *ap, real *d__, 
+	real *e, real *tau, integer *info)
+{
+    /* System generated locals */
+    integer i__1, i__2;
+
+    /* Local variables */
+    real taui;
+    extern real sdot_(integer *, real *, integer *, real *, integer *);
+    integer i__;
+    extern /* Subroutine */ int sspr2_(char *, integer *, real *, real *, 
+	    integer *, real *, integer *, real *);
+    real alpha;
+    extern logical lsame_(char *, char *);
+    integer i1;
+    logical upper;
+    extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, 
+	    real *, integer *), sspmv_(char *, integer *, real *, real *, 
+	    real *, integer *, real *, real *, integer *);
+    integer ii;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slarfg_(
+	    integer *, real *, real *, integer *, real *);
+    integer i1i1;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters */
+
+    /* Parameter adjustments */
+    --tau;
+    --e;
+    --d__;
+    --ap;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSPTRD", &i__1, (ftnlen)6);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n <= 0) {
+	return 0;
+    }
+
+    if (upper) {
+
+/*        Reduce the upper triangle of A. */
+/*        I1 is the index in AP of A(1,I+1). */
+
+	i1 = *n * (*n - 1) / 2 + 1;
+	for (i__ = *n - 1; i__ >= 1; --i__) {
+
+/*           Generate elementary reflector H(i) = I - tau * v * v**T */
+/*           to annihilate A(1:i-1,i+1) */
+
+	    slarfg_(&i__, &ap[i1 + i__ - 1], &ap[i1], &c__1, &taui);
+	    e[i__] = ap[i1 + i__ - 1];
+
+	    if (taui != 0.f) {
+
+/*              Apply H(i) from both sides to A(1:i,1:i) */
+
+		ap[i1 + i__ - 1] = 1.f;
+
+/*              Compute  y := tau * A * v  storing y in TAU(1:i) */
+
+		sspmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b8, &tau[
+			1], &c__1);
+
+/*              Compute  w := y - 1/2 * tau * (y**T *v) * v */
+
+		alpha = taui * -.5f * sdot_(&i__, &tau[1], &c__1, &ap[i1], &
+			c__1);
+		saxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1);
+
+/*              Apply the transformation as a rank-2 update: */
+/*                 A := A - v * w**T - w * v**T */
+
+		sspr2_(uplo, &i__, &c_b14, &ap[i1], &c__1, &tau[1], &c__1, &
+			ap[1]);
+
+		ap[i1 + i__ - 1] = e[i__];
+	    }
+	    d__[i__ + 1] = ap[i1 + i__];
+	    tau[i__] = taui;
+	    i1 -= i__;
+/* L10: */
+	}
+	d__[1] = ap[1];
+    } else {
+
+/*        Reduce the lower triangle of A. II is the index in AP of */
+/*        A(i,i) and I1I1 is the index of A(i+1,i+1). */
+
+	ii = 1;
+	i__1 = *n - 1;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    i1i1 = ii + *n - i__ + 1;
+
+/*           Generate elementary reflector H(i) = I - tau * v * v**T */
+/*           to annihilate A(i+2:n,i) */
+
+	    i__2 = *n - i__;
+	    slarfg_(&i__2, &ap[ii + 1], &ap[ii + 2], &c__1, &taui);
+	    e[i__] = ap[ii + 1];
+
+	    if (taui != 0.f) {
+
+/*              Apply H(i) from both sides to A(i+1:n,i+1:n) */
+
+		ap[ii + 1] = 1.f;
+
+/*              Compute  y := tau * A * v  storing y in TAU(i:n-1) */
+
+		i__2 = *n - i__;
+		sspmv_(uplo, &i__2, &taui, &ap[i1i1], &ap[ii + 1], &c__1, &
+			c_b8, &tau[i__], &c__1);
+
+/*              Compute  w := y - 1/2 * tau * (y**T *v) * v */
+
+		i__2 = *n - i__;
+		alpha = taui * -.5f * sdot_(&i__2, &tau[i__], &c__1, &ap[ii + 
+			1], &c__1);
+		i__2 = *n - i__;
+		saxpy_(&i__2, &alpha, &ap[ii + 1], &c__1, &tau[i__], &c__1);
+
+/*              Apply the transformation as a rank-2 update: */
+/*                 A := A - v * w**T - w * v**T */
+
+		i__2 = *n - i__;
+		sspr2_(uplo, &i__2, &c_b14, &ap[ii + 1], &c__1, &tau[i__], &
+			c__1, &ap[i1i1]);
+
+		ap[ii + 1] = e[i__];
+	    }
+	    d__[i__] = ap[ii];
+	    tau[i__] = taui;
+	    ii = i1i1;
+/* L20: */
+	}
+	d__[*n] = ap[ii];
+    }
+
+    return 0;
+
+/*     End of SSPTRD */
+
+} /* ssptrd_ */
+

lapack-netlib/SRC/ssptri.c

@@ -0,0 +1,834 @@
+/* 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 real c_b11 = -1.f;
+static real c_b13 = 0.f;
+
+/* > \brief \b SSPTRI */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSPTRI + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssptri.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssptri.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssptri.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSPTRI( UPLO, N, AP, IPIV, WORK, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, N */
+/*       INTEGER            IPIV( * ) */
+/*       REAL               AP( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSPTRI computes the inverse of a real symmetric indefinite matrix */
+/* > A in packed storage using the factorization A = U*D*U**T or */
+/* > A = L*D*L**T computed by SSPTRF. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the details of the factorization are stored */
+/* >          as an upper or lower triangular matrix. */
+/* >          = 'U':  Upper triangular, form is A = U*D*U**T; */
+/* >          = 'L':  Lower triangular, form is A = L*D*L**T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] AP */
+/* > \verbatim */
+/* >          AP is REAL array, dimension (N*(N+1)/2) */
+/* >          On entry, the block diagonal matrix D and the multipliers */
+/* >          used to obtain the factor U or L as computed by SSPTRF, */
+/* >          stored as a packed triangular matrix. */
+/* > */
+/* >          On exit, if INFO = 0, the (symmetric) inverse of the original */
+/* >          matrix, stored as a packed triangular matrix. The j-th column */
+/* >          of inv(A) is stored in the array AP as follows: */
+/* >          if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; */
+/* >          if UPLO = 'L', */
+/* >             AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges and the block structure of D */
+/* >          as determined by SSPTRF. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit */
+/* >          < 0: if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */
+/* >               inverse could not be computed. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realOTHERcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssptri_(char *uplo, integer *n, real *ap, integer *ipiv, 
+	real *work, integer *info)
+{
+    /* System generated locals */
+    integer i__1;
+    real r__1;
+
+    /* Local variables */
+    real temp;
+    extern real sdot_(integer *, real *, integer *, real *, integer *);
+    real akkp1, d__;
+    integer j, k;
+    real t;
+    extern logical lsame_(char *, char *);
+    integer kstep;
+    logical upper;
+    extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, 
+	    integer *), sswap_(integer *, real *, integer *, real *, integer *
+	    ), sspmv_(char *, integer *, real *, real *, real *, integer *, 
+	    real *, real *, integer *);
+    real ak;
+    integer kc, kp, kx;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    integer kcnext, kpc, npp;
+    real akp1;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --work;
+    --ipiv;
+    --ap;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSPTRI", &i__1, (ftnlen)6);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+/*     Check that the diagonal matrix D is nonsingular. */
+
+    if (upper) {
+
+/*        Upper triangular storage: examine D from bottom to top */
+
+	kp = *n * (*n + 1) / 2;
+	for (*info = *n; *info >= 1; --(*info)) {
+	    if (ipiv[*info] > 0 && ap[kp] == 0.f) {
+		return 0;
+	    }
+	    kp -= *info;
+/* L10: */
+	}
+    } else {
+
+/*        Lower triangular storage: examine D from top to bottom. */
+
+	kp = 1;
+	i__1 = *n;
+	for (*info = 1; *info <= i__1; ++(*info)) {
+	    if (ipiv[*info] > 0 && ap[kp] == 0.f) {
+		return 0;
+	    }
+	    kp = kp + *n - *info + 1;
+/* L20: */
+	}
+    }
+    *info = 0;
+
+    if (upper) {
+
+/*        Compute inv(A) from the factorization A = U*D*U**T. */
+
+/*        K is the main loop index, increasing from 1 to N in steps of */
+/*        1 or 2, depending on the size of the diagonal blocks. */
+
+	k = 1;
+	kc = 1;
+L30:
+
+/*        If K > N, exit from loop. */
+
+	if (k > *n) {
+	    goto L50;
+	}
+
+	kcnext = kc + k;
+	if (ipiv[k] > 0) {
+
+/*           1 x 1 diagonal block */
+
+/*           Invert the diagonal block. */
+
+	    ap[kc + k - 1] = 1.f / ap[kc + k - 1];
+
+/*           Compute column K of the inverse. */
+
+	    if (k > 1) {
+		i__1 = k - 1;
+		scopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
+		i__1 = k - 1;
+		sspmv_(uplo, &i__1, &c_b11, &ap[1], &work[1], &c__1, &c_b13, &
+			ap[kc], &c__1);
+		i__1 = k - 1;
+		ap[kc + k - 1] -= sdot_(&i__1, &work[1], &c__1, &ap[kc], &
+			c__1);
+	    }
+	    kstep = 1;
+	} else {
+
+/*           2 x 2 diagonal block */
+
+/*           Invert the diagonal block. */
+
+	    t = (r__1 = ap[kcnext + k - 1], abs(r__1));
+	    ak = ap[kc + k - 1] / t;
+	    akp1 = ap[kcnext + k] / t;
+	    akkp1 = ap[kcnext + k - 1] / t;
+	    d__ = t * (ak * akp1 - 1.f);
+	    ap[kc + k - 1] = akp1 / d__;
+	    ap[kcnext + k] = ak / d__;
+	    ap[kcnext + k - 1] = -akkp1 / d__;
+
+/*           Compute columns K and K+1 of the inverse. */
+
+	    if (k > 1) {
+		i__1 = k - 1;
+		scopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1);
+		i__1 = k - 1;
+		sspmv_(uplo, &i__1, &c_b11, &ap[1], &work[1], &c__1, &c_b13, &
+			ap[kc], &c__1);
+		i__1 = k - 1;
+		ap[kc + k - 1] -= sdot_(&i__1, &work[1], &c__1, &ap[kc], &
+			c__1);
+		i__1 = k - 1;
+		ap[kcnext + k - 1] -= sdot_(&i__1, &ap[kc], &c__1, &ap[kcnext]
+			, &c__1);
+		i__1 = k - 1;
+		scopy_(&i__1, &ap[kcnext], &c__1, &work[1], &c__1);
+		i__1 = k - 1;
+		sspmv_(uplo, &i__1, &c_b11, &ap[1], &work[1], &c__1, &c_b13, &
+			ap[kcnext], &c__1);
+		i__1 = k - 1;
+		ap[kcnext + k] -= sdot_(&i__1, &work[1], &c__1, &ap[kcnext], &
+			c__1);
+	    }
+	    kstep = 2;
+	    kcnext = kcnext + k + 1;
+	}
+
+	kp = (i__1 = ipiv[k], abs(i__1));
+	if (kp != k) {
+
+/*           Interchange rows and columns K and KP in the leading */
+/*           submatrix A(1:k+1,1:k+1) */
+
+	    kpc = (kp - 1) * kp / 2 + 1;
+	    i__1 = kp - 1;
+	    sswap_(&i__1, &ap[kc], &c__1, &ap[kpc], &c__1);
+	    kx = kpc + kp - 1;
+	    i__1 = k - 1;
+	    for (j = kp + 1; j <= i__1; ++j) {
+		kx = kx + j - 1;
+		temp = ap[kc + j - 1];
+		ap[kc + j - 1] = ap[kx];
+		ap[kx] = temp;
+/* L40: */
+	    }
+	    temp = ap[kc + k - 1];
+	    ap[kc + k - 1] = ap[kpc + kp - 1];
+	    ap[kpc + kp - 1] = temp;
+	    if (kstep == 2) {
+		temp = ap[kc + k + k - 1];
+		ap[kc + k + k - 1] = ap[kc + k + kp - 1];
+		ap[kc + k + kp - 1] = temp;
+	    }
+	}
+
+	k += kstep;
+	kc = kcnext;
+	goto L30;
+L50:
+
+	;
+    } else {
+
+/*        Compute inv(A) from the factorization A = L*D*L**T. */
+
+/*        K is the main loop index, increasing from 1 to N in steps of */
+/*        1 or 2, depending on the size of the diagonal blocks. */
+
+	npp = *n * (*n + 1) / 2;
+	k = *n;
+	kc = npp;
+L60:
+
+/*        If K < 1, exit from loop. */
+
+	if (k < 1) {
+	    goto L80;
+	}
+
+	kcnext = kc - (*n - k + 2);
+	if (ipiv[k] > 0) {
+
+/*           1 x 1 diagonal block */
+
+/*           Invert the diagonal block. */
+
+	    ap[kc] = 1.f / ap[kc];
+
+/*           Compute column K of the inverse. */
+
+	    if (k < *n) {
+		i__1 = *n - k;
+		scopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
+		i__1 = *n - k;
+		sspmv_(uplo, &i__1, &c_b11, &ap[kc + *n - k + 1], &work[1], &
+			c__1, &c_b13, &ap[kc + 1], &c__1);
+		i__1 = *n - k;
+		ap[kc] -= sdot_(&i__1, &work[1], &c__1, &ap[kc + 1], &c__1);
+	    }
+	    kstep = 1;
+	} else {
+
+/*           2 x 2 diagonal block */
+
+/*           Invert the diagonal block. */
+
+	    t = (r__1 = ap[kcnext + 1], abs(r__1));
+	    ak = ap[kcnext] / t;
+	    akp1 = ap[kc] / t;
+	    akkp1 = ap[kcnext + 1] / t;
+	    d__ = t * (ak * akp1 - 1.f);
+	    ap[kcnext] = akp1 / d__;
+	    ap[kc] = ak / d__;
+	    ap[kcnext + 1] = -akkp1 / d__;
+
+/*           Compute columns K-1 and K of the inverse. */
+
+	    if (k < *n) {
+		i__1 = *n - k;
+		scopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1);
+		i__1 = *n - k;
+		sspmv_(uplo, &i__1, &c_b11, &ap[kc + (*n - k + 1)], &work[1], 
+			&c__1, &c_b13, &ap[kc + 1], &c__1);
+		i__1 = *n - k;
+		ap[kc] -= sdot_(&i__1, &work[1], &c__1, &ap[kc + 1], &c__1);
+		i__1 = *n - k;
+		ap[kcnext + 1] -= sdot_(&i__1, &ap[kc + 1], &c__1, &ap[kcnext 
+			+ 2], &c__1);
+		i__1 = *n - k;
+		scopy_(&i__1, &ap[kcnext + 2], &c__1, &work[1], &c__1);
+		i__1 = *n - k;
+		sspmv_(uplo, &i__1, &c_b11, &ap[kc + (*n - k + 1)], &work[1], 
+			&c__1, &c_b13, &ap[kcnext + 2], &c__1);
+		i__1 = *n - k;
+		ap[kcnext] -= sdot_(&i__1, &work[1], &c__1, &ap[kcnext + 2], &
+			c__1);
+	    }
+	    kstep = 2;
+	    kcnext -= *n - k + 3;
+	}
+
+	kp = (i__1 = ipiv[k], abs(i__1));
+	if (kp != k) {
+
+/*           Interchange rows and columns K and KP in the trailing */
+/*           submatrix A(k-1:n,k-1:n) */
+
+	    kpc = npp - (*n - kp + 1) * (*n - kp + 2) / 2 + 1;
+	    if (kp < *n) {
+		i__1 = *n - kp;
+		sswap_(&i__1, &ap[kc + kp - k + 1], &c__1, &ap[kpc + 1], &
+			c__1);
+	    }
+	    kx = kc + kp - k;
+	    i__1 = kp - 1;
+	    for (j = k + 1; j <= i__1; ++j) {
+		kx = kx + *n - j + 1;
+		temp = ap[kc + j - k];
+		ap[kc + j - k] = ap[kx];
+		ap[kx] = temp;
+/* L70: */
+	    }
+	    temp = ap[kc];
+	    ap[kc] = ap[kpc];
+	    ap[kpc] = temp;
+	    if (kstep == 2) {
+		temp = ap[kc - *n + k - 1];
+		ap[kc - *n + k - 1] = ap[kc - *n + kp - 1];
+		ap[kc - *n + kp - 1] = temp;
+	    }
+	}
+
+	k -= kstep;
+	kc = kcnext;
+	goto L60;
+L80:
+	;
+    }
+
+    return 0;
+
+/*     End of SSPTRI */
+
+} /* ssptri_ */
+

lapack-netlib/SRC/ssptrs.c

@@ -0,0 +1,884 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define 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_b7 = -1.f;
+static integer c__1 = 1;
+static real c_b19 = 1.f;
+
+/* > \brief \b SSPTRS */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSPTRS + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssptrs.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssptrs.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssptrs.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDB, N, NRHS */
+/*       INTEGER            IPIV( * ) */
+/*       REAL               AP( * ), B( LDB, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSPTRS solves a system of linear equations A*X = B with a real */
+/* > symmetric matrix A stored in packed format using the factorization */
+/* > A = U*D*U**T or A = L*D*L**T computed by SSPTRF. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the details of the factorization are stored */
+/* >          as an upper or lower triangular matrix. */
+/* >          = 'U':  Upper triangular, form is A = U*D*U**T; */
+/* >          = 'L':  Lower triangular, form is A = L*D*L**T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The number of right hand sides, i.e., the number of columns */
+/* >          of the matrix B.  NRHS >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] AP */
+/* > \verbatim */
+/* >          AP is REAL array, dimension (N*(N+1)/2) */
+/* >          The block diagonal matrix D and the multipliers used to */
+/* >          obtain the factor U or L as computed by SSPTRF, stored as a */
+/* >          packed triangular matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges and the block structure of D */
+/* >          as determined by SSPTRF. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB,NRHS) */
+/* >          On entry, the right hand side matrix B. */
+/* >          On exit, the solution matrix X. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0: if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realOTHERcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssptrs_(char *uplo, integer *n, integer *nrhs, real *ap, 
+	integer *ipiv, real *b, integer *ldb, integer *info)
+{
+    /* System generated locals */
+    integer b_dim1, b_offset, i__1;
+    real r__1;
+
+    /* Local variables */
+    extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, 
+	    integer *, real *, integer *, real *, integer *);
+    real akm1k;
+    integer j, k;
+    extern logical lsame_(char *, char *);
+    real denom;
+    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), 
+	    sgemv_(char *, integer *, integer *, real *, real *, integer *, 
+	    real *, integer *, real *, real *, integer *);
+    logical upper;
+    extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, 
+	    integer *);
+    real ak, bk;
+    integer kc, kp;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    real akm1, bkm1;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+    /* Parameter adjustments */
+    --ap;
+    --ipiv;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*nrhs < 0) {
+	*info = -3;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -7;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSPTRS", &i__1, (ftnlen)6);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0 || *nrhs == 0) {
+	return 0;
+    }
+
+    if (upper) {
+
+/*        Solve A*X = B, where A = U*D*U**T. */
+
+/*        First solve U*D*X = B, overwriting B with X. */
+
+/*        K is the main loop index, decreasing from N to 1 in steps of */
+/*        1 or 2, depending on the size of the diagonal blocks. */
+
+	k = *n;
+	kc = *n * (*n + 1) / 2 + 1;
+L10:
+
+/*        If K < 1, exit from loop. */
+
+	if (k < 1) {
+	    goto L30;
+	}
+
+	kc -= k;
+	if (ipiv[k] > 0) {
+
+/*           1 x 1 diagonal block */
+
+/*           Interchange rows K and IPIV(K). */
+
+	    kp = ipiv[k];
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+
+/*           Multiply by inv(U(K)), where U(K) is the transformation */
+/*           stored in column K of A. */
+
+	    i__1 = k - 1;
+	    sger_(&i__1, nrhs, &c_b7, &ap[kc], &c__1, &b[k + b_dim1], ldb, &b[
+		    b_dim1 + 1], ldb);
+
+/*           Multiply by the inverse of the diagonal block. */
+
+	    r__1 = 1.f / ap[kc + k - 1];
+	    sscal_(nrhs, &r__1, &b[k + b_dim1], ldb);
+	    --k;
+	} else {
+
+/*           2 x 2 diagonal block */
+
+/*           Interchange rows K-1 and -IPIV(K). */
+
+	    kp = -ipiv[k];
+	    if (kp != k - 1) {
+		sswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+
+/*           Multiply by inv(U(K)), where U(K) is the transformation */
+/*           stored in columns K-1 and K of A. */
+
+	    i__1 = k - 2;
+	    sger_(&i__1, nrhs, &c_b7, &ap[kc], &c__1, &b[k + b_dim1], ldb, &b[
+		    b_dim1 + 1], ldb);
+	    i__1 = k - 2;
+	    sger_(&i__1, nrhs, &c_b7, &ap[kc - (k - 1)], &c__1, &b[k - 1 + 
+		    b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/*           Multiply by the inverse of the diagonal block. */
+
+	    akm1k = ap[kc + k - 2];
+	    akm1 = ap[kc - 1] / akm1k;
+	    ak = ap[kc + k - 1] / akm1k;
+	    denom = akm1 * ak - 1.f;
+	    i__1 = *nrhs;
+	    for (j = 1; j <= i__1; ++j) {
+		bkm1 = b[k - 1 + j * b_dim1] / akm1k;
+		bk = b[k + j * b_dim1] / akm1k;
+		b[k - 1 + j * b_dim1] = (ak * bkm1 - bk) / denom;
+		b[k + j * b_dim1] = (akm1 * bk - bkm1) / denom;
+/* L20: */
+	    }
+	    kc = kc - k + 1;
+	    k += -2;
+	}
+
+	goto L10;
+L30:
+
+/*        Next solve U**T*X = B, overwriting B with X. */
+
+/*        K is the main loop index, increasing from 1 to N in steps of */
+/*        1 or 2, depending on the size of the diagonal blocks. */
+
+	k = 1;
+	kc = 1;
+L40:
+
+/*        If K > N, exit from loop. */
+
+	if (k > *n) {
+	    goto L50;
+	}
+
+	if (ipiv[k] > 0) {
+
+/*           1 x 1 diagonal block */
+
+/*           Multiply by inv(U**T(K)), where U(K) is the transformation */
+/*           stored in column K of A. */
+
+	    i__1 = k - 1;
+	    sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &ap[kc]
+		    , &c__1, &c_b19, &b[k + b_dim1], ldb);
+
+/*           Interchange rows K and IPIV(K). */
+
+	    kp = ipiv[k];
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+	    kc += k;
+	    ++k;
+	} else {
+
+/*           2 x 2 diagonal block */
+
+/*           Multiply by inv(U**T(K+1)), where U(K+1) is the transformation */
+/*           stored in columns K and K+1 of A. */
+
+	    i__1 = k - 1;
+	    sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &ap[kc]
+		    , &c__1, &c_b19, &b[k + b_dim1], ldb);
+	    i__1 = k - 1;
+	    sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &ap[kc 
+		    + k], &c__1, &c_b19, &b[k + 1 + b_dim1], ldb);
+
+/*           Interchange rows K and -IPIV(K). */
+
+	    kp = -ipiv[k];
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+	    kc = kc + (k << 1) + 1;
+	    k += 2;
+	}
+
+	goto L40;
+L50:
+
+	;
+    } else {
+
+/*        Solve A*X = B, where A = L*D*L**T. */
+
+/*        First solve L*D*X = B, overwriting B with X. */
+
+/*        K is the main loop index, increasing from 1 to N in steps of */
+/*        1 or 2, depending on the size of the diagonal blocks. */
+
+	k = 1;
+	kc = 1;
+L60:
+
+/*        If K > N, exit from loop. */
+
+	if (k > *n) {
+	    goto L80;
+	}
+
+	if (ipiv[k] > 0) {
+
+/*           1 x 1 diagonal block */
+
+/*           Interchange rows K and IPIV(K). */
+
+	    kp = ipiv[k];
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+
+/*           Multiply by inv(L(K)), where L(K) is the transformation */
+/*           stored in column K of A. */
+
+	    if (k < *n) {
+		i__1 = *n - k;
+		sger_(&i__1, nrhs, &c_b7, &ap[kc + 1], &c__1, &b[k + b_dim1], 
+			ldb, &b[k + 1 + b_dim1], ldb);
+	    }
+
+/*           Multiply by the inverse of the diagonal block. */
+
+	    r__1 = 1.f / ap[kc];
+	    sscal_(nrhs, &r__1, &b[k + b_dim1], ldb);
+	    kc = kc + *n - k + 1;
+	    ++k;
+	} else {
+
+/*           2 x 2 diagonal block */
+
+/*           Interchange rows K+1 and -IPIV(K). */
+
+	    kp = -ipiv[k];
+	    if (kp != k + 1) {
+		sswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+
+/*           Multiply by inv(L(K)), where L(K) is the transformation */
+/*           stored in columns K and K+1 of A. */
+
+	    if (k < *n - 1) {
+		i__1 = *n - k - 1;
+		sger_(&i__1, nrhs, &c_b7, &ap[kc + 2], &c__1, &b[k + b_dim1], 
+			ldb, &b[k + 2 + b_dim1], ldb);
+		i__1 = *n - k - 1;
+		sger_(&i__1, nrhs, &c_b7, &ap[kc + *n - k + 2], &c__1, &b[k + 
+			1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
+	    }
+
+/*           Multiply by the inverse of the diagonal block. */
+
+	    akm1k = ap[kc + 1];
+	    akm1 = ap[kc] / akm1k;
+	    ak = ap[kc + *n - k + 1] / akm1k;
+	    denom = akm1 * ak - 1.f;
+	    i__1 = *nrhs;
+	    for (j = 1; j <= i__1; ++j) {
+		bkm1 = b[k + j * b_dim1] / akm1k;
+		bk = b[k + 1 + j * b_dim1] / akm1k;
+		b[k + j * b_dim1] = (ak * bkm1 - bk) / denom;
+		b[k + 1 + j * b_dim1] = (akm1 * bk - bkm1) / denom;
+/* L70: */
+	    }
+	    kc = kc + (*n - k << 1) + 1;
+	    k += 2;
+	}
+
+	goto L60;
+L80:
+
+/*        Next solve L**T*X = B, overwriting B with X. */
+
+/*        K is the main loop index, decreasing from N to 1 in steps of */
+/*        1 or 2, depending on the size of the diagonal blocks. */
+
+	k = *n;
+	kc = *n * (*n + 1) / 2 + 1;
+L90:
+
+/*        If K < 1, exit from loop. */
+
+	if (k < 1) {
+	    goto L100;
+	}
+
+	kc -= *n - k + 1;
+	if (ipiv[k] > 0) {
+
+/*           1 x 1 diagonal block */
+
+/*           Multiply by inv(L**T(K)), where L(K) is the transformation */
+/*           stored in column K of A. */
+
+	    if (k < *n) {
+		i__1 = *n - k;
+		sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], 
+			ldb, &ap[kc + 1], &c__1, &c_b19, &b[k + b_dim1], ldb);
+	    }
+
+/*           Interchange rows K and IPIV(K). */
+
+	    kp = ipiv[k];
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+	    --k;
+	} else {
+
+/*           2 x 2 diagonal block */
+
+/*           Multiply by inv(L**T(K-1)), where L(K-1) is the transformation */
+/*           stored in columns K-1 and K of A. */
+
+	    if (k < *n) {
+		i__1 = *n - k;
+		sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], 
+			ldb, &ap[kc + 1], &c__1, &c_b19, &b[k + b_dim1], ldb);
+		i__1 = *n - k;
+		sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], 
+			ldb, &ap[kc - (*n - k)], &c__1, &c_b19, &b[k - 1 + 
+			b_dim1], ldb);
+	    }
+
+/*           Interchange rows K and -IPIV(K). */
+
+	    kp = -ipiv[k];
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+	    kc -= *n - k + 2;
+	    k += -2;
+	}
+
+	goto L90;
+L100:
+	;
+    }
+
+    return 0;
+
+/*     End of SSPTRS */
+
+} /* ssptrs_ */
+

lapack-netlib/SRC/sstedc.c

@@ -0,0 +1,915 @@
+/* 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__9 = 9;
+static integer c__0 = 0;
+static integer c__2 = 2;
+static real c_b17 = 0.f;
+static real c_b18 = 1.f;
+static integer c__1 = 1;
+
+/* > \brief \b SSTEDC */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSTEDC + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sstedc.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sstedc.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sstedc.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, */
+/*                          LIWORK, INFO ) */
+
+/*       CHARACTER          COMPZ */
+/*       INTEGER            INFO, LDZ, LIWORK, LWORK, N */
+/*       INTEGER            IWORK( * ) */
+/*       REAL               D( * ), E( * ), WORK( * ), Z( LDZ, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSTEDC computes all eigenvalues and, optionally, eigenvectors of a */
+/* > symmetric tridiagonal matrix using the divide and conquer method. */
+/* > The eigenvectors of a full or band real symmetric matrix can also be */
+/* > found if SSYTRD or SSPTRD or SSBTRD has been used to reduce this */
+/* > matrix to tridiagonal form. */
+/* > */
+/* > This code makes very mild assumptions about floating point */
+/* > arithmetic. It will work on machines with a guard digit in */
+/* > add/subtract, or on those binary machines without guard digits */
+/* > which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */
+/* > It could conceivably fail on hexadecimal or decimal machines */
+/* > without guard digits, but we know of none.  See SLAED3 for details. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] COMPZ */
+/* > \verbatim */
+/* >          COMPZ is CHARACTER*1 */
+/* >          = 'N':  Compute eigenvalues only. */
+/* >          = 'I':  Compute eigenvectors of tridiagonal matrix also. */
+/* >          = 'V':  Compute eigenvectors of original dense symmetric */
+/* >                  matrix also.  On entry, Z contains the orthogonal */
+/* >                  matrix used to reduce the original matrix to */
+/* >                  tridiagonal form. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The dimension of the symmetric tridiagonal matrix.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] D */
+/* > \verbatim */
+/* >          D is REAL array, dimension (N) */
+/* >          On entry, the diagonal elements of the tridiagonal matrix. */
+/* >          On exit, if INFO = 0, the eigenvalues in ascending order. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] E */
+/* > \verbatim */
+/* >          E is REAL array, dimension (N-1) */
+/* >          On entry, the subdiagonal elements of the tridiagonal matrix. */
+/* >          On exit, E has been destroyed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] Z */
+/* > \verbatim */
+/* >          Z is REAL array, dimension (LDZ,N) */
+/* >          On entry, if COMPZ = 'V', then Z contains the orthogonal */
+/* >          matrix used in the reduction to tridiagonal form. */
+/* >          On exit, if INFO = 0, then if COMPZ = 'V', Z contains the */
+/* >          orthonormal eigenvectors of the original symmetric matrix, */
+/* >          and if COMPZ = 'I', Z contains the orthonormal eigenvectors */
+/* >          of the symmetric tridiagonal matrix. */
+/* >          If  COMPZ = 'N', then Z is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDZ */
+/* > \verbatim */
+/* >          LDZ is INTEGER */
+/* >          The leading dimension of the array Z.  LDZ >= 1. */
+/* >          If eigenvectors are desired, then LDZ >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (MAX(1,LWORK)) */
+/* >          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The dimension of the array WORK. */
+/* >          If COMPZ = 'N' or N <= 1 then LWORK must be at least 1. */
+/* >          If COMPZ = 'V' and N > 1 then LWORK must be at least */
+/* >                         ( 1 + 3*N + 2*N*lg N + 4*N**2 ), */
+/* >                         where lg( N ) = smallest integer k such */
+/* >                         that 2**k >= N. */
+/* >          If COMPZ = 'I' and N > 1 then LWORK must be at least */
+/* >                         ( 1 + 4*N + N**2 ). */
+/* >          Note that for COMPZ = 'I' or 'V', then if N is less than or */
+/* >          equal to the minimum divide size, usually 25, then LWORK need */
+/* >          only be f2cmax(1,2*(N-1)). */
+/* > */
+/* >          If LWORK = -1, then a workspace query is assumed; the routine */
+/* >          only calculates the optimal size of the WORK array, returns */
+/* >          this value as the first entry of the WORK array, and no error */
+/* >          message related to LWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */
+/* >          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LIWORK */
+/* > \verbatim */
+/* >          LIWORK is INTEGER */
+/* >          The dimension of the array IWORK. */
+/* >          If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1. */
+/* >          If COMPZ = 'V' and N > 1 then LIWORK must be at least */
+/* >                         ( 6 + 6*N + 5*N*lg N ). */
+/* >          If COMPZ = 'I' and N > 1 then LIWORK must be at least */
+/* >                         ( 3 + 5*N ). */
+/* >          Note that for COMPZ = 'I' or 'V', then if N is less than or */
+/* >          equal to the minimum divide size, usually 25, then LIWORK */
+/* >          need only be 1. */
+/* > */
+/* >          If LIWORK = -1, then a workspace query is assumed; the */
+/* >          routine only calculates the optimal size of the IWORK array, */
+/* >          returns this value as the first entry of the IWORK array, and */
+/* >          no error message related to LIWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit. */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value. */
+/* >          > 0:  The algorithm failed to compute an eigenvalue while */
+/* >                working on the submatrix lying in rows and columns */
+/* >                INFO/(N+1) through mod(INFO,N+1). */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup auxOTHERcomputational */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > */
+/* > Jeff Rutter, Computer Science Division, University of California */
+/* > at Berkeley, USA \n */
+/* >  Modified by Francoise Tisseur, University of Tennessee */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int sstedc_(char *compz, integer *n, real *d__, real *e, 
+	real *z__, integer *ldz, real *work, integer *lwork, integer *iwork, 
+	integer *liwork, integer *info)
+{
+    /* System generated locals */
+    integer z_dim1, z_offset, i__1, i__2;
+    real r__1, r__2;
+
+    /* Local variables */
+    real tiny;
+    integer i__, j, k, m;
+    real p;
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, 
+	    integer *, real *, real *, integer *, real *, integer *, real *, 
+	    real *, integer *);
+    integer lwmin, start;
+    extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, 
+	    integer *), slaed0_(integer *, integer *, integer *, real *, real 
+	    *, real *, integer *, real *, integer *, real *, integer *, 
+	    integer *);
+    integer ii;
+    extern real slamch_(char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
+	    integer *, integer *, ftnlen, ftnlen);
+    integer finish;
+    extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, 
+	    real *, integer *, integer *, real *, integer *, integer *), slacpy_(char *, integer *, integer *, real *, integer *, 
+	    real *, integer *), slaset_(char *, integer *, integer *, 
+	    real *, real *, real *, integer *);
+    integer liwmin, icompz;
+    real orgnrm;
+    extern real slanst_(char *, integer *, real *, real *);
+    extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *),
+	     slasrt_(char *, integer *, real *, integer *);
+    logical lquery;
+    integer smlsiz;
+    extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *, 
+	    real *, integer *, real *, integer *);
+    integer storez, strtrw, lgn;
+    real eps;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --d__;
+    --e;
+    z_dim1 = *ldz;
+    z_offset = 1 + z_dim1 * 1;
+    z__ -= z_offset;
+    --work;
+    --iwork;
+
+    /* Function Body */
+    *info = 0;
+    lquery = *lwork == -1 || *liwork == -1;
+
+    if (lsame_(compz, "N")) {
+	icompz = 0;
+    } else if (lsame_(compz, "V")) {
+	icompz = 1;
+    } else if (lsame_(compz, "I")) {
+	icompz = 2;
+    } else {
+	icompz = -1;
+    }
+    if (icompz < 0) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*ldz < 1 || icompz > 0 && *ldz < f2cmax(1,*n)) {
+	*info = -6;
+    }
+
+    if (*info == 0) {
+
+/*        Compute the workspace requirements */
+
+	smlsiz = ilaenv_(&c__9, "SSTEDC", " ", &c__0, &c__0, &c__0, &c__0, (
+		ftnlen)6, (ftnlen)1);
+	if (*n <= 1 || icompz == 0) {
+	    liwmin = 1;
+	    lwmin = 1;
+	} else if (*n <= smlsiz) {
+	    liwmin = 1;
+	    lwmin = *n - 1 << 1;
+	} else {
+	    lgn = (integer) (log((real) (*n)) / log(2.f));
+	    if (pow_ii(&c__2, &lgn) < *n) {
+		++lgn;
+	    }
+	    if (pow_ii(&c__2, &lgn) < *n) {
+		++lgn;
+	    }
+	    if (icompz == 1) {
+/* Computing 2nd power */
+		i__1 = *n;
+		lwmin = *n * 3 + 1 + (*n << 1) * lgn + (i__1 * i__1 << 2);
+		liwmin = *n * 6 + 6 + *n * 5 * lgn;
+	    } else if (icompz == 2) {
+/* Computing 2nd power */
+		i__1 = *n;
+		lwmin = (*n << 2) + 1 + i__1 * i__1;
+		liwmin = *n * 5 + 3;
+	    }
+	}
+	work[1] = (real) lwmin;
+	iwork[1] = liwmin;
+
+	if (*lwork < lwmin && ! lquery) {
+	    *info = -8;
+	} else if (*liwork < liwmin && ! lquery) {
+	    *info = -10;
+	}
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSTEDC", &i__1, (ftnlen)6);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+    if (*n == 1) {
+	if (icompz != 0) {
+	    z__[z_dim1 + 1] = 1.f;
+	}
+	return 0;
+    }
+
+/*     If the following conditional clause is removed, then the routine */
+/*     will use the Divide and Conquer routine to compute only the */
+/*     eigenvalues, which requires (3N + 3N**2) real workspace and */
+/*     (2 + 5N + 2N lg(N)) integer workspace. */
+/*     Since on many architectures SSTERF is much faster than any other */
+/*     algorithm for finding eigenvalues only, it is used here */
+/*     as the default. If the conditional clause is removed, then */
+/*     information on the size of workspace needs to be changed. */
+
+/*     If COMPZ = 'N', use SSTERF to compute the eigenvalues. */
+
+    if (icompz == 0) {
+	ssterf_(n, &d__[1], &e[1], info);
+	goto L50;
+    }
+
+/*     If N is smaller than the minimum divide size (SMLSIZ+1), then */
+/*     solve the problem with another solver. */
+
+    if (*n <= smlsiz) {
+
+	ssteqr_(compz, n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], info);
+
+    } else {
+
+/*        If COMPZ = 'V', the Z matrix must be stored elsewhere for later */
+/*        use. */
+
+	if (icompz == 1) {
+	    storez = *n * *n + 1;
+	} else {
+	    storez = 1;
+	}
+
+	if (icompz == 2) {
+	    slaset_("Full", n, n, &c_b17, &c_b18, &z__[z_offset], ldz);
+	}
+
+/*        Scale. */
+
+	orgnrm = slanst_("M", n, &d__[1], &e[1]);
+	if (orgnrm == 0.f) {
+	    goto L50;
+	}
+
+	eps = slamch_("Epsilon");
+
+	start = 1;
+
+/*        while ( START <= N ) */
+
+L10:
+	if (start <= *n) {
+
+/*           Let FINISH be the position of the next subdiagonal entry */
+/*           such that E( FINISH ) <= TINY or FINISH = N if no such */
+/*           subdiagonal exists.  The matrix identified by the elements */
+/*           between START and FINISH constitutes an independent */
+/*           sub-problem. */
+
+	    finish = start;
+L20:
+	    if (finish < *n) {
+		tiny = eps * sqrt((r__1 = d__[finish], abs(r__1))) * sqrt((
+			r__2 = d__[finish + 1], abs(r__2)));
+		if ((r__1 = e[finish], abs(r__1)) > tiny) {
+		    ++finish;
+		    goto L20;
+		}
+	    }
+
+/*           (Sub) Problem determined.  Compute its size and solve it. */
+
+	    m = finish - start + 1;
+	    if (m == 1) {
+		start = finish + 1;
+		goto L10;
+	    }
+	    if (m > smlsiz) {
+
+/*              Scale. */
+
+		orgnrm = slanst_("M", &m, &d__[start], &e[start]);
+		slascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &m, &c__1, &d__[
+			start], &m, info);
+		i__1 = m - 1;
+		i__2 = m - 1;
+		slascl_("G", &c__0, &c__0, &orgnrm, &c_b18, &i__1, &c__1, &e[
+			start], &i__2, info);
+
+		if (icompz == 1) {
+		    strtrw = 1;
+		} else {
+		    strtrw = start;
+		}
+		slaed0_(&icompz, n, &m, &d__[start], &e[start], &z__[strtrw + 
+			start * z_dim1], ldz, &work[1], n, &work[storez], &
+			iwork[1], info);
+		if (*info != 0) {
+		    *info = (*info / (m + 1) + start - 1) * (*n + 1) + *info %
+			     (m + 1) + start - 1;
+		    goto L50;
+		}
+
+/*              Scale back. */
+
+		slascl_("G", &c__0, &c__0, &c_b18, &orgnrm, &m, &c__1, &d__[
+			start], &m, info);
+
+	    } else {
+		if (icompz == 1) {
+
+/*                 Since QR won't update a Z matrix which is larger than */
+/*                 the length of D, we must solve the sub-problem in a */
+/*                 workspace and then multiply back into Z. */
+
+		    ssteqr_("I", &m, &d__[start], &e[start], &work[1], &m, &
+			    work[m * m + 1], info);
+		    slacpy_("A", n, &m, &z__[start * z_dim1 + 1], ldz, &work[
+			    storez], n);
+		    sgemm_("N", "N", n, &m, &m, &c_b18, &work[storez], n, &
+			    work[1], &m, &c_b17, &z__[start * z_dim1 + 1], 
+			    ldz);
+		} else if (icompz == 2) {
+		    ssteqr_("I", &m, &d__[start], &e[start], &z__[start + 
+			    start * z_dim1], ldz, &work[1], info);
+		} else {
+		    ssterf_(&m, &d__[start], &e[start], info);
+		}
+		if (*info != 0) {
+		    *info = start * (*n + 1) + finish;
+		    goto L50;
+		}
+	    }
+
+	    start = finish + 1;
+	    goto L10;
+	}
+
+/*        endwhile */
+
+	if (icompz == 0) {
+
+/*          Use Quick Sort */
+
+	    slasrt_("I", n, &d__[1], info);
+
+	} else {
+
+/*          Use Selection Sort to minimize swaps of eigenvectors */
+
+	    i__1 = *n;
+	    for (ii = 2; ii <= i__1; ++ii) {
+		i__ = ii - 1;
+		k = i__;
+		p = d__[i__];
+		i__2 = *n;
+		for (j = ii; j <= i__2; ++j) {
+		    if (d__[j] < p) {
+			k = j;
+			p = d__[j];
+		    }
+/* L30: */
+		}
+		if (k != i__) {
+		    d__[k] = d__[i__];
+		    d__[i__] = p;
+		    sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[k * z_dim1 
+			    + 1], &c__1);
+		}
+/* L40: */
+	    }
+	}
+    }
+
+L50:
+    work[1] = (real) lwmin;
+    iwork[1] = liwmin;
+
+    return 0;
+
+/*     End of SSTEDC */
+
+} /* sstedc_ */
+

lapack-netlib/SRC/sstegr.c

@@ -0,0 +1,697 @@
+/* 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 SSTEGR */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSTEGR + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sstegr.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sstegr.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sstegr.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, */
+/*                  ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, */
+/*                  LIWORK, INFO ) */
+
+/*       CHARACTER          JOBZ, RANGE */
+/*       INTEGER            IL, INFO, IU, LDZ, LIWORK, LWORK, M, N */
+/*       REAL             ABSTOL, VL, VU */
+/*       INTEGER            ISUPPZ( * ), IWORK( * ) */
+/*       REAL               D( * ), E( * ), W( * ), WORK( * ) */
+/*       REAL               Z( LDZ, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSTEGR computes selected eigenvalues and, optionally, eigenvectors */
+/* > of a real symmetric tridiagonal matrix T. Any such unreduced matrix has */
+/* > a well defined set of pairwise different real eigenvalues, the corresponding */
+/* > real eigenvectors are pairwise orthogonal. */
+/* > */
+/* > The spectrum may be computed either completely or partially by specifying */
+/* > either an interval (VL,VU] or a range of indices IL:IU for the desired */
+/* > eigenvalues. */
+/* > */
+/* > SSTEGR is a compatibility wrapper around the improved SSTEMR routine. */
+/* > See SSTEMR for further details. */
+/* > */
+/* > One important change is that the ABSTOL parameter no longer provides any */
+/* > benefit and hence is no longer used. */
+/* > */
+/* > Note : SSTEGR and SSTEMR work only on machines which follow */
+/* > IEEE-754 floating-point standard in their handling of infinities and */
+/* > NaNs.  Normal execution may create these exceptiona values and hence */
+/* > may abort due to a floating point exception in environments which */
+/* > do not conform to the IEEE-754 standard. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] JOBZ */
+/* > \verbatim */
+/* >          JOBZ is CHARACTER*1 */
+/* >          = 'N':  Compute eigenvalues only; */
+/* >          = 'V':  Compute eigenvalues and eigenvectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] RANGE */
+/* > \verbatim */
+/* >          RANGE is CHARACTER*1 */
+/* >          = 'A': all eigenvalues will be found. */
+/* >          = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* >                 will be found. */
+/* >          = 'I': the IL-th through IU-th eigenvalues will be found. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] D */
+/* > \verbatim */
+/* >          D is REAL array, dimension (N) */
+/* >          On entry, the N diagonal elements of the tridiagonal matrix */
+/* >          T. On exit, D is overwritten. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] E */
+/* > \verbatim */
+/* >          E is REAL array, dimension (N) */
+/* >          On entry, the (N-1) subdiagonal elements of the tridiagonal */
+/* >          matrix T in elements 1 to N-1 of E. E(N) need not be set on */
+/* >          input, but is used internally as workspace. */
+/* >          On exit, E is overwritten. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] VL */
+/* > \verbatim */
+/* >          VL is REAL */
+/* > */
+/* >          If RANGE='V', the lower bound of the interval to */
+/* >          be searched for eigenvalues. VL < VU. */
+/* >          Not referenced if RANGE = 'A' or 'I'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] VU */
+/* > \verbatim */
+/* >          VU is REAL */
+/* > */
+/* >          If RANGE='V', the upper bound of the interval to */
+/* >          be searched for eigenvalues. VL < VU. */
+/* >          Not referenced if RANGE = 'A' or 'I'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IL */
+/* > \verbatim */
+/* >          IL is INTEGER */
+/* > */
+/* >          If RANGE='I', the index of the */
+/* >          smallest eigenvalue to be returned. */
+/* >          1 <= IL <= IU <= N, if N > 0. */
+/* >          Not referenced if RANGE = 'A' or 'V'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IU */
+/* > \verbatim */
+/* >          IU is INTEGER */
+/* > */
+/* >          If RANGE='I', the index of the */
+/* >          largest eigenvalue to be returned. */
+/* >          1 <= IL <= IU <= N, if N > 0. */
+/* >          Not referenced if RANGE = 'A' or 'V'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] ABSTOL */
+/* > \verbatim */
+/* >          ABSTOL is REAL */
+/* >          Unused.  Was the absolute error tolerance for the */
+/* >          eigenvalues/eigenvectors in previous versions. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The total number of eigenvalues found.  0 <= M <= N. */
+/* >          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] W */
+/* > \verbatim */
+/* >          W is REAL array, dimension (N) */
+/* >          The first M elements contain the selected eigenvalues in */
+/* >          ascending order. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Z */
+/* > \verbatim */
+/* >          Z is REAL array, dimension (LDZ, f2cmax(1,M) ) */
+/* >          If JOBZ = 'V', and if INFO = 0, then the first M columns of Z */
+/* >          contain the orthonormal eigenvectors of the matrix T */
+/* >          corresponding to the selected eigenvalues, with the i-th */
+/* >          column of Z holding the eigenvector associated with W(i). */
+/* >          If JOBZ = 'N', then Z is not referenced. */
+/* >          Note: the user must ensure that at least f2cmax(1,M) columns are */
+/* >          supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* >          is not known in advance and an upper bound must be used. */
+/* >          Supplying N columns is always safe. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDZ */
+/* > \verbatim */
+/* >          LDZ is INTEGER */
+/* >          The leading dimension of the array Z.  LDZ >= 1, and if */
+/* >          JOBZ = 'V', then LDZ >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] ISUPPZ */
+/* > \verbatim */
+/* >          ISUPPZ is INTEGER array, dimension ( 2*f2cmax(1,M) ) */
+/* >          The support of the eigenvectors in Z, i.e., the indices */
+/* >          indicating the nonzero elements in Z. The i-th computed eigenvector */
+/* >          is nonzero only in elements ISUPPZ( 2*i-1 ) through */
+/* >          ISUPPZ( 2*i ). This is relevant in the case when the matrix */
+/* >          is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (LWORK) */
+/* >          On exit, if INFO = 0, WORK(1) returns the optimal */
+/* >          (and minimal) LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The dimension of the array WORK. LWORK >= f2cmax(1,18*N) */
+/* >          if JOBZ = 'V', and LWORK >= f2cmax(1,12*N) if JOBZ = 'N'. */
+/* >          If LWORK = -1, then a workspace query is assumed; the routine */
+/* >          only calculates the optimal size of the WORK array, returns */
+/* >          this value as the first entry of the WORK array, and no error */
+/* >          message related to LWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (LIWORK) */
+/* >          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LIWORK */
+/* > \verbatim */
+/* >          LIWORK is INTEGER */
+/* >          The dimension of the array IWORK.  LIWORK >= f2cmax(1,10*N) */
+/* >          if the eigenvectors are desired, and LIWORK >= f2cmax(1,8*N) */
+/* >          if only the eigenvalues are to be computed. */
+/* >          If LIWORK = -1, then a workspace query is assumed; the */
+/* >          routine only calculates the optimal size of the IWORK array, */
+/* >          returns this value as the first entry of the IWORK array, and */
+/* >          no error message related to LIWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          On exit, INFO */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0:  if INFO = 1X, internal error in SLARRE, */
+/* >                if INFO = 2X, internal error in SLARRV. */
+/* >                Here, the digit X = ABS( IINFO ) < 10, where IINFO is */
+/* >                the nonzero error code returned by SLARRE or */
+/* >                SLARRV, respectively. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date June 2016 */
+
+/* > \ingroup realOTHERcomputational */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > */
+/* > Inderjit Dhillon, IBM Almaden, USA \n */
+/* > Osni Marques, LBNL/NERSC, USA \n */
+/* > Christof Voemel, LBNL/NERSC, USA \n */
+
+/*  ===================================================================== */
+/* Subroutine */ int sstegr_(char *jobz, char *range, integer *n, real *d__, 
+	real *e, real *vl, real *vu, integer *il, integer *iu, real *abstol, 
+	integer *m, real *w, real *z__, integer *ldz, integer *isuppz, real *
+	work, integer *lwork, integer *iwork, integer *liwork, integer *info)
+{
+    /* System generated locals */
+    integer z_dim1, z_offset;
+
+    /* Local variables */
+    logical tryrac;
+    extern /* Subroutine */ int sstemr_(char *, char *, integer *, real *, 
+	    real *, real *, real *, integer *, integer *, integer *, real *, 
+	    real *, integer *, integer *, integer *, logical *, real *, 
+	    integer *, integer *, integer *, integer *);
+
+
+/*  -- LAPACK computational routine (version 3.7.1) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     June 2016 */
+
+
+/*  ===================================================================== */
+
+    /* Parameter adjustments */
+    --d__;
+    --e;
+    --w;
+    z_dim1 = *ldz;
+    z_offset = 1 + z_dim1 * 1;
+    z__ -= z_offset;
+    --isuppz;
+    --work;
+    --iwork;
+
+    /* Function Body */
+    *info = 0;
+    tryrac = FALSE_;
+    sstemr_(jobz, range, n, &d__[1], &e[1], vl, vu, il, iu, m, &w[1], &z__[
+	    z_offset], ldz, n, &isuppz[1], &tryrac, &work[1], lwork, &iwork[1]
+	    , liwork, info);
+
+/*     End of SSTEGR */
+
+    return 0;
+} /* sstegr_ */
+

lapack-netlib/SRC/sstein.c

@@ -0,0 +1,893 @@
+/* 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 integer c__1 = 1;
+static integer c_n1 = -1;
+
+/* > \brief \b SSTEIN */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSTEIN + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sstein.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sstein.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sstein.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, */
+/*                          IWORK, IFAIL, INFO ) */
+
+/*       INTEGER            INFO, LDZ, M, N */
+/*       INTEGER            IBLOCK( * ), IFAIL( * ), ISPLIT( * ), */
+/*      $                   IWORK( * ) */
+/*       REAL               D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSTEIN computes the eigenvectors of a real symmetric tridiagonal */
+/* > matrix T corresponding to specified eigenvalues, using inverse */
+/* > iteration. */
+/* > */
+/* > The maximum number of iterations allowed for each eigenvector is */
+/* > specified by an internal parameter MAXITS (currently set to 5). */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] D */
+/* > \verbatim */
+/* >          D is REAL array, dimension (N) */
+/* >          The n diagonal elements of the tridiagonal matrix T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] E */
+/* > \verbatim */
+/* >          E is REAL array, dimension (N-1) */
+/* >          The (n-1) subdiagonal elements of the tridiagonal matrix */
+/* >          T, in elements 1 to N-1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The number of eigenvectors to be found.  0 <= M <= N. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] W */
+/* > \verbatim */
+/* >          W is REAL array, dimension (N) */
+/* >          The first M elements of W contain the eigenvalues for */
+/* >          which eigenvectors are to be computed.  The eigenvalues */
+/* >          should be grouped by split-off block and ordered from */
+/* >          smallest to largest within the block.  ( The output array */
+/* >          W from SSTEBZ with ORDER = 'B' is expected here. ) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IBLOCK */
+/* > \verbatim */
+/* >          IBLOCK is INTEGER array, dimension (N) */
+/* >          The submatrix indices associated with the corresponding */
+/* >          eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to */
+/* >          the first submatrix from the top, =2 if W(i) belongs to */
+/* >          the second submatrix, etc.  ( The output array IBLOCK */
+/* >          from SSTEBZ is expected here. ) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] ISPLIT */
+/* > \verbatim */
+/* >          ISPLIT is INTEGER array, dimension (N) */
+/* >          The splitting points, at which T breaks up into submatrices. */
+/* >          The first submatrix consists of rows/columns 1 to */
+/* >          ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */
+/* >          through ISPLIT( 2 ), etc. */
+/* >          ( The output array ISPLIT from SSTEBZ is expected here. ) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Z */
+/* > \verbatim */
+/* >          Z is REAL array, dimension (LDZ, M) */
+/* >          The computed eigenvectors.  The eigenvector associated */
+/* >          with the eigenvalue W(i) is stored in the i-th column of */
+/* >          Z.  Any vector which fails to converge is set to its current */
+/* >          iterate after MAXITS iterations. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDZ */
+/* > \verbatim */
+/* >          LDZ is INTEGER */
+/* >          The leading dimension of the array Z.  LDZ >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (5*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IFAIL */
+/* > \verbatim */
+/* >          IFAIL is INTEGER array, dimension (M) */
+/* >          On normal exit, all elements of IFAIL are zero. */
+/* >          If one or more eigenvectors fail to converge after */
+/* >          MAXITS iterations, then their indices are stored in */
+/* >          array IFAIL. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit. */
+/* >          < 0: if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0: if INFO = i, then i eigenvectors failed to converge */
+/* >               in MAXITS iterations.  Their indices are stored in */
+/* >               array IFAIL. */
+/* > \endverbatim */
+
+/* > \par Internal Parameters: */
+/*  ========================= */
+/* > */
+/* > \verbatim */
+/* >  MAXITS  INTEGER, default = 5 */
+/* >          The maximum number of iterations performed. */
+/* > */
+/* >  EXTRA   INTEGER, default = 2 */
+/* >          The number of iterations performed after norm growth */
+/* >          criterion is satisfied, should be at least 1. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realOTHERcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int sstein_(integer *n, real *d__, real *e, integer *m, real 
+	*w, integer *iblock, integer *isplit, real *z__, integer *ldz, real *
+	work, integer *iwork, integer *ifail, integer *info)
+{
+    /* System generated locals */
+    integer z_dim1, z_offset, i__1, i__2, i__3;
+    real r__1, r__2, r__3, r__4, r__5;
+
+    /* Local variables */
+    integer jblk, nblk, jmax;
+    extern real sdot_(integer *, real *, integer *, real *, integer *), 
+	    snrm2_(integer *, real *, integer *);
+    integer i__, j, iseed[4], gpind, iinfo;
+    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+    integer b1, j1;
+    extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, 
+	    integer *);
+    real ortol;
+    extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, 
+	    real *, integer *);
+    integer indrv1, indrv2, indrv3, indrv4, indrv5, bn;
+    real xj;
+    extern real slamch_(char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slagtf_(
+	    integer *, real *, real *, real *, real *, real *, real *, 
+	    integer *, integer *);
+    integer nrmchk;
+    extern integer isamax_(integer *, real *, integer *);
+    extern /* Subroutine */ int slagts_(integer *, integer *, real *, real *, 
+	    real *, real *, integer *, real *, real *, integer *);
+    integer blksiz;
+    real onenrm, pertol;
+    extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real 
+	    *);
+    real stpcrt, scl, eps, ctr, sep, nrm, tol;
+    integer its;
+    real xjm, eps1;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --d__;
+    --e;
+    --w;
+    --iblock;
+    --isplit;
+    z_dim1 = *ldz;
+    z_offset = 1 + z_dim1 * 1;
+    z__ -= z_offset;
+    --work;
+    --iwork;
+    --ifail;
+
+    /* Function Body */
+    *info = 0;
+    i__1 = *m;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	ifail[i__] = 0;
+/* L10: */
+    }
+
+    if (*n < 0) {
+	*info = -1;
+    } else if (*m < 0 || *m > *n) {
+	*info = -4;
+    } else if (*ldz < f2cmax(1,*n)) {
+	*info = -9;
+    } else {
+	i__1 = *m;
+	for (j = 2; j <= i__1; ++j) {
+	    if (iblock[j] < iblock[j - 1]) {
+		*info = -6;
+		goto L30;
+	    }
+	    if (iblock[j] == iblock[j - 1] && w[j] < w[j - 1]) {
+		*info = -5;
+		goto L30;
+	    }
+/* L20: */
+	}
+L30:
+	;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSTEIN", &i__1, (ftnlen)6);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0 || *m == 0) {
+	return 0;
+    } else if (*n == 1) {
+	z__[z_dim1 + 1] = 1.f;
+	return 0;
+    }
+
+/*     Get machine constants. */
+
+    eps = slamch_("Precision");
+
+/*     Initialize seed for random number generator SLARNV. */
+
+    for (i__ = 1; i__ <= 4; ++i__) {
+	iseed[i__ - 1] = 1;
+/* L40: */
+    }
+
+/*     Initialize pointers. */
+
+    indrv1 = 0;
+    indrv2 = indrv1 + *n;
+    indrv3 = indrv2 + *n;
+    indrv4 = indrv3 + *n;
+    indrv5 = indrv4 + *n;
+
+/*     Compute eigenvectors of matrix blocks. */
+
+    j1 = 1;
+    i__1 = iblock[*m];
+    for (nblk = 1; nblk <= i__1; ++nblk) {
+
+/*        Find starting and ending indices of block nblk. */
+
+	if (nblk == 1) {
+	    b1 = 1;
+	} else {
+	    b1 = isplit[nblk - 1] + 1;
+	}
+	bn = isplit[nblk];
+	blksiz = bn - b1 + 1;
+	if (blksiz == 1) {
+	    goto L60;
+	}
+	gpind = j1;
+
+/*        Compute reorthogonalization criterion and stopping criterion. */
+
+	onenrm = (r__1 = d__[b1], abs(r__1)) + (r__2 = e[b1], abs(r__2));
+/* Computing MAX */
+	r__3 = onenrm, r__4 = (r__1 = d__[bn], abs(r__1)) + (r__2 = e[bn - 1],
+		 abs(r__2));
+	onenrm = f2cmax(r__3,r__4);
+	i__2 = bn - 1;
+	for (i__ = b1 + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+	    r__4 = onenrm, r__5 = (r__1 = d__[i__], abs(r__1)) + (r__2 = e[
+		    i__ - 1], abs(r__2)) + (r__3 = e[i__], abs(r__3));
+	    onenrm = f2cmax(r__4,r__5);
+/* L50: */
+	}
+	ortol = onenrm * .001f;
+
+	stpcrt = sqrt(.1f / blksiz);
+
+/*        Loop through eigenvalues of block nblk. */
+
+L60:
+	jblk = 0;
+	i__2 = *m;
+	for (j = j1; j <= i__2; ++j) {
+	    if (iblock[j] != nblk) {
+		j1 = j;
+		goto L160;
+	    }
+	    ++jblk;
+	    xj = w[j];
+
+/*           Skip all the work if the block size is one. */
+
+	    if (blksiz == 1) {
+		work[indrv1 + 1] = 1.f;
+		goto L120;
+	    }
+
+/*           If eigenvalues j and j-1 are too close, add a relatively */
+/*           small perturbation. */
+
+	    if (jblk > 1) {
+		eps1 = (r__1 = eps * xj, abs(r__1));
+		pertol = eps1 * 10.f;
+		sep = xj - xjm;
+		if (sep < pertol) {
+		    xj = xjm + pertol;
+		}
+	    }
+
+	    its = 0;
+	    nrmchk = 0;
+
+/*           Get random starting vector. */
+
+	    slarnv_(&c__2, iseed, &blksiz, &work[indrv1 + 1]);
+
+/*           Copy the matrix T so it won't be destroyed in factorization. */
+
+	    scopy_(&blksiz, &d__[b1], &c__1, &work[indrv4 + 1], &c__1);
+	    i__3 = blksiz - 1;
+	    scopy_(&i__3, &e[b1], &c__1, &work[indrv2 + 2], &c__1);
+	    i__3 = blksiz - 1;
+	    scopy_(&i__3, &e[b1], &c__1, &work[indrv3 + 1], &c__1);
+
+/*           Compute LU factors with partial pivoting  ( PT = LU ) */
+
+	    tol = 0.f;
+	    slagtf_(&blksiz, &work[indrv4 + 1], &xj, &work[indrv2 + 2], &work[
+		    indrv3 + 1], &tol, &work[indrv5 + 1], &iwork[1], &iinfo);
+
+/*           Update iteration count. */
+
+L70:
+	    ++its;
+	    if (its > 5) {
+		goto L100;
+	    }
+
+/*           Normalize and scale the righthand side vector Pb. */
+
+	    jmax = isamax_(&blksiz, &work[indrv1 + 1], &c__1);
+/* Computing MAX */
+	    r__3 = eps, r__4 = (r__1 = work[indrv4 + blksiz], abs(r__1));
+	    scl = blksiz * onenrm * f2cmax(r__3,r__4) / (r__2 = work[indrv1 + 
+		    jmax], abs(r__2));
+	    sscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1);
+
+/*           Solve the system LU = Pb. */
+
+	    slagts_(&c_n1, &blksiz, &work[indrv4 + 1], &work[indrv2 + 2], &
+		    work[indrv3 + 1], &work[indrv5 + 1], &iwork[1], &work[
+		    indrv1 + 1], &tol, &iinfo);
+
+/*           Reorthogonalize by modified Gram-Schmidt if eigenvalues are */
+/*           close enough. */
+
+	    if (jblk == 1) {
+		goto L90;
+	    }
+	    if ((r__1 = xj - xjm, abs(r__1)) > ortol) {
+		gpind = j;
+	    }
+	    if (gpind != j) {
+		i__3 = j - 1;
+		for (i__ = gpind; i__ <= i__3; ++i__) {
+		    ctr = -sdot_(&blksiz, &work[indrv1 + 1], &c__1, &z__[b1 + 
+			    i__ * z_dim1], &c__1);
+		    saxpy_(&blksiz, &ctr, &z__[b1 + i__ * z_dim1], &c__1, &
+			    work[indrv1 + 1], &c__1);
+/* L80: */
+		}
+	    }
+
+/*           Check the infinity norm of the iterate. */
+
+L90:
+	    jmax = isamax_(&blksiz, &work[indrv1 + 1], &c__1);
+	    nrm = (r__1 = work[indrv1 + jmax], abs(r__1));
+
+/*           Continue for additional iterations after norm reaches */
+/*           stopping criterion. */
+
+	    if (nrm < stpcrt) {
+		goto L70;
+	    }
+	    ++nrmchk;
+	    if (nrmchk < 3) {
+		goto L70;
+	    }
+
+	    goto L110;
+
+/*           If stopping criterion was not satisfied, update info and */
+/*           store eigenvector number in array ifail. */
+
+L100:
+	    ++(*info);
+	    ifail[*info] = j;
+
+/*           Accept iterate as jth eigenvector. */
+
+L110:
+	    scl = 1.f / snrm2_(&blksiz, &work[indrv1 + 1], &c__1);
+	    jmax = isamax_(&blksiz, &work[indrv1 + 1], &c__1);
+	    if (work[indrv1 + jmax] < 0.f) {
+		scl = -scl;
+	    }
+	    sscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1);
+L120:
+	    i__3 = *n;
+	    for (i__ = 1; i__ <= i__3; ++i__) {
+		z__[i__ + j * z_dim1] = 0.f;
+/* L130: */
+	    }
+	    i__3 = blksiz;
+	    for (i__ = 1; i__ <= i__3; ++i__) {
+		z__[b1 + i__ - 1 + j * z_dim1] = work[indrv1 + i__];
+/* L140: */
+	    }
+
+/*           Save the shift to check eigenvalue spacing at next */
+/*           iteration. */
+
+	    xjm = xj;
+
+/* L150: */
+	}
+L160:
+	;
+    }
+
+    return 0;
+
+/*     End of SSTEIN */
+
+} /* sstein_ */
+

lapack-netlib/SRC/ssterf.c

@@ -0,0 +1,878 @@
+/* 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__0 = 0;
+static integer c__1 = 1;
+static real c_b32 = 1.f;
+
+/* > \brief \b SSTERF */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSTERF + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssterf.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssterf.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssterf.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSTERF( N, D, E, INFO ) */
+
+/*       INTEGER            INFO, N */
+/*       REAL               D( * ), E( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSTERF computes all eigenvalues of a symmetric tridiagonal matrix */
+/* > using the Pal-Walker-Kahan variant of the QL or QR algorithm. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] D */
+/* > \verbatim */
+/* >          D is REAL array, dimension (N) */
+/* >          On entry, the n diagonal elements of the tridiagonal matrix. */
+/* >          On exit, if INFO = 0, the eigenvalues in ascending order. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] E */
+/* > \verbatim */
+/* >          E is REAL array, dimension (N-1) */
+/* >          On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* >          matrix. */
+/* >          On exit, E has been destroyed. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0:  the algorithm failed to find all of the eigenvalues in */
+/* >                a total of 30*N iterations; if INFO = i, then i */
+/* >                elements of E have not converged to zero. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup auxOTHERcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssterf_(integer *n, real *d__, real *e, integer *info)
+{
+    /* System generated locals */
+    integer i__1;
+    real r__1, r__2, r__3;
+
+    /* Local variables */
+    real oldc;
+    integer lend, jtot;
+    extern /* Subroutine */ int slae2_(real *, real *, real *, real *, real *)
+	    ;
+    real c__;
+    integer i__, l, m;
+    real p, gamma, r__, s, alpha, sigma, anorm;
+    integer l1;
+    real bb;
+    extern real slapy2_(real *, real *);
+    integer iscale;
+    real oldgam;
+    extern real slamch_(char *);
+    real safmin;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    real safmax;
+    extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, 
+	    real *, integer *, integer *, real *, integer *, integer *);
+    integer lendsv;
+    real ssfmin;
+    integer nmaxit;
+    real ssfmax;
+    extern real slanst_(char *, integer *, real *, real *);
+    extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *);
+    real rt1, rt2, eps, rte;
+    integer lsv;
+    real eps2;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --e;
+    --d__;
+
+    /* Function Body */
+    *info = 0;
+
+/*     Quick return if possible */
+
+    if (*n < 0) {
+	*info = -1;
+	i__1 = -(*info);
+	xerbla_("SSTERF", &i__1, (ftnlen)6);
+	return 0;
+    }
+    if (*n <= 1) {
+	return 0;
+    }
+
+/*     Determine the unit roundoff for this environment. */
+
+    eps = slamch_("E");
+/* Computing 2nd power */
+    r__1 = eps;
+    eps2 = r__1 * r__1;
+    safmin = slamch_("S");
+    safmax = 1.f / safmin;
+    ssfmax = sqrt(safmax) / 3.f;
+    ssfmin = sqrt(safmin) / eps2;
+
+/*     Compute the eigenvalues of the tridiagonal matrix. */
+
+    nmaxit = *n * 30;
+    sigma = 0.f;
+    jtot = 0;
+
+/*     Determine where the matrix splits and choose QL or QR iteration */
+/*     for each block, according to whether top or bottom diagonal */
+/*     element is smaller. */
+
+    l1 = 1;
+
+L10:
+    if (l1 > *n) {
+	goto L170;
+    }
+    if (l1 > 1) {
+	e[l1 - 1] = 0.f;
+    }
+    i__1 = *n - 1;
+    for (m = l1; m <= i__1; ++m) {
+	if ((r__3 = e[m], abs(r__3)) <= sqrt((r__1 = d__[m], abs(r__1))) * 
+		sqrt((r__2 = d__[m + 1], abs(r__2))) * eps) {
+	    e[m] = 0.f;
+	    goto L30;
+	}
+/* L20: */
+    }
+    m = *n;
+
+L30:
+    l = l1;
+    lsv = l;
+    lend = m;
+    lendsv = lend;
+    l1 = m + 1;
+    if (lend == l) {
+	goto L10;
+    }
+
+/*     Scale submatrix in rows and columns L to LEND */
+
+    i__1 = lend - l + 1;
+    anorm = slanst_("M", &i__1, &d__[l], &e[l]);
+    iscale = 0;
+    if (anorm == 0.f) {
+	goto L10;
+    }
+    if (anorm > ssfmax) {
+	iscale = 1;
+	i__1 = lend - l + 1;
+	slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &d__[l], n, 
+		info);
+	i__1 = lend - l;
+	slascl_("G", &c__0, &c__0, &anorm, &ssfmax, &i__1, &c__1, &e[l], n, 
+		info);
+    } else if (anorm < ssfmin) {
+	iscale = 2;
+	i__1 = lend - l + 1;
+	slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &d__[l], n, 
+		info);
+	i__1 = lend - l;
+	slascl_("G", &c__0, &c__0, &anorm, &ssfmin, &i__1, &c__1, &e[l], n, 
+		info);
+    }
+
+    i__1 = lend - 1;
+    for (i__ = l; i__ <= i__1; ++i__) {
+/* Computing 2nd power */
+	r__1 = e[i__];
+	e[i__] = r__1 * r__1;
+/* L40: */
+    }
+
+/*     Choose between QL and QR iteration */
+
+    if ((r__1 = d__[lend], abs(r__1)) < (r__2 = d__[l], abs(r__2))) {
+	lend = lsv;
+	l = lendsv;
+    }
+
+    if (lend >= l) {
+
+/*        QL Iteration */
+
+/*        Look for small subdiagonal element. */
+
+L50:
+	if (l != lend) {
+	    i__1 = lend - 1;
+	    for (m = l; m <= i__1; ++m) {
+		if ((r__2 = e[m], abs(r__2)) <= eps2 * (r__1 = d__[m] * d__[m 
+			+ 1], abs(r__1))) {
+		    goto L70;
+		}
+/* L60: */
+	    }
+	}
+	m = lend;
+
+L70:
+	if (m < lend) {
+	    e[m] = 0.f;
+	}
+	p = d__[l];
+	if (m == l) {
+	    goto L90;
+	}
+
+/*        If remaining matrix is 2 by 2, use SLAE2 to compute its */
+/*        eigenvalues. */
+
+	if (m == l + 1) {
+	    rte = sqrt(e[l]);
+	    slae2_(&d__[l], &rte, &d__[l + 1], &rt1, &rt2);
+	    d__[l] = rt1;
+	    d__[l + 1] = rt2;
+	    e[l] = 0.f;
+	    l += 2;
+	    if (l <= lend) {
+		goto L50;
+	    }
+	    goto L150;
+	}
+
+	if (jtot == nmaxit) {
+	    goto L150;
+	}
+	++jtot;
+
+/*        Form shift. */
+
+	rte = sqrt(e[l]);
+	sigma = (d__[l + 1] - p) / (rte * 2.f);
+	r__ = slapy2_(&sigma, &c_b32);
+	sigma = p - rte / (sigma + r_sign(&r__, &sigma));
+
+	c__ = 1.f;
+	s = 0.f;
+	gamma = d__[m] - sigma;
+	p = gamma * gamma;
+
+/*        Inner loop */
+
+	i__1 = l;
+	for (i__ = m - 1; i__ >= i__1; --i__) {
+	    bb = e[i__];
+	    r__ = p + bb;
+	    if (i__ != m - 1) {
+		e[i__ + 1] = s * r__;
+	    }
+	    oldc = c__;
+	    c__ = p / r__;
+	    s = bb / r__;
+	    oldgam = gamma;
+	    alpha = d__[i__];
+	    gamma = c__ * (alpha - sigma) - s * oldgam;
+	    d__[i__ + 1] = oldgam + (alpha - gamma);
+	    if (c__ != 0.f) {
+		p = gamma * gamma / c__;
+	    } else {
+		p = oldc * bb;
+	    }
+/* L80: */
+	}
+
+	e[l] = s * p;
+	d__[l] = sigma + gamma;
+	goto L50;
+
+/*        Eigenvalue found. */
+
+L90:
+	d__[l] = p;
+
+	++l;
+	if (l <= lend) {
+	    goto L50;
+	}
+	goto L150;
+
+    } else {
+
+/*        QR Iteration */
+
+/*        Look for small superdiagonal element. */
+
+L100:
+	i__1 = lend + 1;
+	for (m = l; m >= i__1; --m) {
+	    if ((r__2 = e[m - 1], abs(r__2)) <= eps2 * (r__1 = d__[m] * d__[m 
+		    - 1], abs(r__1))) {
+		goto L120;
+	    }
+/* L110: */
+	}
+	m = lend;
+
+L120:
+	if (m > lend) {
+	    e[m - 1] = 0.f;
+	}
+	p = d__[l];
+	if (m == l) {
+	    goto L140;
+	}
+
+/*        If remaining matrix is 2 by 2, use SLAE2 to compute its */
+/*        eigenvalues. */
+
+	if (m == l - 1) {
+	    rte = sqrt(e[l - 1]);
+	    slae2_(&d__[l], &rte, &d__[l - 1], &rt1, &rt2);
+	    d__[l] = rt1;
+	    d__[l - 1] = rt2;
+	    e[l - 1] = 0.f;
+	    l += -2;
+	    if (l >= lend) {
+		goto L100;
+	    }
+	    goto L150;
+	}
+
+	if (jtot == nmaxit) {
+	    goto L150;
+	}
+	++jtot;
+
+/*        Form shift. */
+
+	rte = sqrt(e[l - 1]);
+	sigma = (d__[l - 1] - p) / (rte * 2.f);
+	r__ = slapy2_(&sigma, &c_b32);
+	sigma = p - rte / (sigma + r_sign(&r__, &sigma));
+
+	c__ = 1.f;
+	s = 0.f;
+	gamma = d__[m] - sigma;
+	p = gamma * gamma;
+
+/*        Inner loop */
+
+	i__1 = l - 1;
+	for (i__ = m; i__ <= i__1; ++i__) {
+	    bb = e[i__];
+	    r__ = p + bb;
+	    if (i__ != m) {
+		e[i__ - 1] = s * r__;
+	    }
+	    oldc = c__;
+	    c__ = p / r__;
+	    s = bb / r__;
+	    oldgam = gamma;
+	    alpha = d__[i__ + 1];
+	    gamma = c__ * (alpha - sigma) - s * oldgam;
+	    d__[i__] = oldgam + (alpha - gamma);
+	    if (c__ != 0.f) {
+		p = gamma * gamma / c__;
+	    } else {
+		p = oldc * bb;
+	    }
+/* L130: */
+	}
+
+	e[l - 1] = s * p;
+	d__[l] = sigma + gamma;
+	goto L100;
+
+/*        Eigenvalue found. */
+
+L140:
+	d__[l] = p;
+
+	--l;
+	if (l >= lend) {
+	    goto L100;
+	}
+	goto L150;
+
+    }
+
+/*     Undo scaling if necessary */
+
+L150:
+    if (iscale == 1) {
+	i__1 = lendsv - lsv + 1;
+	slascl_("G", &c__0, &c__0, &ssfmax, &anorm, &i__1, &c__1, &d__[lsv], 
+		n, info);
+    }
+    if (iscale == 2) {
+	i__1 = lendsv - lsv + 1;
+	slascl_("G", &c__0, &c__0, &ssfmin, &anorm, &i__1, &c__1, &d__[lsv], 
+		n, info);
+    }
+
+/*     Check for no convergence to an eigenvalue after a total */
+/*     of N*MAXIT iterations. */
+
+    if (jtot < nmaxit) {
+	goto L10;
+    }
+    i__1 = *n - 1;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	if (e[i__] != 0.f) {
+	    ++(*info);
+	}
+/* L160: */
+    }
+    goto L180;
+
+/*     Sort eigenvalues in increasing order. */
+
+L170:
+    slasrt_("I", n, &d__[1], info);
+
+L180:
+    return 0;
+
+/*     End of SSTERF */
+
+} /* ssterf_ */
+

lapack-netlib/SRC/sstev.c

@@ -0,0 +1,637 @@
+/* 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;
+
+/* > \brief <b> SSTEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER m
+atrices</b> */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSTEV + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sstev.f
+"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sstev.f
+"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sstev.f
+"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO ) */
+
+/*       CHARACTER          JOBZ */
+/*       INTEGER            INFO, LDZ, N */
+/*       REAL               D( * ), E( * ), WORK( * ), Z( LDZ, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSTEV computes all eigenvalues and, optionally, eigenvectors of a */
+/* > real symmetric tridiagonal matrix A. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] JOBZ */
+/* > \verbatim */
+/* >          JOBZ is CHARACTER*1 */
+/* >          = 'N':  Compute eigenvalues only; */
+/* >          = 'V':  Compute eigenvalues and eigenvectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] D */
+/* > \verbatim */
+/* >          D is REAL array, dimension (N) */
+/* >          On entry, the n diagonal elements of the tridiagonal matrix */
+/* >          A. */
+/* >          On exit, if INFO = 0, the eigenvalues in ascending order. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] E */
+/* > \verbatim */
+/* >          E is REAL array, dimension (N-1) */
+/* >          On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* >          matrix A, stored in elements 1 to N-1 of E. */
+/* >          On exit, the contents of E are destroyed. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Z */
+/* > \verbatim */
+/* >          Z is REAL array, dimension (LDZ, N) */
+/* >          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
+/* >          eigenvectors of the matrix A, with the i-th column of Z */
+/* >          holding the eigenvector associated with D(i). */
+/* >          If JOBZ = 'N', then Z is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDZ */
+/* > \verbatim */
+/* >          LDZ is INTEGER */
+/* >          The leading dimension of the array Z.  LDZ >= 1, and if */
+/* >          JOBZ = 'V', LDZ >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (f2cmax(1,2*N-2)) */
+/* >          If JOBZ = 'N', WORK is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0:  if INFO = i, the algorithm failed to converge; i */
+/* >                off-diagonal elements of E did not converge to zero. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realOTHEReigen */
+
+/*  ===================================================================== */
+/* Subroutine */ int sstev_(char *jobz, integer *n, real *d__, real *e, real *
+	z__, integer *ldz, real *work, integer *info)
+{
+    /* System generated locals */
+    integer z_dim1, z_offset, i__1;
+    real r__1;
+
+    /* Local variables */
+    integer imax;
+    real rmin, rmax, tnrm, sigma;
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+    logical wantz;
+    integer iscale;
+    extern real slamch_(char *);
+    real safmin;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    real bignum;
+    extern real slanst_(char *, integer *, real *, real *);
+    extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
+    real smlnum;
+    extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *, 
+	    real *, integer *, real *, integer *);
+    real eps;
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --d__;
+    --e;
+    z_dim1 = *ldz;
+    z_offset = 1 + z_dim1 * 1;
+    z__ -= z_offset;
+    --work;
+
+    /* Function Body */
+    wantz = lsame_(jobz, "V");
+
+    *info = 0;
+    if (! (wantz || lsame_(jobz, "N"))) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*ldz < 1 || wantz && *ldz < *n) {
+	*info = -6;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSTEV ", &i__1, (ftnlen)6);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+    if (*n == 1) {
+	if (wantz) {
+	    z__[z_dim1 + 1] = 1.f;
+	}
+	return 0;
+    }
+
+/*     Get machine constants. */
+
+    safmin = slamch_("Safe minimum");
+    eps = slamch_("Precision");
+    smlnum = safmin / eps;
+    bignum = 1.f / smlnum;
+    rmin = sqrt(smlnum);
+    rmax = sqrt(bignum);
+
+/*     Scale matrix to allowable range, if necessary. */
+
+    iscale = 0;
+    tnrm = slanst_("M", n, &d__[1], &e[1]);
+    if (tnrm > 0.f && tnrm < rmin) {
+	iscale = 1;
+	sigma = rmin / tnrm;
+    } else if (tnrm > rmax) {
+	iscale = 1;
+	sigma = rmax / tnrm;
+    }
+    if (iscale == 1) {
+	sscal_(n, &sigma, &d__[1], &c__1);
+	i__1 = *n - 1;
+	sscal_(&i__1, &sigma, &e[1], &c__1);
+    }
+
+/*     For eigenvalues only, call SSTERF.  For eigenvalues and */
+/*     eigenvectors, call SSTEQR. */
+
+    if (! wantz) {
+	ssterf_(n, &d__[1], &e[1], info);
+    } else {
+	ssteqr_("I", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], info);
+    }
+
+/*     If matrix was scaled, then rescale eigenvalues appropriately. */
+
+    if (iscale == 1) {
+	if (*info == 0) {
+	    imax = *n;
+	} else {
+	    imax = *info - 1;
+	}
+	r__1 = 1.f / sigma;
+	sscal_(&imax, &r__1, &d__[1], &c__1);
+    }
+
+    return 0;
+
+/*     End of SSTEV */
+
+} /* sstev_ */
+

lapack-netlib/SRC/sstevd.c

@@ -0,0 +1,710 @@
+/* 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;
+
+/* > \brief <b> SSTEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER 
+matrices</b> */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSTEVD + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sstevd.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sstevd.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sstevd.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK, */
+/*                          LIWORK, INFO ) */
+
+/*       CHARACTER          JOBZ */
+/*       INTEGER            INFO, LDZ, LIWORK, LWORK, N */
+/*       INTEGER            IWORK( * ) */
+/*       REAL               D( * ), E( * ), WORK( * ), Z( LDZ, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSTEVD computes all eigenvalues and, optionally, eigenvectors of a */
+/* > real symmetric tridiagonal matrix. If eigenvectors are desired, it */
+/* > uses a divide and conquer algorithm. */
+/* > */
+/* > The divide and conquer algorithm makes very mild assumptions about */
+/* > floating point arithmetic. It will work on machines with a guard */
+/* > digit in add/subtract, or on those binary machines without guard */
+/* > digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* > Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* > without guard digits, but we know of none. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] JOBZ */
+/* > \verbatim */
+/* >          JOBZ is CHARACTER*1 */
+/* >          = 'N':  Compute eigenvalues only; */
+/* >          = 'V':  Compute eigenvalues and eigenvectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] D */
+/* > \verbatim */
+/* >          D is REAL array, dimension (N) */
+/* >          On entry, the n diagonal elements of the tridiagonal matrix */
+/* >          A. */
+/* >          On exit, if INFO = 0, the eigenvalues in ascending order. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] E */
+/* > \verbatim */
+/* >          E is REAL array, dimension (N-1) */
+/* >          On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* >          matrix A, stored in elements 1 to N-1 of E. */
+/* >          On exit, the contents of E are destroyed. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Z */
+/* > \verbatim */
+/* >          Z is REAL array, dimension (LDZ, N) */
+/* >          If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
+/* >          eigenvectors of the matrix A, with the i-th column of Z */
+/* >          holding the eigenvector associated with D(i). */
+/* >          If JOBZ = 'N', then Z is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDZ */
+/* > \verbatim */
+/* >          LDZ is INTEGER */
+/* >          The leading dimension of the array Z.  LDZ >= 1, and if */
+/* >          JOBZ = 'V', LDZ >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, */
+/* >                                         dimension (LWORK) */
+/* >          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The dimension of the array WORK. */
+/* >          If JOBZ  = 'N' or N <= 1 then LWORK must be at least 1. */
+/* >          If JOBZ  = 'V' and N > 1 then LWORK must be at least */
+/* >                         ( 1 + 4*N + N**2 ). */
+/* > */
+/* >          If LWORK = -1, then a workspace query is assumed; the routine */
+/* >          only calculates the optimal sizes of the WORK and IWORK */
+/* >          arrays, returns these values as the first entries of the WORK */
+/* >          and IWORK arrays, and no error message related to LWORK or */
+/* >          LIWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */
+/* >          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LIWORK */
+/* > \verbatim */
+/* >          LIWORK is INTEGER */
+/* >          The dimension of the array IWORK. */
+/* >          If JOBZ  = 'N' or N <= 1 then LIWORK must be at least 1. */
+/* >          If JOBZ  = 'V' and N > 1 then LIWORK must be at least 3+5*N. */
+/* > */
+/* >          If LIWORK = -1, then a workspace query is assumed; the */
+/* >          routine only calculates the optimal sizes of the WORK and */
+/* >          IWORK arrays, returns these values as the first entries of */
+/* >          the WORK and IWORK arrays, and no error message related to */
+/* >          LWORK or LIWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0:  if INFO = i, the algorithm failed to converge; i */
+/* >                off-diagonal elements of E did not converge to zero. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realOTHEReigen */
+
+/*  ===================================================================== */
+/* Subroutine */ int sstevd_(char *jobz, integer *n, real *d__, real *e, real 
+	*z__, integer *ldz, real *work, integer *lwork, integer *iwork, 
+	integer *liwork, integer *info)
+{
+    /* System generated locals */
+    integer z_dim1, z_offset, i__1;
+    real r__1;
+
+    /* Local variables */
+    real rmin, rmax, tnrm, sigma;
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+    integer lwmin;
+    logical wantz;
+    integer iscale;
+    extern real slamch_(char *);
+    real safmin;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    real bignum;
+    extern /* Subroutine */ int sstedc_(char *, integer *, real *, real *, 
+	    real *, integer *, real *, integer *, integer *, integer *, 
+	    integer *);
+    integer liwmin;
+    extern real slanst_(char *, integer *, real *, real *);
+    extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
+    real smlnum;
+    logical lquery;
+    real eps;
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --d__;
+    --e;
+    z_dim1 = *ldz;
+    z_offset = 1 + z_dim1 * 1;
+    z__ -= z_offset;
+    --work;
+    --iwork;
+
+    /* Function Body */
+    wantz = lsame_(jobz, "V");
+    lquery = *lwork == -1 || *liwork == -1;
+
+    *info = 0;
+    liwmin = 1;
+    lwmin = 1;
+    if (*n > 1 && wantz) {
+/* Computing 2nd power */
+	i__1 = *n;
+	lwmin = (*n << 2) + 1 + i__1 * i__1;
+	liwmin = *n * 5 + 3;
+    }
+
+    if (! (wantz || lsame_(jobz, "N"))) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*ldz < 1 || wantz && *ldz < *n) {
+	*info = -6;
+    }
+
+    if (*info == 0) {
+	work[1] = (real) lwmin;
+	iwork[1] = liwmin;
+
+	if (*lwork < lwmin && ! lquery) {
+	    *info = -8;
+	} else if (*liwork < liwmin && ! lquery) {
+	    *info = -10;
+	}
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSTEVD", &i__1, (ftnlen)6);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+    if (*n == 1) {
+	if (wantz) {
+	    z__[z_dim1 + 1] = 1.f;
+	}
+	return 0;
+    }
+
+/*     Get machine constants. */
+
+    safmin = slamch_("Safe minimum");
+    eps = slamch_("Precision");
+    smlnum = safmin / eps;
+    bignum = 1.f / smlnum;
+    rmin = sqrt(smlnum);
+    rmax = sqrt(bignum);
+
+/*     Scale matrix to allowable range, if necessary. */
+
+    iscale = 0;
+    tnrm = slanst_("M", n, &d__[1], &e[1]);
+    if (tnrm > 0.f && tnrm < rmin) {
+	iscale = 1;
+	sigma = rmin / tnrm;
+    } else if (tnrm > rmax) {
+	iscale = 1;
+	sigma = rmax / tnrm;
+    }
+    if (iscale == 1) {
+	sscal_(n, &sigma, &d__[1], &c__1);
+	i__1 = *n - 1;
+	sscal_(&i__1, &sigma, &e[1], &c__1);
+    }
+
+/*     For eigenvalues only, call SSTERF.  For eigenvalues and */
+/*     eigenvectors, call SSTEDC. */
+
+    if (! wantz) {
+	ssterf_(n, &d__[1], &e[1], info);
+    } else {
+	sstedc_("I", n, &d__[1], &e[1], &z__[z_offset], ldz, &work[1], lwork, 
+		&iwork[1], liwork, info);
+    }
+
+/*     If matrix was scaled, then rescale eigenvalues appropriately. */
+
+    if (iscale == 1) {
+	r__1 = 1.f / sigma;
+	sscal_(n, &r__1, &d__[1], &c__1);
+    }
+
+    work[1] = (real) lwmin;
+    iwork[1] = liwmin;
+
+    return 0;
+
+/*     End of SSTEVD */
+
+} /* sstevd_ */
+

lapack-netlib/SRC/sstevx.c

@@ -0,0 +1,898 @@
+/* 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;
+
+/* > \brief <b> SSTEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER 
+matrices</b> */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSTEVX + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sstevx.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sstevx.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sstevx.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, */
+/*                          M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO ) */
+
+/*       CHARACTER          JOBZ, RANGE */
+/*       INTEGER            IL, INFO, IU, LDZ, M, N */
+/*       REAL               ABSTOL, VL, VU */
+/*       INTEGER            IFAIL( * ), IWORK( * ) */
+/*       REAL               D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSTEVX computes selected eigenvalues and, optionally, eigenvectors */
+/* > of a real symmetric tridiagonal matrix A.  Eigenvalues and */
+/* > eigenvectors can be selected by specifying either a range of values */
+/* > or a range of indices for the desired eigenvalues. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] JOBZ */
+/* > \verbatim */
+/* >          JOBZ is CHARACTER*1 */
+/* >          = 'N':  Compute eigenvalues only; */
+/* >          = 'V':  Compute eigenvalues and eigenvectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] RANGE */
+/* > \verbatim */
+/* >          RANGE is CHARACTER*1 */
+/* >          = 'A': all eigenvalues will be found. */
+/* >          = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* >                 will be found. */
+/* >          = 'I': the IL-th through IU-th eigenvalues will be found. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] D */
+/* > \verbatim */
+/* >          D is REAL array, dimension (N) */
+/* >          On entry, the n diagonal elements of the tridiagonal matrix */
+/* >          A. */
+/* >          On exit, D may be multiplied by a constant factor chosen */
+/* >          to avoid over/underflow in computing the eigenvalues. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] E */
+/* > \verbatim */
+/* >          E is REAL array, dimension (f2cmax(1,N-1)) */
+/* >          On entry, the (n-1) subdiagonal elements of the tridiagonal */
+/* >          matrix A in elements 1 to N-1 of E. */
+/* >          On exit, E may be multiplied by a constant factor chosen */
+/* >          to avoid over/underflow in computing the eigenvalues. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] VL */
+/* > \verbatim */
+/* >          VL is REAL */
+/* >          If RANGE='V', the lower bound of the interval to */
+/* >          be searched for eigenvalues. VL < VU. */
+/* >          Not referenced if RANGE = 'A' or 'I'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] VU */
+/* > \verbatim */
+/* >          VU is REAL */
+/* >          If RANGE='V', the upper bound of the interval to */
+/* >          be searched for eigenvalues. VL < VU. */
+/* >          Not referenced if RANGE = 'A' or 'I'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IL */
+/* > \verbatim */
+/* >          IL is INTEGER */
+/* >          If RANGE='I', the index of the */
+/* >          smallest eigenvalue to be returned. */
+/* >          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* >          Not referenced if RANGE = 'A' or 'V'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IU */
+/* > \verbatim */
+/* >          IU is INTEGER */
+/* >          If RANGE='I', the index of the */
+/* >          largest eigenvalue to be returned. */
+/* >          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* >          Not referenced if RANGE = 'A' or 'V'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] ABSTOL */
+/* > \verbatim */
+/* >          ABSTOL is REAL */
+/* >          The absolute error tolerance for the eigenvalues. */
+/* >          An approximate eigenvalue is accepted as converged */
+/* >          when it is determined to lie in an interval [a,b] */
+/* >          of width less than or equal to */
+/* > */
+/* >                  ABSTOL + EPS *   f2cmax( |a|,|b| ) , */
+/* > */
+/* >          where EPS is the machine precision.  If ABSTOL is less */
+/* >          than or equal to zero, then  EPS*|T|  will be used in */
+/* >          its place, where |T| is the 1-norm of the tridiagonal */
+/* >          matrix. */
+/* > */
+/* >          Eigenvalues will be computed most accurately when ABSTOL is */
+/* >          set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
+/* >          If this routine returns with INFO>0, indicating that some */
+/* >          eigenvectors did not converge, try setting ABSTOL to */
+/* >          2*SLAMCH('S'). */
+/* > */
+/* >          See "Computing Small Singular Values of Bidiagonal Matrices */
+/* >          with Guaranteed High Relative Accuracy," by Demmel and */
+/* >          Kahan, LAPACK Working Note #3. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The total number of eigenvalues found.  0 <= M <= N. */
+/* >          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] W */
+/* > \verbatim */
+/* >          W is REAL array, dimension (N) */
+/* >          The first M elements contain the selected eigenvalues in */
+/* >          ascending order. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Z */
+/* > \verbatim */
+/* >          Z is REAL array, dimension (LDZ, f2cmax(1,M) ) */
+/* >          If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* >          contain the orthonormal eigenvectors of the matrix A */
+/* >          corresponding to the selected eigenvalues, with the i-th */
+/* >          column of Z holding the eigenvector associated with W(i). */
+/* >          If an eigenvector fails to converge (INFO > 0), then that */
+/* >          column of Z contains the latest approximation to the */
+/* >          eigenvector, and the index of the eigenvector is returned */
+/* >          in IFAIL.  If JOBZ = 'N', then Z is not referenced. */
+/* >          Note: the user must ensure that at least f2cmax(1,M) columns are */
+/* >          supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* >          is not known in advance and an upper bound must be used. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDZ */
+/* > \verbatim */
+/* >          LDZ is INTEGER */
+/* >          The leading dimension of the array Z.  LDZ >= 1, and if */
+/* >          JOBZ = 'V', LDZ >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (5*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (5*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IFAIL */
+/* > \verbatim */
+/* >          IFAIL is INTEGER array, dimension (N) */
+/* >          If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* >          IFAIL are zero.  If INFO > 0, then IFAIL contains the */
+/* >          indices of the eigenvectors that failed to converge. */
+/* >          If JOBZ = 'N', then IFAIL is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0:  if INFO = i, then i eigenvectors failed to converge. */
+/* >                Their indices are stored in array IFAIL. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date June 2016 */
+
+/* > \ingroup realOTHEReigen */
+
+/*  ===================================================================== */
+/* Subroutine */ int sstevx_(char *jobz, char *range, integer *n, real *d__, 
+	real *e, real *vl, real *vu, integer *il, integer *iu, real *abstol, 
+	integer *m, real *w, real *z__, integer *ldz, real *work, integer *
+	iwork, integer *ifail, integer *info)
+{
+    /* System generated locals */
+    integer z_dim1, z_offset, i__1, i__2;
+    real r__1, r__2;
+
+    /* Local variables */
+    integer imax;
+    real rmin, rmax;
+    logical test;
+    real tnrm;
+    integer itmp1, i__, j;
+    real sigma;
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+    char order[1];
+    extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, 
+	    integer *), sswap_(integer *, real *, integer *, real *, integer *
+	    );
+    logical wantz;
+    integer jj;
+    logical alleig, indeig;
+    integer iscale, indibl;
+    logical valeig;
+    extern real slamch_(char *);
+    real safmin;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    real bignum;
+    integer indisp, indiwo, indwrk;
+    extern real slanst_(char *, integer *, real *, real *);
+    extern /* Subroutine */ int sstein_(integer *, real *, real *, integer *, 
+	    real *, integer *, integer *, real *, integer *, real *, integer *
+	    , integer *, integer *), ssterf_(integer *, real *, real *, 
+	    integer *);
+    integer nsplit;
+    extern /* Subroutine */ int sstebz_(char *, char *, integer *, real *, 
+	    real *, integer *, integer *, real *, real *, real *, integer *, 
+	    integer *, real *, integer *, integer *, real *, integer *, 
+	    integer *);
+    real smlnum;
+    extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *, 
+	    real *, integer *, real *, integer *);
+    real eps, vll, vuu, tmp1;
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     June 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --d__;
+    --e;
+    --w;
+    z_dim1 = *ldz;
+    z_offset = 1 + z_dim1 * 1;
+    z__ -= z_offset;
+    --work;
+    --iwork;
+    --ifail;
+
+    /* Function Body */
+    wantz = lsame_(jobz, "V");
+    alleig = lsame_(range, "A");
+    valeig = lsame_(range, "V");
+    indeig = lsame_(range, "I");
+
+    *info = 0;
+    if (! (wantz || lsame_(jobz, "N"))) {
+	*info = -1;
+    } else if (! (alleig || valeig || indeig)) {
+	*info = -2;
+    } else if (*n < 0) {
+	*info = -3;
+    } else {
+	if (valeig) {
+	    if (*n > 0 && *vu <= *vl) {
+		*info = -7;
+	    }
+	} else if (indeig) {
+	    if (*il < 1 || *il > f2cmax(1,*n)) {
+		*info = -8;
+	    } else if (*iu < f2cmin(*n,*il) || *iu > *n) {
+		*info = -9;
+	    }
+	}
+    }
+    if (*info == 0) {
+	if (*ldz < 1 || wantz && *ldz < *n) {
+	    *info = -14;
+	}
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSTEVX", &i__1, (ftnlen)6);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    *m = 0;
+    if (*n == 0) {
+	return 0;
+    }
+
+    if (*n == 1) {
+	if (alleig || indeig) {
+	    *m = 1;
+	    w[1] = d__[1];
+	} else {
+	    if (*vl < d__[1] && *vu >= d__[1]) {
+		*m = 1;
+		w[1] = d__[1];
+	    }
+	}
+	if (wantz) {
+	    z__[z_dim1 + 1] = 1.f;
+	}
+	return 0;
+    }
+
+/*     Get machine constants. */
+
+    safmin = slamch_("Safe minimum");
+    eps = slamch_("Precision");
+    smlnum = safmin / eps;
+    bignum = 1.f / smlnum;
+    rmin = sqrt(smlnum);
+/* Computing MIN */
+    r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
+    rmax = f2cmin(r__1,r__2);
+
+/*     Scale matrix to allowable range, if necessary. */
+
+    iscale = 0;
+    if (valeig) {
+	vll = *vl;
+	vuu = *vu;
+    } else {
+	vll = 0.f;
+	vuu = 0.f;
+    }
+    tnrm = slanst_("M", n, &d__[1], &e[1]);
+    if (tnrm > 0.f && tnrm < rmin) {
+	iscale = 1;
+	sigma = rmin / tnrm;
+    } else if (tnrm > rmax) {
+	iscale = 1;
+	sigma = rmax / tnrm;
+    }
+    if (iscale == 1) {
+	sscal_(n, &sigma, &d__[1], &c__1);
+	i__1 = *n - 1;
+	sscal_(&i__1, &sigma, &e[1], &c__1);
+	if (valeig) {
+	    vll = *vl * sigma;
+	    vuu = *vu * sigma;
+	}
+    }
+
+/*     If all eigenvalues are desired and ABSTOL is less than zero, then */
+/*     call SSTERF or SSTEQR.  If this fails for some eigenvalue, then */
+/*     try SSTEBZ. */
+
+    test = FALSE_;
+    if (indeig) {
+	if (*il == 1 && *iu == *n) {
+	    test = TRUE_;
+	}
+    }
+    if ((alleig || test) && *abstol <= 0.f) {
+	scopy_(n, &d__[1], &c__1, &w[1], &c__1);
+	i__1 = *n - 1;
+	scopy_(&i__1, &e[1], &c__1, &work[1], &c__1);
+	indwrk = *n + 1;
+	if (! wantz) {
+	    ssterf_(n, &w[1], &work[1], info);
+	} else {
+	    ssteqr_("I", n, &w[1], &work[1], &z__[z_offset], ldz, &work[
+		    indwrk], info);
+	    if (*info == 0) {
+		i__1 = *n;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    ifail[i__] = 0;
+/* L10: */
+		}
+	    }
+	}
+	if (*info == 0) {
+	    *m = *n;
+	    goto L20;
+	}
+	*info = 0;
+    }
+
+/*     Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. */
+
+    if (wantz) {
+	*(unsigned char *)order = 'B';
+    } else {
+	*(unsigned char *)order = 'E';
+    }
+    indwrk = 1;
+    indibl = 1;
+    indisp = indibl + *n;
+    indiwo = indisp + *n;
+    sstebz_(range, order, n, &vll, &vuu, il, iu, abstol, &d__[1], &e[1], m, &
+	    nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[indwrk], &
+	    iwork[indiwo], info);
+
+    if (wantz) {
+	sstein_(n, &d__[1], &e[1], m, &w[1], &iwork[indibl], &iwork[indisp], &
+		z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &ifail[1], 
+		info);
+    }
+
+/*     If matrix was scaled, then rescale eigenvalues appropriately. */
+
+L20:
+    if (iscale == 1) {
+	if (*info == 0) {
+	    imax = *m;
+	} else {
+	    imax = *info - 1;
+	}
+	r__1 = 1.f / sigma;
+	sscal_(&imax, &r__1, &w[1], &c__1);
+    }
+
+/*     If eigenvalues are not in order, then sort them, along with */
+/*     eigenvectors. */
+
+    if (wantz) {
+	i__1 = *m - 1;
+	for (j = 1; j <= i__1; ++j) {
+	    i__ = 0;
+	    tmp1 = w[j];
+	    i__2 = *m;
+	    for (jj = j + 1; jj <= i__2; ++jj) {
+		if (w[jj] < tmp1) {
+		    i__ = jj;
+		    tmp1 = w[jj];
+		}
+/* L30: */
+	    }
+
+	    if (i__ != 0) {
+		itmp1 = iwork[indibl + i__ - 1];
+		w[i__] = w[j];
+		iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
+		w[j] = tmp1;
+		iwork[indibl + j - 1] = itmp1;
+		sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
+			 &c__1);
+		if (*info != 0) {
+		    itmp1 = ifail[i__];
+		    ifail[i__] = ifail[j];
+		    ifail[j] = itmp1;
+		}
+	    }
+/* L40: */
+	}
+    }
+
+    return 0;
+
+/*     End of SSTEVX */
+
+} /* sstevx_ */
+

lapack-netlib/SRC/ssycon.c

@@ -0,0 +1,637 @@
+/* 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;
+
+/* > \brief \b SSYCON */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYCON + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssycon.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssycon.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssycon.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, */
+/*                          IWORK, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDA, N */
+/*       REAL               ANORM, RCOND */
+/*       INTEGER            IPIV( * ), IWORK( * ) */
+/*       REAL               A( LDA, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYCON estimates the reciprocal of the condition number (in the */
+/* > 1-norm) of a real symmetric matrix A using the factorization */
+/* > A = U*D*U**T or A = L*D*L**T computed by SSYTRF. */
+/* > */
+/* > An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* > condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the details of the factorization are stored */
+/* >          as an upper or lower triangular matrix. */
+/* >          = 'U':  Upper triangular, form is A = U*D*U**T; */
+/* >          = 'L':  Lower triangular, form is A = L*D*L**T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          The block diagonal matrix D and the multipliers used to */
+/* >          obtain the factor U or L as computed by SSYTRF. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges and the block structure of D */
+/* >          as determined by SSYTRF. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] ANORM */
+/* > \verbatim */
+/* >          ANORM is REAL */
+/* >          The 1-norm of the original matrix A. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] RCOND */
+/* > \verbatim */
+/* >          RCOND is REAL */
+/* >          The reciprocal of the condition number of the matrix A, */
+/* >          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */
+/* >          estimate of the 1-norm of inv(A) computed in this routine. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (2*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realSYcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssycon_(char *uplo, integer *n, real *a, integer *lda, 
+	integer *ipiv, real *anorm, real *rcond, real *work, integer *iwork, 
+	integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1;
+
+    /* Local variables */
+    integer kase, i__;
+    extern logical lsame_(char *, char *);
+    integer isave[3];
+    logical upper;
+    extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *, 
+	    real *, integer *, integer *), xerbla_(char *, integer *, ftnlen);
+    real ainvnm;
+    extern /* Subroutine */ int ssytrs_(char *, integer *, integer *, real *, 
+	    integer *, integer *, real *, integer *, integer *);
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --ipiv;
+    --work;
+    --iwork;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -4;
+    } else if (*anorm < 0.f) {
+	*info = -6;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYCON", &i__1, (ftnlen)6);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    *rcond = 0.f;
+    if (*n == 0) {
+	*rcond = 1.f;
+	return 0;
+    } else if (*anorm <= 0.f) {
+	return 0;
+    }
+
+/*     Check that the diagonal matrix D is nonsingular. */
+
+    if (upper) {
+
+/*        Upper triangular storage: examine D from bottom to top */
+
+	for (i__ = *n; i__ >= 1; --i__) {
+	    if (ipiv[i__] > 0 && a[i__ + i__ * a_dim1] == 0.f) {
+		return 0;
+	    }
+/* L10: */
+	}
+    } else {
+
+/*        Lower triangular storage: examine D from top to bottom. */
+
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    if (ipiv[i__] > 0 && a[i__ + i__ * a_dim1] == 0.f) {
+		return 0;
+	    }
+/* L20: */
+	}
+    }
+
+/*     Estimate the 1-norm of the inverse. */
+
+    kase = 0;
+L30:
+    slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+    if (kase != 0) {
+
+/*        Multiply by inv(L*D*L**T) or inv(U*D*U**T). */
+
+	ssytrs_(uplo, n, &c__1, &a[a_offset], lda, &ipiv[1], &work[1], n, 
+		info);
+	goto L30;
+    }
+
+/*     Compute the estimate of the reciprocal condition number. */
+
+    if (ainvnm != 0.f) {
+	*rcond = 1.f / ainvnm / *anorm;
+    }
+
+    return 0;
+
+/*     End of SSYCON */
+
+} /* ssycon_ */
+

lapack-netlib/SRC/ssycon_3.c

@@ -0,0 +1,678 @@
+/* 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;
+
+/* > \brief \b SSYCON_3 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYCON_3 + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssycon_
+3.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssycon_
+3.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssycon_
+3.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYCON_3( UPLO, N, A, LDA, E, IPIV, ANORM, RCOND, */
+/*                            WORK, IWORK, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDA, N */
+/*       REAL               ANORM, RCOND */
+/*       INTEGER            IPIV( * ), IWORK( * ) */
+/*       REAL               A( LDA, * ), E ( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > SSYCON_3 estimates the reciprocal of the condition number (in the */
+/* > 1-norm) of a real symmetric matrix A using the factorization */
+/* > computed by DSYTRF_RK or DSYTRF_BK: */
+/* > */
+/* >    A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), */
+/* > */
+/* > where U (or L) is unit upper (or lower) triangular matrix, */
+/* > U**T (or L**T) is the transpose of U (or L), P is a permutation */
+/* > matrix, P**T is the transpose of P, and D is symmetric and block */
+/* > diagonal with 1-by-1 and 2-by-2 diagonal blocks. */
+/* > */
+/* > An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* > condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+/* > This routine uses BLAS3 solver SSYTRS_3. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the details of the factorization are */
+/* >          stored as an upper or lower triangular matrix: */
+/* >          = 'U':  Upper triangular, form is A = P*U*D*(U**T)*(P**T); */
+/* >          = 'L':  Lower triangular, form is A = P*L*D*(L**T)*(P**T). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          Diagonal of the block diagonal matrix D and factors U or L */
+/* >          as computed by SSYTRF_RK and SSYTRF_BK: */
+/* >            a) ONLY diagonal elements of the symmetric block diagonal */
+/* >               matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */
+/* >               (superdiagonal (or subdiagonal) elements of D */
+/* >                should be provided on entry in array E), and */
+/* >            b) If UPLO = 'U': factor U in the superdiagonal part of A. */
+/* >               If UPLO = 'L': factor L in the subdiagonal part of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] E */
+/* > \verbatim */
+/* >          E is REAL array, dimension (N) */
+/* >          On entry, contains the superdiagonal (or subdiagonal) */
+/* >          elements of the symmetric block diagonal matrix D */
+/* >          with 1-by-1 or 2-by-2 diagonal blocks, where */
+/* >          If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; */
+/* >          If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. */
+/* > */
+/* >          NOTE: For 1-by-1 diagonal block D(k), where */
+/* >          1 <= k <= N, the element E(k) is not referenced in both */
+/* >          UPLO = 'U' or UPLO = 'L' cases. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges and the block structure of D */
+/* >          as determined by SSYTRF_RK or SSYTRF_BK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] ANORM */
+/* > \verbatim */
+/* >          ANORM is REAL */
+/* >          The 1-norm of the original matrix A. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] RCOND */
+/* > \verbatim */
+/* >          RCOND is REAL */
+/* >          The reciprocal of the condition number of the matrix A, */
+/* >          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */
+/* >          estimate of the 1-norm of inv(A) computed in this routine. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (2*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date June 2017 */
+
+/* > \ingroup singleSYcomputational */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > \verbatim */
+/* > */
+/* >  June 2017,  Igor Kozachenko, */
+/* >                  Computer Science Division, */
+/* >                  University of California, Berkeley */
+/* > */
+/* >  September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */
+/* >                  School of Mathematics, */
+/* >                  University of Manchester */
+/* > */
+/* > \endverbatim */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssycon_3_(char *uplo, integer *n, real *a, integer *lda,
+	 real *e, integer *ipiv, real *anorm, real *rcond, real *work, 
+	integer *iwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1;
+
+    /* Local variables */
+    integer kase;
+    extern /* Subroutine */ int ssytrs_3_(char *, integer *, integer *, real 
+	    *, integer *, real *, integer *, real *, integer *, integer *);
+    integer i__;
+    extern logical lsame_(char *, char *);
+    integer isave[3];
+    logical upper;
+    extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *, 
+	    real *, integer *, integer *), xerbla_(char *, integer *, ftnlen);
+    real ainvnm;
+
+
+/*  -- LAPACK computational routine (version 3.7.1) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     June 2017 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --e;
+    --ipiv;
+    --work;
+    --iwork;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -4;
+    } else if (*anorm < 0.f) {
+	*info = -7;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYCON_3", &i__1, (ftnlen)8);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    *rcond = 0.f;
+    if (*n == 0) {
+	*rcond = 1.f;
+	return 0;
+    } else if (*anorm <= 0.f) {
+	return 0;
+    }
+
+/*     Check that the diagonal matrix D is nonsingular. */
+
+    if (upper) {
+
+/*        Upper triangular storage: examine D from bottom to top */
+
+	for (i__ = *n; i__ >= 1; --i__) {
+	    if (ipiv[i__] > 0 && a[i__ + i__ * a_dim1] == 0.f) {
+		return 0;
+	    }
+	}
+    } else {
+
+/*        Lower triangular storage: examine D from top to bottom. */
+
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    if (ipiv[i__] > 0 && a[i__ + i__ * a_dim1] == 0.f) {
+		return 0;
+	    }
+	}
+    }
+
+/*     Estimate the 1-norm of the inverse. */
+
+    kase = 0;
+L30:
+    slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+    if (kase != 0) {
+
+/*        Multiply by inv(L*D*L**T) or inv(U*D*U**T). */
+
+	ssytrs_3_(uplo, n, &c__1, &a[a_offset], lda, &e[1], &ipiv[1], &work[
+		1], n, info);
+	goto L30;
+    }
+
+/*     Compute the estimate of the reciprocal condition number. */
+
+    if (ainvnm != 0.f) {
+	*rcond = 1.f / ainvnm / *anorm;
+    }
+
+    return 0;
+
+/*     End of DSYCON_3 */
+
+} /* ssycon_3__ */
+

lapack-netlib/SRC/ssycon_rook.c

@@ -0,0 +1,652 @@
+/* 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;
+
+/* > \brief <b> SSYCON_ROOK </b> */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYCON_ROOK + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssycon_
+rook.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssycon_
+rook.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssycon_
+rook.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYCON_ROOK( UPLO, N, A, LDA, IPIV, ANORM, RCOND, */
+/*                               WORK, IWORK, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDA, N */
+/*       REAL               ANORM, RCOND */
+/*       INTEGER            IPIV( * ), IWORK( * ) */
+/*       REAL               A( LDA, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYCON_ROOK estimates the reciprocal of the condition number (in the */
+/* > 1-norm) of a real symmetric matrix A using the factorization */
+/* > A = U*D*U**T or A = L*D*L**T computed by SSYTRF_ROOK. */
+/* > */
+/* > An estimate is obtained for norm(inv(A)), and the reciprocal of the */
+/* > condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the details of the factorization are stored */
+/* >          as an upper or lower triangular matrix. */
+/* >          = 'U':  Upper triangular, form is A = U*D*U**T; */
+/* >          = 'L':  Lower triangular, form is A = L*D*L**T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          The block diagonal matrix D and the multipliers used to */
+/* >          obtain the factor U or L as computed by SSYTRF_ROOK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges and the block structure of D */
+/* >          as determined by SSYTRF_ROOK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] ANORM */
+/* > \verbatim */
+/* >          ANORM is REAL */
+/* >          The 1-norm of the original matrix A. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] RCOND */
+/* > \verbatim */
+/* >          RCOND is REAL */
+/* >          The reciprocal of the condition number of the matrix A, */
+/* >          computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */
+/* >          estimate of the 1-norm of inv(A) computed in this routine. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (2*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realSYcomputational */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > \verbatim */
+/* > */
+/* >   December 2016, Igor Kozachenko, */
+/* >                  Computer Science Division, */
+/* >                  University of California, Berkeley */
+/* > */
+/* >  September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */
+/* >                  School of Mathematics, */
+/* >                  University of Manchester */
+/* > */
+/* > \endverbatim */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssycon_rook_(char *uplo, integer *n, real *a, integer *
+	lda, integer *ipiv, real *anorm, real *rcond, real *work, integer *
+	iwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1;
+
+    /* Local variables */
+    integer kase;
+    extern /* Subroutine */ int ssytrs_rook_(char *, integer *, integer *, 
+	    real *, integer *, integer *, real *, integer *, integer *);
+    integer i__;
+    extern logical lsame_(char *, char *);
+    integer isave[3];
+    logical upper;
+    extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *, 
+	    real *, integer *, integer *), xerbla_(char *, integer *, ftnlen);
+    real ainvnm;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --ipiv;
+    --work;
+    --iwork;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -4;
+    } else if (*anorm < 0.f) {
+	*info = -6;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYCON_ROOK", &i__1, (ftnlen)11);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    *rcond = 0.f;
+    if (*n == 0) {
+	*rcond = 1.f;
+	return 0;
+    } else if (*anorm <= 0.f) {
+	return 0;
+    }
+
+/*     Check that the diagonal matrix D is nonsingular. */
+
+    if (upper) {
+
+/*        Upper triangular storage: examine D from bottom to top */
+
+	for (i__ = *n; i__ >= 1; --i__) {
+	    if (ipiv[i__] > 0 && a[i__ + i__ * a_dim1] == 0.f) {
+		return 0;
+	    }
+/* L10: */
+	}
+    } else {
+
+/*        Lower triangular storage: examine D from top to bottom. */
+
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    if (ipiv[i__] > 0 && a[i__ + i__ * a_dim1] == 0.f) {
+		return 0;
+	    }
+/* L20: */
+	}
+    }
+
+/*     Estimate the 1-norm of the inverse. */
+
+    kase = 0;
+L30:
+    slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+    if (kase != 0) {
+
+/*        Multiply by inv(L*D*L**T) or inv(U*D*U**T). */
+
+	ssytrs_rook_(uplo, n, &c__1, &a[a_offset], lda, &ipiv[1], &work[1], 
+		n, info);
+	goto L30;
+    }
+
+/*     Compute the estimate of the reciprocal condition number. */
+
+    if (ainvnm != 0.f) {
+	*rcond = 1.f / ainvnm / *anorm;
+    }
+
+    return 0;
+
+/*     End of SSYCON_ROOK */
+
+} /* ssycon_rook__ */
+

lapack-netlib/SRC/ssyconv.c

@@ -0,0 +1,764 @@
+/* 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 SSYCONV */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYCONV + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssyconv
+.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssyconv
+.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssyconv
+.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYCONV( UPLO, WAY, N, A, LDA, IPIV, E, INFO ) */
+
+/*       CHARACTER          UPLO, WAY */
+/*       INTEGER            INFO, LDA, N */
+/*       INTEGER            IPIV( * ) */
+/*       REAL               A( LDA, * ), E( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYCONV convert A given by TRF into L and D and vice-versa. */
+/* > Get Non-diag elements of D (returned in workspace) and */
+/* > apply or reverse permutation done in TRF. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the details of the factorization are stored */
+/* >          as an upper or lower triangular matrix. */
+/* >          = 'U':  Upper triangular, form is A = U*D*U**T; */
+/* >          = 'L':  Lower triangular, form is A = L*D*L**T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] WAY */
+/* > \verbatim */
+/* >          WAY is CHARACTER*1 */
+/* >          = 'C': Convert */
+/* >          = 'R': Revert */
+/* > \endverbatim */
+/* > */
+/* > \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) */
+/* >          The block diagonal matrix D and the multipliers used to */
+/* >          obtain the factor U or L as computed by SSYTRF. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges and the block structure of D */
+/* >          as determined by SSYTRF. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] E */
+/* > \verbatim */
+/* >          E is REAL array, dimension (N) */
+/* >          E stores the supdiagonal/subdiagonal of the symmetric 1-by-1 */
+/* >          or 2-by-2 block diagonal matrix D in LDLT. */
+/* > \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 realSYcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssyconv_(char *uplo, char *way, integer *n, real *a, 
+	integer *lda, integer *ipiv, real *e, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1;
+
+    /* Local variables */
+    real temp;
+    integer i__, j;
+    extern logical lsame_(char *, char *);
+    logical upper;
+    integer ip;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    logical convert;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --ipiv;
+    --e;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    convert = lsame_(way, "C");
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (! convert && ! lsame_(way, "R")) {
+	*info = -2;
+    } else if (*n < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYCONV", &i__1, (ftnlen)7);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+    if (upper) {
+
+/*      A is UPPER */
+
+/*      Convert A (A is upper) */
+
+/*        Convert VALUE */
+
+	if (convert) {
+	    i__ = *n;
+	    e[1] = 0.f;
+	    while(i__ > 1) {
+		if (ipiv[i__] < 0) {
+		    e[i__] = a[i__ - 1 + i__ * a_dim1];
+		    e[i__ - 1] = 0.f;
+		    a[i__ - 1 + i__ * a_dim1] = 0.f;
+		    --i__;
+		} else {
+		    e[i__] = 0.f;
+		}
+		--i__;
+	    }
+
+/*        Convert PERMUTATIONS */
+
+	    i__ = *n;
+	    while(i__ >= 1) {
+		if (ipiv[i__] > 0) {
+		    ip = ipiv[i__];
+		    if (i__ < *n) {
+			i__1 = *n;
+			for (j = i__ + 1; j <= i__1; ++j) {
+			    temp = a[ip + j * a_dim1];
+			    a[ip + j * a_dim1] = a[i__ + j * a_dim1];
+			    a[i__ + j * a_dim1] = temp;
+/* L12: */
+			}
+		    }
+		} else {
+		    ip = -ipiv[i__];
+		    if (i__ < *n) {
+			i__1 = *n;
+			for (j = i__ + 1; j <= i__1; ++j) {
+			    temp = a[ip + j * a_dim1];
+			    a[ip + j * a_dim1] = a[i__ - 1 + j * a_dim1];
+			    a[i__ - 1 + j * a_dim1] = temp;
+/* L13: */
+			}
+		    }
+		    --i__;
+		}
+		--i__;
+	    }
+	} else {
+
+/*      Revert A (A is upper) */
+
+
+/*        Revert PERMUTATIONS */
+
+	    i__ = 1;
+	    while(i__ <= *n) {
+		if (ipiv[i__] > 0) {
+		    ip = ipiv[i__];
+		    if (i__ < *n) {
+			i__1 = *n;
+			for (j = i__ + 1; j <= i__1; ++j) {
+			    temp = a[ip + j * a_dim1];
+			    a[ip + j * a_dim1] = a[i__ + j * a_dim1];
+			    a[i__ + j * a_dim1] = temp;
+			}
+		    }
+		} else {
+		    ip = -ipiv[i__];
+		    ++i__;
+		    if (i__ < *n) {
+			i__1 = *n;
+			for (j = i__ + 1; j <= i__1; ++j) {
+			    temp = a[ip + j * a_dim1];
+			    a[ip + j * a_dim1] = a[i__ - 1 + j * a_dim1];
+			    a[i__ - 1 + j * a_dim1] = temp;
+			}
+		    }
+		}
+		++i__;
+	    }
+
+/*        Revert VALUE */
+
+	    i__ = *n;
+	    while(i__ > 1) {
+		if (ipiv[i__] < 0) {
+		    a[i__ - 1 + i__ * a_dim1] = e[i__];
+		    --i__;
+		}
+		--i__;
+	    }
+	}
+    } else {
+
+/*      A is LOWER */
+
+	if (convert) {
+
+/*      Convert A (A is lower) */
+
+
+/*        Convert VALUE */
+
+	    i__ = 1;
+	    e[*n] = 0.f;
+	    while(i__ <= *n) {
+		if (i__ < *n && ipiv[i__] < 0) {
+		    e[i__] = a[i__ + 1 + i__ * a_dim1];
+		    e[i__ + 1] = 0.f;
+		    a[i__ + 1 + i__ * a_dim1] = 0.f;
+		    ++i__;
+		} else {
+		    e[i__] = 0.f;
+		}
+		++i__;
+	    }
+
+/*        Convert PERMUTATIONS */
+
+	    i__ = 1;
+	    while(i__ <= *n) {
+		if (ipiv[i__] > 0) {
+		    ip = ipiv[i__];
+		    if (i__ > 1) {
+			i__1 = i__ - 1;
+			for (j = 1; j <= i__1; ++j) {
+			    temp = a[ip + j * a_dim1];
+			    a[ip + j * a_dim1] = a[i__ + j * a_dim1];
+			    a[i__ + j * a_dim1] = temp;
+/* L22: */
+			}
+		    }
+		} else {
+		    ip = -ipiv[i__];
+		    if (i__ > 1) {
+			i__1 = i__ - 1;
+			for (j = 1; j <= i__1; ++j) {
+			    temp = a[ip + j * a_dim1];
+			    a[ip + j * a_dim1] = a[i__ + 1 + j * a_dim1];
+			    a[i__ + 1 + j * a_dim1] = temp;
+/* L23: */
+			}
+		    }
+		    ++i__;
+		}
+		++i__;
+	    }
+	} else {
+
+/*      Revert A (A is lower) */
+
+
+/*        Revert PERMUTATIONS */
+
+	    i__ = *n;
+	    while(i__ >= 1) {
+		if (ipiv[i__] > 0) {
+		    ip = ipiv[i__];
+		    if (i__ > 1) {
+			i__1 = i__ - 1;
+			for (j = 1; j <= i__1; ++j) {
+			    temp = a[i__ + j * a_dim1];
+			    a[i__ + j * a_dim1] = a[ip + j * a_dim1];
+			    a[ip + j * a_dim1] = temp;
+			}
+		    }
+		} else {
+		    ip = -ipiv[i__];
+		    --i__;
+		    if (i__ > 1) {
+			i__1 = i__ - 1;
+			for (j = 1; j <= i__1; ++j) {
+			    temp = a[i__ + 1 + j * a_dim1];
+			    a[i__ + 1 + j * a_dim1] = a[ip + j * a_dim1];
+			    a[ip + j * a_dim1] = temp;
+			}
+		    }
+		}
+		--i__;
+	    }
+
+/*        Revert VALUE */
+
+	    i__ = 1;
+	    while(i__ <= *n - 1) {
+		if (ipiv[i__] < 0) {
+		    a[i__ + 1 + i__ * a_dim1] = e[i__];
+		    ++i__;
+		}
+		++i__;
+	    }
+	}
+    }
+    return 0;
+
+/*     End of SSYCONV */
+
+} /* ssyconv_ */
+

lapack-netlib/SRC/ssyconvf.c

@@ -0,0 +1,956 @@
+/* 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 SSYCONVF */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYCONVF + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssyconv
+f.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssyconv
+f.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssyconv
+f.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYCONVF( UPLO, WAY, N, A, LDA, E, IPIV, INFO ) */
+
+/*       CHARACTER          UPLO, WAY */
+/*       INTEGER            INFO, LDA, N */
+/*       INTEGER            IPIV( * ) */
+/*       REAL               A( LDA, * ), E( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > If parameter WAY = 'C': */
+/* > SSYCONVF converts the factorization output format used in */
+/* > SSYTRF provided on entry in parameter A into the factorization */
+/* > output format used in SSYTRF_RK (or SSYTRF_BK) that is stored */
+/* > on exit in parameters A and E. It also coverts in place details of */
+/* > the intechanges stored in IPIV from the format used in SSYTRF into */
+/* > the format used in SSYTRF_RK (or SSYTRF_BK). */
+/* > */
+/* > If parameter WAY = 'R': */
+/* > SSYCONVF performs the conversion in reverse direction, i.e. */
+/* > converts the factorization output format used in SSYTRF_RK */
+/* > (or SSYTRF_BK) provided on entry in parameters A and E into */
+/* > the factorization output format used in SSYTRF that is stored */
+/* > on exit in parameter A. It also coverts in place details of */
+/* > the intechanges stored in IPIV from the format used in SSYTRF_RK */
+/* > (or SSYTRF_BK) into the format used in SSYTRF. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the details of the factorization are */
+/* >          stored as an upper or lower triangular matrix A. */
+/* >          = 'U':  Upper triangular */
+/* >          = 'L':  Lower triangular */
+/* > \endverbatim */
+/* > */
+/* > \param[in] WAY */
+/* > \verbatim */
+/* >          WAY is CHARACTER*1 */
+/* >          = 'C': Convert */
+/* >          = 'R': Revert */
+/* > \endverbatim */
+/* > */
+/* > \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) */
+/* > */
+/* >          1) If WAY ='C': */
+/* > */
+/* >          On entry, contains factorization details in format used in */
+/* >          SSYTRF: */
+/* >            a) all elements of the symmetric block diagonal */
+/* >               matrix D on the diagonal of A and on superdiagonal */
+/* >               (or subdiagonal) of A, and */
+/* >            b) If UPLO = 'U': multipliers used to obtain factor U */
+/* >               in the superdiagonal part of A. */
+/* >               If UPLO = 'L': multipliers used to obtain factor L */
+/* >               in the superdiagonal part of A. */
+/* > */
+/* >          On exit, contains factorization details in format used in */
+/* >          SSYTRF_RK or SSYTRF_BK: */
+/* >            a) ONLY diagonal elements of the symmetric block diagonal */
+/* >               matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */
+/* >               (superdiagonal (or subdiagonal) elements of D */
+/* >                are stored on exit in array E), and */
+/* >            b) If UPLO = 'U': factor U in the superdiagonal part of A. */
+/* >               If UPLO = 'L': factor L in the subdiagonal part of A. */
+/* > */
+/* >          2) If WAY = 'R': */
+/* > */
+/* >          On entry, contains factorization details in format used in */
+/* >          SSYTRF_RK or SSYTRF_BK: */
+/* >            a) ONLY diagonal elements of the symmetric block diagonal */
+/* >               matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */
+/* >               (superdiagonal (or subdiagonal) elements of D */
+/* >                are stored on exit in array E), and */
+/* >            b) If UPLO = 'U': factor U in the superdiagonal part of A. */
+/* >               If UPLO = 'L': factor L in the subdiagonal part of A. */
+/* > */
+/* >          On exit, contains factorization details in format used in */
+/* >          SSYTRF: */
+/* >            a) all elements of the symmetric block diagonal */
+/* >               matrix D on the diagonal of A and on superdiagonal */
+/* >               (or subdiagonal) of A, and */
+/* >            b) If UPLO = 'U': multipliers used to obtain factor U */
+/* >               in the superdiagonal part of A. */
+/* >               If UPLO = 'L': multipliers used to obtain factor L */
+/* >               in the superdiagonal part of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] E */
+/* > \verbatim */
+/* >          E is REAL array, dimension (N) */
+/* > */
+/* >          1) If WAY ='C': */
+/* > */
+/* >          On entry, just a workspace. */
+/* > */
+/* >          On exit, contains the superdiagonal (or subdiagonal) */
+/* >          elements of the symmetric block diagonal matrix D */
+/* >          with 1-by-1 or 2-by-2 diagonal blocks, where */
+/* >          If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; */
+/* >          If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. */
+/* > */
+/* >          2) If WAY = 'R': */
+/* > */
+/* >          On entry, contains the superdiagonal (or subdiagonal) */
+/* >          elements of the symmetric block diagonal matrix D */
+/* >          with 1-by-1 or 2-by-2 diagonal blocks, where */
+/* >          If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; */
+/* >          If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. */
+/* > */
+/* >          On exit, is not changed */
+/* > \endverbatim */
+/* . */
+/* > \param[in,out] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* > */
+/* >          1) If WAY ='C': */
+/* >          On entry, details of the interchanges and the block */
+/* >          structure of D in the format used in SSYTRF. */
+/* >          On exit, details of the interchanges and the block */
+/* >          structure of D in the format used in SSYTRF_RK */
+/* >          ( or SSYTRF_BK). */
+/* > */
+/* >          1) If WAY ='R': */
+/* >          On entry, details of the interchanges and the block */
+/* >          structure of D in the format used in SSYTRF_RK */
+/* >          ( or SSYTRF_BK). */
+/* >          On exit, details of the interchanges and the block */
+/* >          structure of D in the format used in SSYTRF. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date November 2017 */
+
+/* > \ingroup singleSYcomputational */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  November 2017,  Igor Kozachenko, */
+/* >                  Computer Science Division, */
+/* >                  University of California, Berkeley */
+/* > */
+/* > \endverbatim */
+/*  ===================================================================== */
+/* Subroutine */ int ssyconvf_(char *uplo, char *way, integer *n, real *a, 
+	integer *lda, real *e, integer *ipiv, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1;
+
+    /* Local variables */
+    integer i__;
+    extern logical lsame_(char *, char *);
+    logical upper;
+    extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, 
+	    integer *);
+    integer ip;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    logical convert;
+
+
+/*  -- LAPACK computational routine (version 3.8.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     November 2017 */
+
+
+/*  ===================================================================== */
+
+
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --e;
+    --ipiv;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    convert = lsame_(way, "C");
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (! convert && ! lsame_(way, "R")) {
+	*info = -2;
+    } else if (*n < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYCONVF", &i__1, (ftnlen)8);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+    if (upper) {
+
+/*        Begin A is UPPER */
+
+	if (convert) {
+
+/*           Convert A (A is upper) */
+
+
+/*           Convert VALUE */
+
+/*           Assign superdiagonal entries of D to array E and zero out */
+/*           corresponding entries in input storage A */
+
+	    i__ = *n;
+	    e[1] = 0.f;
+	    while(i__ > 1) {
+		if (ipiv[i__] < 0) {
+		    e[i__] = a[i__ - 1 + i__ * a_dim1];
+		    e[i__ - 1] = 0.f;
+		    a[i__ - 1 + i__ * a_dim1] = 0.f;
+		    --i__;
+		} else {
+		    e[i__] = 0.f;
+		}
+		--i__;
+	    }
+
+/*           Convert PERMUTATIONS and IPIV */
+
+/*           Apply permutations to submatrices of upper part of A */
+/*           in factorization order where i decreases from N to 1 */
+
+	    i__ = *n;
+	    while(i__ >= 1) {
+		if (ipiv[i__] > 0) {
+
+/*                 1-by-1 pivot interchange */
+
+/*                 Swap rows i and IPIV(i) in A(1:i,N-i:N) */
+
+		    ip = ipiv[i__];
+		    if (i__ < *n) {
+			if (ip != i__) {
+			    i__1 = *n - i__;
+			    sswap_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda, &
+				    a[ip + (i__ + 1) * a_dim1], lda);
+			}
+		    }
+
+		} else {
+
+/*                 2-by-2 pivot interchange */
+
+/*                 Swap rows i-1 and IPIV(i) in A(1:i,N-i:N) */
+
+		    ip = -ipiv[i__];
+		    if (i__ < *n) {
+			if (ip != i__ - 1) {
+			    i__1 = *n - i__;
+			    sswap_(&i__1, &a[i__ - 1 + (i__ + 1) * a_dim1], 
+				    lda, &a[ip + (i__ + 1) * a_dim1], lda);
+			}
+		    }
+
+/*                 Convert IPIV */
+/*                 There is no interchnge of rows i and and IPIV(i), */
+/*                 so this should be reflected in IPIV format for */
+/*                 *SYTRF_RK ( or *SYTRF_BK) */
+
+		    ipiv[i__] = i__;
+
+		    --i__;
+
+		}
+		--i__;
+	    }
+
+	} else {
+
+/*           Revert A (A is upper) */
+
+
+/*           Revert PERMUTATIONS and IPIV */
+
+/*           Apply permutations to submatrices of upper part of A */
+/*           in reverse factorization order where i increases from 1 to N */
+
+	    i__ = 1;
+	    while(i__ <= *n) {
+		if (ipiv[i__] > 0) {
+
+/*                 1-by-1 pivot interchange */
+
+/*                 Swap rows i and IPIV(i) in A(1:i,N-i:N) */
+
+		    ip = ipiv[i__];
+		    if (i__ < *n) {
+			if (ip != i__) {
+			    i__1 = *n - i__;
+			    sswap_(&i__1, &a[ip + (i__ + 1) * a_dim1], lda, &
+				    a[i__ + (i__ + 1) * a_dim1], lda);
+			}
+		    }
+
+		} else {
+
+/*                 2-by-2 pivot interchange */
+
+/*                 Swap rows i-1 and IPIV(i) in A(1:i,N-i:N) */
+
+		    ++i__;
+		    ip = -ipiv[i__];
+		    if (i__ < *n) {
+			if (ip != i__ - 1) {
+			    i__1 = *n - i__;
+			    sswap_(&i__1, &a[ip + (i__ + 1) * a_dim1], lda, &
+				    a[i__ - 1 + (i__ + 1) * a_dim1], lda);
+			}
+		    }
+
+/*                 Convert IPIV */
+/*                 There is one interchange of rows i-1 and IPIV(i-1), */
+/*                 so this should be recorded in two consecutive entries */
+/*                 in IPIV format for *SYTRF */
+
+		    ipiv[i__] = ipiv[i__ - 1];
+
+		}
+		++i__;
+	    }
+
+/*           Revert VALUE */
+/*           Assign superdiagonal entries of D from array E to */
+/*           superdiagonal entries of A. */
+
+	    i__ = *n;
+	    while(i__ > 1) {
+		if (ipiv[i__] < 0) {
+		    a[i__ - 1 + i__ * a_dim1] = e[i__];
+		    --i__;
+		}
+		--i__;
+	    }
+
+/*        End A is UPPER */
+
+	}
+
+    } else {
+
+/*        Begin A is LOWER */
+
+	if (convert) {
+
+/*           Convert A (A is lower) */
+
+
+/*           Convert VALUE */
+/*           Assign subdiagonal entries of D to array E and zero out */
+/*           corresponding entries in input storage A */
+
+	    i__ = 1;
+	    e[*n] = 0.f;
+	    while(i__ <= *n) {
+		if (i__ < *n && ipiv[i__] < 0) {
+		    e[i__] = a[i__ + 1 + i__ * a_dim1];
+		    e[i__ + 1] = 0.f;
+		    a[i__ + 1 + i__ * a_dim1] = 0.f;
+		    ++i__;
+		} else {
+		    e[i__] = 0.f;
+		}
+		++i__;
+	    }
+
+/*           Convert PERMUTATIONS and IPIV */
+
+/*           Apply permutations to submatrices of lower part of A */
+/*           in factorization order where k increases from 1 to N */
+
+	    i__ = 1;
+	    while(i__ <= *n) {
+		if (ipiv[i__] > 0) {
+
+/*                 1-by-1 pivot interchange */
+
+/*                 Swap rows i and IPIV(i) in A(i:N,1:i-1) */
+
+		    ip = ipiv[i__];
+		    if (i__ > 1) {
+			if (ip != i__) {
+			    i__1 = i__ - 1;
+			    sswap_(&i__1, &a[i__ + a_dim1], lda, &a[ip + 
+				    a_dim1], lda);
+			}
+		    }
+
+		} else {
+
+/*                 2-by-2 pivot interchange */
+
+/*                 Swap rows i+1 and IPIV(i) in A(i:N,1:i-1) */
+
+		    ip = -ipiv[i__];
+		    if (i__ > 1) {
+			if (ip != i__ + 1) {
+			    i__1 = i__ - 1;
+			    sswap_(&i__1, &a[i__ + 1 + a_dim1], lda, &a[ip + 
+				    a_dim1], lda);
+			}
+		    }
+
+/*                 Convert IPIV */
+/*                 There is no interchnge of rows i and and IPIV(i), */
+/*                 so this should be reflected in IPIV format for */
+/*                 *SYTRF_RK ( or *SYTRF_BK) */
+
+		    ipiv[i__] = i__;
+
+		    ++i__;
+
+		}
+		++i__;
+	    }
+
+	} else {
+
+/*           Revert A (A is lower) */
+
+
+/*           Revert PERMUTATIONS and IPIV */
+
+/*           Apply permutations to submatrices of lower part of A */
+/*           in reverse factorization order where i decreases from N to 1 */
+
+	    i__ = *n;
+	    while(i__ >= 1) {
+		if (ipiv[i__] > 0) {
+
+/*                 1-by-1 pivot interchange */
+
+/*                 Swap rows i and IPIV(i) in A(i:N,1:i-1) */
+
+		    ip = ipiv[i__];
+		    if (i__ > 1) {
+			if (ip != i__) {
+			    i__1 = i__ - 1;
+			    sswap_(&i__1, &a[ip + a_dim1], lda, &a[i__ + 
+				    a_dim1], lda);
+			}
+		    }
+
+		} else {
+
+/*                 2-by-2 pivot interchange */
+
+/*                 Swap rows i+1 and IPIV(i) in A(i:N,1:i-1) */
+
+		    --i__;
+		    ip = -ipiv[i__];
+		    if (i__ > 1) {
+			if (ip != i__ + 1) {
+			    i__1 = i__ - 1;
+			    sswap_(&i__1, &a[ip + a_dim1], lda, &a[i__ + 1 + 
+				    a_dim1], lda);
+			}
+		    }
+
+/*                 Convert IPIV */
+/*                 There is one interchange of rows i+1 and IPIV(i+1), */
+/*                 so this should be recorded in consecutive entries */
+/*                 in IPIV format for *SYTRF */
+
+		    ipiv[i__] = ipiv[i__ + 1];
+
+		}
+		--i__;
+	    }
+
+/*           Revert VALUE */
+/*           Assign subdiagonal entries of D from array E to */
+/*           subgiagonal entries of A. */
+
+	    i__ = 1;
+	    while(i__ <= *n - 1) {
+		if (ipiv[i__] < 0) {
+		    a[i__ + 1 + i__ * a_dim1] = e[i__];
+		    ++i__;
+		}
+		++i__;
+	    }
+
+	}
+
+/*        End A is LOWER */
+
+    }
+    return 0;
+
+/*     End of SSYCONVF */
+
+} /* ssyconvf_ */
+

lapack-netlib/SRC/ssyconvf_rook.c

@@ -0,0 +1,946 @@
+/* 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 SSYCONVF_ROOK */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYCONVF_ROOK + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssyconv
+f_rook.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssyconv
+f_rook.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssyconv
+f_rook.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYCONVF_ROOK( UPLO, WAY, N, A, LDA, E, IPIV, INFO ) */
+
+/*       CHARACTER          UPLO, WAY */
+/*       INTEGER            INFO, LDA, N */
+/*       INTEGER            IPIV( * ) */
+/*       REAL               A( LDA, * ), E( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > If parameter WAY = 'C': */
+/* > SSYCONVF_ROOK converts the factorization output format used in */
+/* > SSYTRF_ROOK provided on entry in parameter A into the factorization */
+/* > output format used in SSYTRF_RK (or SSYTRF_BK) that is stored */
+/* > on exit in parameters A and E. IPIV format for SSYTRF_ROOK and */
+/* > SSYTRF_RK (or SSYTRF_BK) is the same and is not converted. */
+/* > */
+/* > If parameter WAY = 'R': */
+/* > SSYCONVF_ROOK performs the conversion in reverse direction, i.e. */
+/* > converts the factorization output format used in SSYTRF_RK */
+/* > (or SSYTRF_BK) provided on entry in parameters A and E into */
+/* > the factorization output format used in SSYTRF_ROOK that is stored */
+/* > on exit in parameter A. IPIV format for SSYTRF_ROOK and */
+/* > SSYTRF_RK (or SSYTRF_BK) is the same and is not converted. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the details of the factorization are */
+/* >          stored as an upper or lower triangular matrix A. */
+/* >          = 'U':  Upper triangular */
+/* >          = 'L':  Lower triangular */
+/* > \endverbatim */
+/* > */
+/* > \param[in] WAY */
+/* > \verbatim */
+/* >          WAY is CHARACTER*1 */
+/* >          = 'C': Convert */
+/* >          = 'R': Revert */
+/* > \endverbatim */
+/* > */
+/* > \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) */
+/* > */
+/* >          1) If WAY ='C': */
+/* > */
+/* >          On entry, contains factorization details in format used in */
+/* >          SSYTRF_ROOK: */
+/* >            a) all elements of the symmetric block diagonal */
+/* >               matrix D on the diagonal of A and on superdiagonal */
+/* >               (or subdiagonal) of A, and */
+/* >            b) If UPLO = 'U': multipliers used to obtain factor U */
+/* >               in the superdiagonal part of A. */
+/* >               If UPLO = 'L': multipliers used to obtain factor L */
+/* >               in the superdiagonal part of A. */
+/* > */
+/* >          On exit, contains factorization details in format used in */
+/* >          SSYTRF_RK or SSYTRF_BK: */
+/* >            a) ONLY diagonal elements of the symmetric block diagonal */
+/* >               matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */
+/* >               (superdiagonal (or subdiagonal) elements of D */
+/* >                are stored on exit in array E), and */
+/* >            b) If UPLO = 'U': factor U in the superdiagonal part of A. */
+/* >               If UPLO = 'L': factor L in the subdiagonal part of A. */
+/* > */
+/* >          2) If WAY = 'R': */
+/* > */
+/* >          On entry, contains factorization details in format used in */
+/* >          SSYTRF_RK or SSYTRF_BK: */
+/* >            a) ONLY diagonal elements of the symmetric block diagonal */
+/* >               matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */
+/* >               (superdiagonal (or subdiagonal) elements of D */
+/* >                are stored on exit in array E), and */
+/* >            b) If UPLO = 'U': factor U in the superdiagonal part of A. */
+/* >               If UPLO = 'L': factor L in the subdiagonal part of A. */
+/* > */
+/* >          On exit, contains factorization details in format used in */
+/* >          SSYTRF_ROOK: */
+/* >            a) all elements of the symmetric block diagonal */
+/* >               matrix D on the diagonal of A and on superdiagonal */
+/* >               (or subdiagonal) of A, and */
+/* >            b) If UPLO = 'U': multipliers used to obtain factor U */
+/* >               in the superdiagonal part of A. */
+/* >               If UPLO = 'L': multipliers used to obtain factor L */
+/* >               in the superdiagonal part of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] E */
+/* > \verbatim */
+/* >          E is REAL array, dimension (N) */
+/* > */
+/* >          1) If WAY ='C': */
+/* > */
+/* >          On entry, just a workspace. */
+/* > */
+/* >          On exit, contains the superdiagonal (or subdiagonal) */
+/* >          elements of the symmetric block diagonal matrix D */
+/* >          with 1-by-1 or 2-by-2 diagonal blocks, where */
+/* >          If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; */
+/* >          If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. */
+/* > */
+/* >          2) If WAY = 'R': */
+/* > */
+/* >          On entry, contains the superdiagonal (or subdiagonal) */
+/* >          elements of the symmetric block diagonal matrix D */
+/* >          with 1-by-1 or 2-by-2 diagonal blocks, where */
+/* >          If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; */
+/* >          If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. */
+/* > */
+/* >          On exit, is not changed */
+/* > \endverbatim */
+/* . */
+/* > \param[in] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          On entry, details of the interchanges and the block */
+/* >          structure of D as determined: */
+/* >          1) by SSYTRF_ROOK, if WAY ='C'; */
+/* >          2) by SSYTRF_RK (or SSYTRF_BK), if WAY ='R'. */
+/* >          The IPIV format is the same for all these routines. */
+/* > */
+/* >          On exit, is not changed. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date November 2017 */
+
+/* > \ingroup singleSYcomputational */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  November 2017,  Igor Kozachenko, */
+/* >                  Computer Science Division, */
+/* >                  University of California, Berkeley */
+/* > */
+/* > \endverbatim */
+/*  ===================================================================== */
+/* Subroutine */ int ssyconvf_rook_(char *uplo, char *way, integer *n, real *
+	a, integer *lda, real *e, integer *ipiv, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1;
+
+    /* Local variables */
+    integer i__;
+    extern logical lsame_(char *, char *);
+    logical upper;
+    extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, 
+	    integer *);
+    integer ip;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    integer ip2;
+    logical convert;
+
+
+/*  -- LAPACK computational routine (version 3.8.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     November 2017 */
+
+
+/*  ===================================================================== */
+
+
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --e;
+    --ipiv;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    convert = lsame_(way, "C");
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (! convert && ! lsame_(way, "R")) {
+	*info = -2;
+    } else if (*n < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYCONVF_ROOK", &i__1, (ftnlen)13);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+    if (upper) {
+
+/*        Begin A is UPPER */
+
+	if (convert) {
+
+/*           Convert A (A is upper) */
+
+
+/*           Convert VALUE */
+
+/*           Assign superdiagonal entries of D to array E and zero out */
+/*           corresponding entries in input storage A */
+
+	    i__ = *n;
+	    e[1] = 0.f;
+	    while(i__ > 1) {
+		if (ipiv[i__] < 0) {
+		    e[i__] = a[i__ - 1 + i__ * a_dim1];
+		    e[i__ - 1] = 0.f;
+		    a[i__ - 1 + i__ * a_dim1] = 0.f;
+		    --i__;
+		} else {
+		    e[i__] = 0.f;
+		}
+		--i__;
+	    }
+
+/*           Convert PERMUTATIONS */
+
+/*           Apply permutations to submatrices of upper part of A */
+/*           in factorization order where i decreases from N to 1 */
+
+	    i__ = *n;
+	    while(i__ >= 1) {
+		if (ipiv[i__] > 0) {
+
+/*                 1-by-1 pivot interchange */
+
+/*                 Swap rows i and IPIV(i) in A(1:i,N-i:N) */
+
+		    ip = ipiv[i__];
+		    if (i__ < *n) {
+			if (ip != i__) {
+			    i__1 = *n - i__;
+			    sswap_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda, &
+				    a[ip + (i__ + 1) * a_dim1], lda);
+			}
+		    }
+
+		} else {
+
+/*                 2-by-2 pivot interchange */
+
+/*                 Swap rows i and IPIV(i) and i-1 and IPIV(i-1) */
+/*                 in A(1:i,N-i:N) */
+
+		    ip = -ipiv[i__];
+		    ip2 = -ipiv[i__ - 1];
+		    if (i__ < *n) {
+			if (ip != i__) {
+			    i__1 = *n - i__;
+			    sswap_(&i__1, &a[i__ + (i__ + 1) * a_dim1], lda, &
+				    a[ip + (i__ + 1) * a_dim1], lda);
+			}
+			if (ip2 != i__ - 1) {
+			    i__1 = *n - i__;
+			    sswap_(&i__1, &a[i__ - 1 + (i__ + 1) * a_dim1], 
+				    lda, &a[ip2 + (i__ + 1) * a_dim1], lda);
+			}
+		    }
+		    --i__;
+
+		}
+		--i__;
+	    }
+
+	} else {
+
+/*           Revert A (A is upper) */
+
+
+/*           Revert PERMUTATIONS */
+
+/*           Apply permutations to submatrices of upper part of A */
+/*           in reverse factorization order where i increases from 1 to N */
+
+	    i__ = 1;
+	    while(i__ <= *n) {
+		if (ipiv[i__] > 0) {
+
+/*                 1-by-1 pivot interchange */
+
+/*                 Swap rows i and IPIV(i) in A(1:i,N-i:N) */
+
+		    ip = ipiv[i__];
+		    if (i__ < *n) {
+			if (ip != i__) {
+			    i__1 = *n - i__;
+			    sswap_(&i__1, &a[ip + (i__ + 1) * a_dim1], lda, &
+				    a[i__ + (i__ + 1) * a_dim1], lda);
+			}
+		    }
+
+		} else {
+
+/*                 2-by-2 pivot interchange */
+
+/*                 Swap rows i-1 and IPIV(i-1) and i and IPIV(i) */
+/*                 in A(1:i,N-i:N) */
+
+		    ++i__;
+		    ip = -ipiv[i__];
+		    ip2 = -ipiv[i__ - 1];
+		    if (i__ < *n) {
+			if (ip2 != i__ - 1) {
+			    i__1 = *n - i__;
+			    sswap_(&i__1, &a[ip2 + (i__ + 1) * a_dim1], lda, &
+				    a[i__ - 1 + (i__ + 1) * a_dim1], lda);
+			}
+			if (ip != i__) {
+			    i__1 = *n - i__;
+			    sswap_(&i__1, &a[ip + (i__ + 1) * a_dim1], lda, &
+				    a[i__ + (i__ + 1) * a_dim1], lda);
+			}
+		    }
+
+		}
+		++i__;
+	    }
+
+/*           Revert VALUE */
+/*           Assign superdiagonal entries of D from array E to */
+/*           superdiagonal entries of A. */
+
+	    i__ = *n;
+	    while(i__ > 1) {
+		if (ipiv[i__] < 0) {
+		    a[i__ - 1 + i__ * a_dim1] = e[i__];
+		    --i__;
+		}
+		--i__;
+	    }
+
+/*        End A is UPPER */
+
+	}
+
+    } else {
+
+/*        Begin A is LOWER */
+
+	if (convert) {
+
+/*           Convert A (A is lower) */
+
+
+/*           Convert VALUE */
+/*           Assign subdiagonal entries of D to array E and zero out */
+/*           corresponding entries in input storage A */
+
+	    i__ = 1;
+	    e[*n] = 0.f;
+	    while(i__ <= *n) {
+		if (i__ < *n && ipiv[i__] < 0) {
+		    e[i__] = a[i__ + 1 + i__ * a_dim1];
+		    e[i__ + 1] = 0.f;
+		    a[i__ + 1 + i__ * a_dim1] = 0.f;
+		    ++i__;
+		} else {
+		    e[i__] = 0.f;
+		}
+		++i__;
+	    }
+
+/*           Convert PERMUTATIONS */
+
+/*           Apply permutations to submatrices of lower part of A */
+/*           in factorization order where i increases from 1 to N */
+
+	    i__ = 1;
+	    while(i__ <= *n) {
+		if (ipiv[i__] > 0) {
+
+/*                 1-by-1 pivot interchange */
+
+/*                 Swap rows i and IPIV(i) in A(i:N,1:i-1) */
+
+		    ip = ipiv[i__];
+		    if (i__ > 1) {
+			if (ip != i__) {
+			    i__1 = i__ - 1;
+			    sswap_(&i__1, &a[i__ + a_dim1], lda, &a[ip + 
+				    a_dim1], lda);
+			}
+		    }
+
+		} else {
+
+/*                 2-by-2 pivot interchange */
+
+/*                 Swap rows i and IPIV(i) and i+1 and IPIV(i+1) */
+/*                 in A(i:N,1:i-1) */
+
+		    ip = -ipiv[i__];
+		    ip2 = -ipiv[i__ + 1];
+		    if (i__ > 1) {
+			if (ip != i__) {
+			    i__1 = i__ - 1;
+			    sswap_(&i__1, &a[i__ + a_dim1], lda, &a[ip + 
+				    a_dim1], lda);
+			}
+			if (ip2 != i__ + 1) {
+			    i__1 = i__ - 1;
+			    sswap_(&i__1, &a[i__ + 1 + a_dim1], lda, &a[ip2 + 
+				    a_dim1], lda);
+			}
+		    }
+		    ++i__;
+
+		}
+		++i__;
+	    }
+
+	} else {
+
+/*           Revert A (A is lower) */
+
+
+/*           Revert PERMUTATIONS */
+
+/*           Apply permutations to submatrices of lower part of A */
+/*           in reverse factorization order where i decreases from N to 1 */
+
+	    i__ = *n;
+	    while(i__ >= 1) {
+		if (ipiv[i__] > 0) {
+
+/*                 1-by-1 pivot interchange */
+
+/*                 Swap rows i and IPIV(i) in A(i:N,1:i-1) */
+
+		    ip = ipiv[i__];
+		    if (i__ > 1) {
+			if (ip != i__) {
+			    i__1 = i__ - 1;
+			    sswap_(&i__1, &a[ip + a_dim1], lda, &a[i__ + 
+				    a_dim1], lda);
+			}
+		    }
+
+		} else {
+
+/*                 2-by-2 pivot interchange */
+
+/*                 Swap rows i+1 and IPIV(i+1) and i and IPIV(i) */
+/*                 in A(i:N,1:i-1) */
+
+		    --i__;
+		    ip = -ipiv[i__];
+		    ip2 = -ipiv[i__ + 1];
+		    if (i__ > 1) {
+			if (ip2 != i__ + 1) {
+			    i__1 = i__ - 1;
+			    sswap_(&i__1, &a[ip2 + a_dim1], lda, &a[i__ + 1 + 
+				    a_dim1], lda);
+			}
+			if (ip != i__) {
+			    i__1 = i__ - 1;
+			    sswap_(&i__1, &a[ip + a_dim1], lda, &a[i__ + 
+				    a_dim1], lda);
+			}
+		    }
+
+		}
+		--i__;
+	    }
+
+/*           Revert VALUE */
+/*           Assign subdiagonal entries of D from array E to */
+/*           subgiagonal entries of A. */
+
+	    i__ = 1;
+	    while(i__ <= *n - 1) {
+		if (ipiv[i__] < 0) {
+		    a[i__ + 1 + i__ * a_dim1] = e[i__];
+		    ++i__;
+		}
+		++i__;
+	    }
+
+	}
+
+/*        End A is LOWER */
+
+    }
+    return 0;
+
+/*     End of SSYCONVF_ROOK */
+
+} /* ssyconvf_rook__ */
+

lapack-netlib/SRC/ssyequb.c

@@ -0,0 +1,762 @@
+/* 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;
+
+/* > \brief \b SSYEQUB */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYEQUB + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssyequb
+.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssyequb
+.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssyequb
+.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYEQUB( UPLO, N, A, LDA, S, SCOND, AMAX, WORK, INFO ) */
+
+/*       INTEGER            INFO, LDA, N */
+/*       REAL               AMAX, SCOND */
+/*       CHARACTER          UPLO */
+/*       REAL               A( LDA, * ), S( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYEQUB computes row and column scalings intended to equilibrate a */
+/* > symmetric matrix A (with respect to the Euclidean norm) and reduce */
+/* > its condition number. The scale factors S are computed by the BIN */
+/* > algorithm (see references) so that the scaled matrix B with elements */
+/* > B(i,j) = S(i)*A(i,j)*S(j) has a condition number within a factor N of */
+/* > the smallest possible condition number over all possible diagonal */
+/* > scalings. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A. N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          The N-by-N symmetric matrix whose scaling factors are to be */
+/* >          computed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A. LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] S */
+/* > \verbatim */
+/* >          S is REAL array, dimension (N) */
+/* >          If INFO = 0, S contains the scale factors for A. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] SCOND */
+/* > \verbatim */
+/* >          SCOND is REAL */
+/* >          If INFO = 0, S contains the ratio of the smallest S(i) to */
+/* >          the largest S(i). If SCOND >= 0.1 and AMAX is neither too */
+/* >          large nor too small, it is not worth scaling by S. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] AMAX */
+/* > \verbatim */
+/* >          AMAX is REAL */
+/* >          Largest absolute value of any matrix element. If AMAX is */
+/* >          very close to overflow or very close to underflow, the */
+/* >          matrix should be scaled. */
+/* > \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 */
+/* >          > 0:  if INFO = i, the i-th diagonal element is nonpositive. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date November 2017 */
+
+/* > \ingroup realSYcomputational */
+
+/* > \par References: */
+/*  ================ */
+/* > */
+/* >  Livne, O.E. and Golub, G.H., "Scaling by Binormalization", \n */
+/* >  Numerical Algorithms, vol. 35, no. 1, pp. 97-120, January 2004. \n */
+/* >  DOI 10.1023/B:NUMA.0000016606.32820.69 \n */
+/* >  Tech report version: http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.3.1679 */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int ssyequb_(char *uplo, integer *n, real *a, integer *lda, 
+	real *s, real *scond, real *amax, real *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+    real r__1, r__2, r__3;
+
+    /* Local variables */
+    real base;
+    integer iter;
+    real smin, smax, d__;
+    integer i__, j;
+    real t, u, scale;
+    extern logical lsame_(char *, char *);
+    real c0, c1, c2, sumsq, si;
+    logical up;
+    extern real slamch_(char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    real bignum;
+    extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, 
+	    real *);
+    real smlnum, avg, std, tol;
+
+
+/*  -- LAPACK computational routine (version 3.8.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     November 2017 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --s;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    if (! (lsame_(uplo, "U") || lsame_(uplo, "L"))) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -4;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYEQUB", &i__1, (ftnlen)7);
+	return 0;
+    }
+    up = lsame_(uplo, "U");
+    *amax = 0.f;
+
+/*     Quick return if possible. */
+
+    if (*n == 0) {
+	*scond = 1.f;
+	return 0;
+    }
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	s[i__] = 0.f;
+    }
+    *amax = 0.f;
+    if (up) {
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    i__2 = j - 1;
+	    for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+		r__2 = s[i__], r__3 = (r__1 = a[i__ + j * a_dim1], abs(r__1));
+		s[i__] = f2cmax(r__2,r__3);
+/* Computing MAX */
+		r__2 = s[j], r__3 = (r__1 = a[i__ + j * a_dim1], abs(r__1));
+		s[j] = f2cmax(r__2,r__3);
+/* Computing MAX */
+		r__2 = *amax, r__3 = (r__1 = a[i__ + j * a_dim1], abs(r__1));
+		*amax = f2cmax(r__2,r__3);
+	    }
+/* Computing MAX */
+	    r__2 = s[j], r__3 = (r__1 = a[j + j * a_dim1], abs(r__1));
+	    s[j] = f2cmax(r__2,r__3);
+/* Computing MAX */
+	    r__2 = *amax, r__3 = (r__1 = a[j + j * a_dim1], abs(r__1));
+	    *amax = f2cmax(r__2,r__3);
+	}
+    } else {
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+	    r__2 = s[j], r__3 = (r__1 = a[j + j * a_dim1], abs(r__1));
+	    s[j] = f2cmax(r__2,r__3);
+/* Computing MAX */
+	    r__2 = *amax, r__3 = (r__1 = a[j + j * a_dim1], abs(r__1));
+	    *amax = f2cmax(r__2,r__3);
+	    i__2 = *n;
+	    for (i__ = j + 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+		r__2 = s[i__], r__3 = (r__1 = a[i__ + j * a_dim1], abs(r__1));
+		s[i__] = f2cmax(r__2,r__3);
+/* Computing MAX */
+		r__2 = s[j], r__3 = (r__1 = a[i__ + j * a_dim1], abs(r__1));
+		s[j] = f2cmax(r__2,r__3);
+/* Computing MAX */
+		r__2 = *amax, r__3 = (r__1 = a[i__ + j * a_dim1], abs(r__1));
+		*amax = f2cmax(r__2,r__3);
+	    }
+	}
+    }
+    i__1 = *n;
+    for (j = 1; j <= i__1; ++j) {
+	s[j] = 1.f / s[j];
+    }
+    tol = 1.f / sqrt(*n * 2.f);
+    for (iter = 1; iter <= 100; ++iter) {
+	scale = 0.f;
+	sumsq = 0.f;
+/*        beta = |A|s */
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    work[i__] = 0.f;
+	}
+	if (up) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		i__2 = j - 1;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    work[i__] += (r__1 = a[i__ + j * a_dim1], abs(r__1)) * s[
+			    j];
+		    work[j] += (r__1 = a[i__ + j * a_dim1], abs(r__1)) * s[
+			    i__];
+		}
+		work[j] += (r__1 = a[j + j * a_dim1], abs(r__1)) * s[j];
+	    }
+	} else {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		work[j] += (r__1 = a[j + j * a_dim1], abs(r__1)) * s[j];
+		i__2 = *n;
+		for (i__ = j + 1; i__ <= i__2; ++i__) {
+		    work[i__] += (r__1 = a[i__ + j * a_dim1], abs(r__1)) * s[
+			    j];
+		    work[j] += (r__1 = a[i__ + j * a_dim1], abs(r__1)) * s[
+			    i__];
+		}
+	    }
+	}
+/*        avg = s^T beta / n */
+	avg = 0.f;
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    avg += s[i__] * work[i__];
+	}
+	avg /= *n;
+	std = 0.f;
+	i__1 = *n << 1;
+	for (i__ = *n + 1; i__ <= i__1; ++i__) {
+	    work[i__] = s[i__ - *n] * work[i__ - *n] - avg;
+	}
+	slassq_(n, &work[*n + 1], &c__1, &scale, &sumsq);
+	std = scale * sqrt(sumsq / *n);
+	if (std < tol * avg) {
+	    goto L999;
+	}
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    t = (r__1 = a[i__ + i__ * a_dim1], abs(r__1));
+	    si = s[i__];
+	    c2 = (*n - 1) * t;
+	    c1 = (*n - 2) * (work[i__] - t * si);
+	    c0 = -(t * si) * si + work[i__] * 2 * si - *n * avg;
+	    d__ = c1 * c1 - c0 * 4 * c2;
+	    if (d__ <= 0.f) {
+		*info = -1;
+		return 0;
+	    }
+	    si = c0 * -2 / (c1 + sqrt(d__));
+	    d__ = si - s[i__];
+	    u = 0.f;
+	    if (up) {
+		i__2 = i__;
+		for (j = 1; j <= i__2; ++j) {
+		    t = (r__1 = a[j + i__ * a_dim1], abs(r__1));
+		    u += s[j] * t;
+		    work[j] += d__ * t;
+		}
+		i__2 = *n;
+		for (j = i__ + 1; j <= i__2; ++j) {
+		    t = (r__1 = a[i__ + j * a_dim1], abs(r__1));
+		    u += s[j] * t;
+		    work[j] += d__ * t;
+		}
+	    } else {
+		i__2 = i__;
+		for (j = 1; j <= i__2; ++j) {
+		    t = (r__1 = a[i__ + j * a_dim1], abs(r__1));
+		    u += s[j] * t;
+		    work[j] += d__ * t;
+		}
+		i__2 = *n;
+		for (j = i__ + 1; j <= i__2; ++j) {
+		    t = (r__1 = a[j + i__ * a_dim1], abs(r__1));
+		    u += s[j] * t;
+		    work[j] += d__ * t;
+		}
+	    }
+	    avg += (u + work[i__]) * d__ / *n;
+	    s[i__] = si;
+	}
+    }
+L999:
+    smlnum = slamch_("SAFEMIN");
+    bignum = 1.f / smlnum;
+    smin = bignum;
+    smax = 0.f;
+    t = 1.f / sqrt(avg);
+    base = slamch_("B");
+    u = 1.f / log(base);
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	i__2 = (integer) (u * log(s[i__] * t));
+	s[i__] = pow_ri(&base, &i__2);
+/* Computing MIN */
+	r__1 = smin, r__2 = s[i__];
+	smin = f2cmin(r__1,r__2);
+/* Computing MAX */
+	r__1 = smax, r__2 = s[i__];
+	smax = f2cmax(r__1,r__2);
+    }
+    *scond = f2cmax(smin,smlnum) / f2cmin(smax,bignum);
+
+    return 0;
+} /* ssyequb_ */
+

lapack-netlib/SRC/ssyev.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__1 = 1;
+static integer c_n1 = -1;
+static integer c__0 = 0;
+static real c_b17 = 1.f;
+
+/* > \brief <b> SSYEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY matr
+ices</b> */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYEV + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssyev.f
+"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssyev.f
+"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssyev.f
+"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO ) */
+
+/*       CHARACTER          JOBZ, UPLO */
+/*       INTEGER            INFO, LDA, LWORK, N */
+/*       REAL               A( LDA, * ), W( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYEV computes all eigenvalues and, optionally, eigenvectors of a */
+/* > real symmetric matrix A. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] JOBZ */
+/* > \verbatim */
+/* >          JOBZ is CHARACTER*1 */
+/* >          = 'N':  Compute eigenvalues only; */
+/* >          = 'V':  Compute eigenvalues and eigenvectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \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 symmetric matrix A.  If UPLO = 'U', the */
+/* >          leading N-by-N upper triangular part of A contains the */
+/* >          upper triangular part of the matrix A.  If UPLO = 'L', */
+/* >          the leading N-by-N lower triangular part of A contains */
+/* >          the lower triangular part of the matrix A. */
+/* >          On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* >          orthonormal eigenvectors of the matrix A. */
+/* >          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') */
+/* >          or the upper triangle (if UPLO='U') of A, including the */
+/* >          diagonal, is destroyed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] W */
+/* > \verbatim */
+/* >          W is REAL array, dimension (N) */
+/* >          If INFO = 0, the eigenvalues in ascending order. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (MAX(1,LWORK)) */
+/* >          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The length of the array WORK.  LWORK >= f2cmax(1,3*N-1). */
+/* >          For optimal efficiency, LWORK >= (NB+2)*N, */
+/* >          where NB is the blocksize for SSYTRD returned by ILAENV. */
+/* > */
+/* >          If LWORK = -1, then a workspace query is assumed; the routine */
+/* >          only calculates the optimal size of the WORK array, returns */
+/* >          this value as the first entry of the WORK array, and no error */
+/* >          message related to LWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0:  if INFO = i, the algorithm failed to converge; i */
+/* >                off-diagonal elements of an intermediate tridiagonal */
+/* >                form did not converge to zero. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realSYeigen */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssyev_(char *jobz, char *uplo, integer *n, real *a, 
+	integer *lda, real *w, real *work, integer *lwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+    real r__1;
+
+    /* Local variables */
+    integer inde;
+    real anrm;
+    integer imax;
+    real rmin, rmax, sigma;
+    extern logical lsame_(char *, char *);
+    integer iinfo;
+    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+    logical lower, wantz;
+    integer nb, iscale;
+    extern real slamch_(char *);
+    real safmin;
+    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
+	    integer *, integer *, ftnlen, ftnlen);
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    real bignum;
+    extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, 
+	    real *, integer *, integer *, real *, integer *, integer *);
+    integer indtau, indwrk;
+    extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
+    extern real slansy_(char *, char *, integer *, real *, integer *, real *);
+    integer llwork;
+    real smlnum;
+    integer lwkopt;
+    logical lquery;
+    extern /* Subroutine */ int sorgtr_(char *, integer *, real *, integer *, 
+	    real *, real *, integer *, integer *), ssteqr_(char *, 
+	    integer *, real *, real *, real *, integer *, real *, integer *), ssytrd_(char *, integer *, real *, integer *, real *, 
+	    real *, real *, real *, integer *, integer *);
+    real eps;
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --w;
+    --work;
+
+    /* Function Body */
+    wantz = lsame_(jobz, "V");
+    lower = lsame_(uplo, "L");
+    lquery = *lwork == -1;
+
+    *info = 0;
+    if (! (wantz || lsame_(jobz, "N"))) {
+	*info = -1;
+    } else if (! (lower || lsame_(uplo, "U"))) {
+	*info = -2;
+    } else if (*n < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    }
+
+    if (*info == 0) {
+	nb = ilaenv_(&c__1, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
+		 (ftnlen)1);
+/* Computing MAX */
+	i__1 = 1, i__2 = (nb + 2) * *n;
+	lwkopt = f2cmax(i__1,i__2);
+	work[1] = (real) lwkopt;
+
+/* Computing MAX */
+	i__1 = 1, i__2 = *n * 3 - 1;
+	if (*lwork < f2cmax(i__1,i__2) && ! lquery) {
+	    *info = -8;
+	}
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYEV ", &i__1, (ftnlen)6);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+    if (*n == 1) {
+	w[1] = a[a_dim1 + 1];
+	work[1] = 2.f;
+	if (wantz) {
+	    a[a_dim1 + 1] = 1.f;
+	}
+	return 0;
+    }
+
+/*     Get machine constants. */
+
+    safmin = slamch_("Safe minimum");
+    eps = slamch_("Precision");
+    smlnum = safmin / eps;
+    bignum = 1.f / smlnum;
+    rmin = sqrt(smlnum);
+    rmax = sqrt(bignum);
+
+/*     Scale matrix to allowable range, if necessary. */
+
+    anrm = slansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
+    iscale = 0;
+    if (anrm > 0.f && anrm < rmin) {
+	iscale = 1;
+	sigma = rmin / anrm;
+    } else if (anrm > rmax) {
+	iscale = 1;
+	sigma = rmax / anrm;
+    }
+    if (iscale == 1) {
+	slascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda, 
+		info);
+    }
+
+/*     Call SSYTRD to reduce symmetric matrix to tridiagonal form. */
+
+    inde = 1;
+    indtau = inde + *n;
+    indwrk = indtau + *n;
+    llwork = *lwork - indwrk + 1;
+    ssytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], &
+	    work[indwrk], &llwork, &iinfo);
+
+/*     For eigenvalues only, call SSTERF.  For eigenvectors, first call */
+/*     SORGTR to generate the orthogonal matrix, then call SSTEQR. */
+
+    if (! wantz) {
+	ssterf_(n, &w[1], &work[inde], info);
+    } else {
+	sorgtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], &
+		llwork, &iinfo);
+	ssteqr_(jobz, n, &w[1], &work[inde], &a[a_offset], lda, &work[indtau],
+		 info);
+    }
+
+/*     If matrix was scaled, then rescale eigenvalues appropriately. */
+
+    if (iscale == 1) {
+	if (*info == 0) {
+	    imax = *n;
+	} else {
+	    imax = *info - 1;
+	}
+	r__1 = 1.f / sigma;
+	sscal_(&imax, &r__1, &w[1], &c__1);
+    }
+
+/*     Set WORK(1) to optimal workspace size. */
+
+    work[1] = (real) lwkopt;
+
+    return 0;
+
+/*     End of SSYEV */
+
+} /* ssyev_ */
+

lapack-netlib/SRC/ssyev_2stage.c

@@ -0,0 +1,773 @@
+/* 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_n1 = -1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static integer c__0 = 0;
+static real c_b27 = 1.f;
+
+/* > \brief <b> SSYEV_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for 
+SY matrices</b> */
+
+/*  @generated from dsyev_2stage.f, fortran d -> s, Sat Nov  5 23:55:51 2016 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYEV_2STAGE + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssyevd_
+2stage.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssyevd_
+2stage.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssyevd_
+2stage.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYEV_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, */
+/*                                INFO ) */
+
+/*       IMPLICIT NONE */
+
+/*       CHARACTER          JOBZ, UPLO */
+/*       INTEGER            INFO, LDA, LWORK, N */
+/*       REAL               A( LDA, * ), W( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYEV_2STAGE computes all eigenvalues and, optionally, eigenvectors of a */
+/* > real symmetric matrix A using the 2stage technique for */
+/* > the reduction to tridiagonal. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] JOBZ */
+/* > \verbatim */
+/* >          JOBZ is CHARACTER*1 */
+/* >          = 'N':  Compute eigenvalues only; */
+/* >          = 'V':  Compute eigenvalues and eigenvectors. */
+/* >                  Not available in this release. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \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 symmetric matrix A.  If UPLO = 'U', the */
+/* >          leading N-by-N upper triangular part of A contains the */
+/* >          upper triangular part of the matrix A.  If UPLO = 'L', */
+/* >          the leading N-by-N lower triangular part of A contains */
+/* >          the lower triangular part of the matrix A. */
+/* >          On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* >          orthonormal eigenvectors of the matrix A. */
+/* >          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') */
+/* >          or the upper triangle (if UPLO='U') of A, including the */
+/* >          diagonal, is destroyed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] W */
+/* > \verbatim */
+/* >          W is REAL array, dimension (N) */
+/* >          If INFO = 0, the eigenvalues in ascending order. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension LWORK */
+/* >          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The length of the array WORK. LWORK >= 1, when N <= 1; */
+/* >          otherwise */
+/* >          If JOBZ = 'N' and N > 1, LWORK must be queried. */
+/* >                                   LWORK = MAX(1, dimension) where */
+/* >                                   dimension = f2cmax(stage1,stage2) + (KD+1)*N + 2*N */
+/* >                                             = N*KD + N*f2cmax(KD+1,FACTOPTNB) */
+/* >                                               + f2cmax(2*KD*KD, KD*NTHREADS) */
+/* >                                               + (KD+1)*N + 2*N */
+/* >                                   where KD is the blocking size of the reduction, */
+/* >                                   FACTOPTNB is the blocking used by the QR or LQ */
+/* >                                   algorithm, usually FACTOPTNB=128 is a good choice */
+/* >                                   NTHREADS is the number of threads used when */
+/* >                                   openMP compilation is enabled, otherwise =1. */
+/* >          If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available */
+/* > */
+/* >          If LWORK = -1, then a workspace query is assumed; the routine */
+/* >          only calculates the optimal size of the WORK array, returns */
+/* >          this value as the first entry of the WORK array, and no error */
+/* >          message related to LWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0:  if INFO = i, the algorithm failed to converge; i */
+/* >                off-diagonal elements of an intermediate tridiagonal */
+/* >                form did not converge to zero. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date November 2017 */
+
+/* > \ingroup realSYeigen */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  All details about the 2stage techniques are available in: */
+/* > */
+/* >  Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */
+/* >  Parallel reduction to condensed forms for symmetric eigenvalue problems */
+/* >  using aggregated fine-grained and memory-aware kernels. In Proceedings */
+/* >  of 2011 International Conference for High Performance Computing, */
+/* >  Networking, Storage and Analysis (SC '11), New York, NY, USA, */
+/* >  Article 8 , 11 pages. */
+/* >  http://doi.acm.org/10.1145/2063384.2063394 */
+/* > */
+/* >  A. Haidar, J. Kurzak, P. Luszczek, 2013. */
+/* >  An improved parallel singular value algorithm and its implementation */
+/* >  for multicore hardware, In Proceedings of 2013 International Conference */
+/* >  for High Performance Computing, Networking, Storage and Analysis (SC '13). */
+/* >  Denver, Colorado, USA, 2013. */
+/* >  Article 90, 12 pages. */
+/* >  http://doi.acm.org/10.1145/2503210.2503292 */
+/* > */
+/* >  A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */
+/* >  A novel hybrid CPU-GPU generalized eigensolver for electronic structure */
+/* >  calculations based on fine-grained memory aware tasks. */
+/* >  International Journal of High Performance Computing Applications. */
+/* >  Volume 28 Issue 2, Pages 196-209, May 2014. */
+/* >  http://hpc.sagepub.com/content/28/2/196 */
+/* > */
+/* > \endverbatim */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssyev_2stage_(char *jobz, char *uplo, integer *n, real *
+	a, integer *lda, real *w, real *work, integer *lwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1;
+    real r__1;
+
+    /* Local variables */
+    integer inde;
+    extern integer ilaenv2stage_(integer *, char *, char *, integer *, 
+	    integer *, integer *, integer *);
+    real anrm;
+    integer imax;
+    real rmin, rmax, sigma;
+    extern logical lsame_(char *, char *);
+    integer iinfo;
+    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+    integer lhtrd, lwmin;
+    logical lower;
+    extern /* Subroutine */ int ssytrd_2stage_(char *, char *, integer *, 
+	    real *, integer *, real *, real *, real *, real *, integer *, 
+	    real *, integer *, integer *);
+    integer lwtrd;
+    logical wantz;
+    integer ib, kd, iscale;
+    extern real slamch_(char *);
+    real safmin;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    real bignum;
+    extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, 
+	    real *, integer *, integer *, real *, integer *, integer *);
+    integer indtau, indwrk;
+    extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
+    extern real slansy_(char *, char *, integer *, real *, integer *, real *);
+    integer llwork;
+    real smlnum;
+    extern /* Subroutine */ int sorgtr_(char *, integer *, real *, integer *, 
+	    real *, real *, integer *, integer *);
+    logical lquery;
+    extern /* Subroutine */ int ssteqr_(char *, integer *, real *, real *, 
+	    real *, integer *, real *, integer *);
+    real eps;
+    integer indhous;
+
+
+
+/*  -- LAPACK driver 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --w;
+    --work;
+
+    /* Function Body */
+    wantz = lsame_(jobz, "V");
+    lower = lsame_(uplo, "L");
+    lquery = *lwork == -1;
+
+    *info = 0;
+    if (! lsame_(jobz, "N")) {
+	*info = -1;
+    } else if (! (lower || lsame_(uplo, "U"))) {
+	*info = -2;
+    } else if (*n < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    }
+
+    if (*info == 0) {
+	kd = ilaenv2stage_(&c__1, "SSYTRD_2STAGE", jobz, n, &c_n1, &c_n1, &
+		c_n1);
+	ib = ilaenv2stage_(&c__2, "SSYTRD_2STAGE", jobz, n, &kd, &c_n1, &c_n1);
+	lhtrd = ilaenv2stage_(&c__3, "SSYTRD_2STAGE", jobz, n, &kd, &ib, &
+		c_n1);
+	lwtrd = ilaenv2stage_(&c__4, "SSYTRD_2STAGE", jobz, n, &kd, &ib, &
+		c_n1);
+	lwmin = (*n << 1) + lhtrd + lwtrd;
+	work[1] = (real) lwmin;
+
+	if (*lwork < lwmin && ! lquery) {
+	    *info = -8;
+	}
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYEV_2STAGE ", &i__1, (ftnlen)13);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+    if (*n == 1) {
+	w[1] = a[a_dim1 + 1];
+	work[1] = 2.f;
+	if (wantz) {
+	    a[a_dim1 + 1] = 1.f;
+	}
+	return 0;
+    }
+
+/*     Get machine constants. */
+
+    safmin = slamch_("Safe minimum");
+    eps = slamch_("Precision");
+    smlnum = safmin / eps;
+    bignum = 1.f / smlnum;
+    rmin = sqrt(smlnum);
+    rmax = sqrt(bignum);
+
+/*     Scale matrix to allowable range, if necessary. */
+
+    anrm = slansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
+    iscale = 0;
+    if (anrm > 0.f && anrm < rmin) {
+	iscale = 1;
+	sigma = rmin / anrm;
+    } else if (anrm > rmax) {
+	iscale = 1;
+	sigma = rmax / anrm;
+    }
+    if (iscale == 1) {
+	slascl_(uplo, &c__0, &c__0, &c_b27, &sigma, n, n, &a[a_offset], lda, 
+		info);
+    }
+
+/*     Call SSYTRD_2STAGE to reduce symmetric matrix to tridiagonal form. */
+
+    inde = 1;
+    indtau = inde + *n;
+    indhous = indtau + *n;
+    indwrk = indhous + lhtrd;
+    llwork = *lwork - indwrk + 1;
+
+    ssytrd_2stage_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[inde], &
+	    work[indtau], &work[indhous], &lhtrd, &work[indwrk], &llwork, &
+	    iinfo);
+
+/*     For eigenvalues only, call SSTERF.  For eigenvectors, first call */
+/*     SORGTR to generate the orthogonal matrix, then call SSTEQR. */
+
+    if (! wantz) {
+	ssterf_(n, &w[1], &work[inde], info);
+    } else {
+/*        Not available in this release, and argument checking should not */
+/*        let it getting here */
+	return 0;
+	sorgtr_(uplo, n, &a[a_offset], lda, &work[indtau], &work[indwrk], &
+		llwork, &iinfo);
+	ssteqr_(jobz, n, &w[1], &work[inde], &a[a_offset], lda, &work[indtau],
+		 info);
+    }
+
+/*     If matrix was scaled, then rescale eigenvalues appropriately. */
+
+    if (iscale == 1) {
+	if (*info == 0) {
+	    imax = *n;
+	} else {
+	    imax = *info - 1;
+	}
+	r__1 = 1.f / sigma;
+	sscal_(&imax, &r__1, &w[1], &c__1);
+    }
+
+/*     Set WORK(1) to optimal workspace size. */
+
+    work[1] = (real) lwmin;
+
+    return 0;
+
+/*     End of SSYEV_2STAGE */
+
+} /* ssyev_2stage__ */
+

lapack-netlib/SRC/ssyevd.c

@@ -0,0 +1,781 @@
+/* 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_n1 = -1;
+static integer c__0 = 0;
+static real c_b17 = 1.f;
+
+/* > \brief <b> SSYEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for SY mat
+rices</b> */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYEVD + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssyevd.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssyevd.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssyevd.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, */
+/*                          LIWORK, INFO ) */
+
+/*       CHARACTER          JOBZ, UPLO */
+/*       INTEGER            INFO, LDA, LIWORK, LWORK, N */
+/*       INTEGER            IWORK( * ) */
+/*       REAL               A( LDA, * ), W( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYEVD computes all eigenvalues and, optionally, eigenvectors of a */
+/* > real symmetric matrix A. If eigenvectors are desired, it uses a */
+/* > divide and conquer algorithm. */
+/* > */
+/* > The divide and conquer algorithm makes very mild assumptions about */
+/* > floating point arithmetic. It will work on machines with a guard */
+/* > digit in add/subtract, or on those binary machines without guard */
+/* > digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* > Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* > without guard digits, but we know of none. */
+/* > */
+/* > Because of large use of BLAS of level 3, SSYEVD needs N**2 more */
+/* > workspace than SSYEVX. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] JOBZ */
+/* > \verbatim */
+/* >          JOBZ is CHARACTER*1 */
+/* >          = 'N':  Compute eigenvalues only; */
+/* >          = 'V':  Compute eigenvalues and eigenvectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \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 symmetric matrix A.  If UPLO = 'U', the */
+/* >          leading N-by-N upper triangular part of A contains the */
+/* >          upper triangular part of the matrix A.  If UPLO = 'L', */
+/* >          the leading N-by-N lower triangular part of A contains */
+/* >          the lower triangular part of the matrix A. */
+/* >          On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* >          orthonormal eigenvectors of the matrix A. */
+/* >          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') */
+/* >          or the upper triangle (if UPLO='U') of A, including the */
+/* >          diagonal, is destroyed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] W */
+/* > \verbatim */
+/* >          W is REAL array, dimension (N) */
+/* >          If INFO = 0, the eigenvalues in ascending order. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, */
+/* >                                         dimension (LWORK) */
+/* >          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The dimension of the array WORK. */
+/* >          If N <= 1,               LWORK must be at least 1. */
+/* >          If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1. */
+/* >          If JOBZ = 'V' and N > 1, LWORK must be at least */
+/* >                                                1 + 6*N + 2*N**2. */
+/* > */
+/* >          If LWORK = -1, then a workspace query is assumed; the routine */
+/* >          only calculates the optimal sizes of the WORK and IWORK */
+/* >          arrays, returns these values as the first entries of the WORK */
+/* >          and IWORK arrays, and no error message related to LWORK or */
+/* >          LIWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */
+/* >          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LIWORK */
+/* > \verbatim */
+/* >          LIWORK is INTEGER */
+/* >          The dimension of the array IWORK. */
+/* >          If N <= 1,                LIWORK must be at least 1. */
+/* >          If JOBZ  = 'N' and N > 1, LIWORK must be at least 1. */
+/* >          If JOBZ  = 'V' and N > 1, LIWORK must be at least 3 + 5*N. */
+/* > */
+/* >          If LIWORK = -1, then a workspace query is assumed; the */
+/* >          routine only calculates the optimal sizes of the WORK and */
+/* >          IWORK arrays, returns these values as the first entries of */
+/* >          the WORK and IWORK arrays, and no error message related to */
+/* >          LWORK or LIWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0:  if INFO = i and JOBZ = 'N', then the algorithm failed */
+/* >                to converge; i off-diagonal elements of an intermediate */
+/* >                tridiagonal form did not converge to zero; */
+/* >                if INFO = i and JOBZ = 'V', then the algorithm failed */
+/* >                to compute an eigenvalue while working on the submatrix */
+/* >                lying in rows and columns INFO/(N+1) through */
+/* >                mod(INFO,N+1). */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realSYeigen */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > */
+/* > Jeff Rutter, Computer Science Division, University of California */
+/* > at Berkeley, USA \n */
+/* >  Modified by Francoise Tisseur, University of Tennessee \n */
+/* >  Modified description of INFO. Sven, 16 Feb 05. \n */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int ssyevd_(char *jobz, char *uplo, integer *n, real *a, 
+	integer *lda, real *w, real *work, integer *lwork, integer *iwork, 
+	integer *liwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+    real r__1;
+
+    /* Local variables */
+    integer inde;
+    real anrm, rmin, rmax;
+    integer lopt;
+    real sigma;
+    extern logical lsame_(char *, char *);
+    integer iinfo;
+    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+    integer lwmin, liopt;
+    logical lower, wantz;
+    integer indwk2, llwrk2, iscale;
+    extern real slamch_(char *);
+    real safmin;
+    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
+	    integer *, integer *, ftnlen, ftnlen);
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    real bignum;
+    extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, 
+	    real *, integer *, integer *, real *, integer *, integer *);
+    integer indtau;
+    extern /* Subroutine */ int sstedc_(char *, integer *, real *, real *, 
+	    real *, integer *, real *, integer *, integer *, integer *, 
+	    integer *), slacpy_(char *, integer *, integer *, real *, 
+	    integer *, real *, integer *);
+    integer indwrk, liwmin;
+    extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
+    extern real slansy_(char *, char *, integer *, real *, integer *, real *);
+    integer llwork;
+    real smlnum;
+    logical lquery;
+    extern /* Subroutine */ int sormtr_(char *, char *, char *, integer *, 
+	    integer *, real *, integer *, real *, real *, integer *, real *, 
+	    integer *, integer *), ssytrd_(char *, 
+	    integer *, real *, integer *, real *, real *, real *, real *, 
+	    integer *, integer *);
+    real eps;
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --w;
+    --work;
+    --iwork;
+
+    /* Function Body */
+    wantz = lsame_(jobz, "V");
+    lower = lsame_(uplo, "L");
+    lquery = *lwork == -1 || *liwork == -1;
+
+    *info = 0;
+    if (! (wantz || lsame_(jobz, "N"))) {
+	*info = -1;
+    } else if (! (lower || lsame_(uplo, "U"))) {
+	*info = -2;
+    } else if (*n < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    }
+
+    if (*info == 0) {
+	if (*n <= 1) {
+	    liwmin = 1;
+	    lwmin = 1;
+	    lopt = lwmin;
+	    liopt = liwmin;
+	} else {
+	    if (wantz) {
+		liwmin = *n * 5 + 3;
+/* Computing 2nd power */
+		i__1 = *n;
+		lwmin = *n * 6 + 1 + (i__1 * i__1 << 1);
+	    } else {
+		liwmin = 1;
+		lwmin = (*n << 1) + 1;
+	    }
+/* Computing MAX */
+	    i__1 = lwmin, i__2 = (*n << 1) + ilaenv_(&c__1, "SSYTRD", uplo, n,
+		     &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1);
+	    lopt = f2cmax(i__1,i__2);
+	    liopt = liwmin;
+	}
+	work[1] = (real) lopt;
+	iwork[1] = liopt;
+
+	if (*lwork < lwmin && ! lquery) {
+	    *info = -8;
+	} else if (*liwork < liwmin && ! lquery) {
+	    *info = -10;
+	}
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYEVD", &i__1, (ftnlen)6);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+    if (*n == 1) {
+	w[1] = a[a_dim1 + 1];
+	if (wantz) {
+	    a[a_dim1 + 1] = 1.f;
+	}
+	return 0;
+    }
+
+/*     Get machine constants. */
+
+    safmin = slamch_("Safe minimum");
+    eps = slamch_("Precision");
+    smlnum = safmin / eps;
+    bignum = 1.f / smlnum;
+    rmin = sqrt(smlnum);
+    rmax = sqrt(bignum);
+
+/*     Scale matrix to allowable range, if necessary. */
+
+    anrm = slansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
+    iscale = 0;
+    if (anrm > 0.f && anrm < rmin) {
+	iscale = 1;
+	sigma = rmin / anrm;
+    } else if (anrm > rmax) {
+	iscale = 1;
+	sigma = rmax / anrm;
+    }
+    if (iscale == 1) {
+	slascl_(uplo, &c__0, &c__0, &c_b17, &sigma, n, n, &a[a_offset], lda, 
+		info);
+    }
+
+/*     Call SSYTRD to reduce symmetric matrix to tridiagonal form. */
+
+    inde = 1;
+    indtau = inde + *n;
+    indwrk = indtau + *n;
+    llwork = *lwork - indwrk + 1;
+    indwk2 = indwrk + *n * *n;
+    llwrk2 = *lwork - indwk2 + 1;
+
+    ssytrd_(uplo, n, &a[a_offset], lda, &w[1], &work[inde], &work[indtau], &
+	    work[indwrk], &llwork, &iinfo);
+
+/*     For eigenvalues only, call SSTERF.  For eigenvectors, first call */
+/*     SSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the */
+/*     tridiagonal matrix, then call SORMTR to multiply it by the */
+/*     Householder transformations stored in A. */
+
+    if (! wantz) {
+	ssterf_(n, &w[1], &work[inde], info);
+    } else {
+	sstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], &
+		llwrk2, &iwork[1], liwork, info);
+	sormtr_("L", uplo, "N", n, n, &a[a_offset], lda, &work[indtau], &work[
+		indwrk], n, &work[indwk2], &llwrk2, &iinfo);
+	slacpy_("A", n, n, &work[indwrk], n, &a[a_offset], lda);
+    }
+
+/*     If matrix was scaled, then rescale eigenvalues appropriately. */
+
+    if (iscale == 1) {
+	r__1 = 1.f / sigma;
+	sscal_(n, &r__1, &w[1], &c__1);
+    }
+
+    work[1] = (real) lopt;
+    iwork[1] = liopt;
+
+    return 0;
+
+/*     End of SSYEVD */
+
+} /* ssyevd_ */
+

lapack-netlib/SRC/ssyevd_2stage.c

@@ -0,0 +1,837 @@
+/* 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_n1 = -1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static integer c__0 = 0;
+static real c_b27 = 1.f;
+
+/* > \brief <b> SSYEVD_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for
+ SY matrices</b> */
+
+/*  @generated from dsyevd_2stage.f, fortran d -> s, Sat Nov  5 23:55:54 2016 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYEVD_2STAGE + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssyevd_
+2stage.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssyevd_
+2stage.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssyevd_
+2stage.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYEVD_2STAGE( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, */
+/*                                IWORK, LIWORK, INFO ) */
+
+/*       IMPLICIT NONE */
+
+/*       CHARACTER          JOBZ, UPLO */
+/*       INTEGER            INFO, LDA, LIWORK, LWORK, N */
+/*       INTEGER            IWORK( * ) */
+/*       REAL               A( LDA, * ), W( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYEVD_2STAGE computes all eigenvalues and, optionally, eigenvectors of a */
+/* > real symmetric matrix A using the 2stage technique for */
+/* > the reduction to tridiagonal. If eigenvectors are desired, it uses a */
+/* > divide and conquer algorithm. */
+/* > */
+/* > The divide and conquer algorithm makes very mild assumptions about */
+/* > floating point arithmetic. It will work on machines with a guard */
+/* > digit in add/subtract, or on those binary machines without guard */
+/* > digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* > Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* > without guard digits, but we know of none. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] JOBZ */
+/* > \verbatim */
+/* >          JOBZ is CHARACTER*1 */
+/* >          = 'N':  Compute eigenvalues only; */
+/* >          = 'V':  Compute eigenvalues and eigenvectors. */
+/* >                  Not available in this release. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \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 symmetric matrix A.  If UPLO = 'U', the */
+/* >          leading N-by-N upper triangular part of A contains the */
+/* >          upper triangular part of the matrix A.  If UPLO = 'L', */
+/* >          the leading N-by-N lower triangular part of A contains */
+/* >          the lower triangular part of the matrix A. */
+/* >          On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* >          orthonormal eigenvectors of the matrix A. */
+/* >          If JOBZ = 'N', then on exit the lower triangle (if UPLO='L') */
+/* >          or the upper triangle (if UPLO='U') of A, including the */
+/* >          diagonal, is destroyed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] W */
+/* > \verbatim */
+/* >          W is REAL array, dimension (N) */
+/* >          If INFO = 0, the eigenvalues in ascending order. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, */
+/* >                                         dimension (LWORK) */
+/* >          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The dimension of the array WORK. */
+/* >          If N <= 1,               LWORK must be at least 1. */
+/* >          If JOBZ = 'N' and N > 1, LWORK must be queried. */
+/* >                                   LWORK = MAX(1, dimension) where */
+/* >                                   dimension = f2cmax(stage1,stage2) + (KD+1)*N + 2*N+1 */
+/* >                                             = N*KD + N*f2cmax(KD+1,FACTOPTNB) */
+/* >                                               + f2cmax(2*KD*KD, KD*NTHREADS) */
+/* >                                               + (KD+1)*N + 2*N+1 */
+/* >                                   where KD is the blocking size of the reduction, */
+/* >                                   FACTOPTNB is the blocking used by the QR or LQ */
+/* >                                   algorithm, usually FACTOPTNB=128 is a good choice */
+/* >                                   NTHREADS is the number of threads used when */
+/* >                                   openMP compilation is enabled, otherwise =1. */
+/* >          If JOBZ = 'V' and N > 1, LWORK must be at least */
+/* >                                                1 + 6*N + 2*N**2. */
+/* > */
+/* >          If LWORK = -1, then a workspace query is assumed; the routine */
+/* >          only calculates the optimal sizes of the WORK and IWORK */
+/* >          arrays, returns these values as the first entries of the WORK */
+/* >          and IWORK arrays, and no error message related to LWORK or */
+/* >          LIWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */
+/* >          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LIWORK */
+/* > \verbatim */
+/* >          LIWORK is INTEGER */
+/* >          The dimension of the array IWORK. */
+/* >          If N <= 1,                LIWORK must be at least 1. */
+/* >          If JOBZ  = 'N' and N > 1, LIWORK must be at least 1. */
+/* >          If JOBZ  = 'V' and N > 1, LIWORK must be at least 3 + 5*N. */
+/* > */
+/* >          If LIWORK = -1, then a workspace query is assumed; the */
+/* >          routine only calculates the optimal sizes of the WORK and */
+/* >          IWORK arrays, returns these values as the first entries of */
+/* >          the WORK and IWORK arrays, and no error message related to */
+/* >          LWORK or LIWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0:  if INFO = i and JOBZ = 'N', then the algorithm failed */
+/* >                to converge; i off-diagonal elements of an intermediate */
+/* >                tridiagonal form did not converge to zero; */
+/* >                if INFO = i and JOBZ = 'V', then the algorithm failed */
+/* >                to compute an eigenvalue while working on the submatrix */
+/* >                lying in rows and columns INFO/(N+1) through */
+/* >                mod(INFO,N+1). */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date November 2017 */
+
+/* > \ingroup realSYeigen */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > */
+/* > Jeff Rutter, Computer Science Division, University of California */
+/* > at Berkeley, USA \n */
+/* >  Modified by Francoise Tisseur, University of Tennessee \n */
+/* >  Modified description of INFO. Sven, 16 Feb 05. \n */
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  All details about the 2stage techniques are available in: */
+/* > */
+/* >  Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */
+/* >  Parallel reduction to condensed forms for symmetric eigenvalue problems */
+/* >  using aggregated fine-grained and memory-aware kernels. In Proceedings */
+/* >  of 2011 International Conference for High Performance Computing, */
+/* >  Networking, Storage and Analysis (SC '11), New York, NY, USA, */
+/* >  Article 8 , 11 pages. */
+/* >  http://doi.acm.org/10.1145/2063384.2063394 */
+/* > */
+/* >  A. Haidar, J. Kurzak, P. Luszczek, 2013. */
+/* >  An improved parallel singular value algorithm and its implementation */
+/* >  for multicore hardware, In Proceedings of 2013 International Conference */
+/* >  for High Performance Computing, Networking, Storage and Analysis (SC '13). */
+/* >  Denver, Colorado, USA, 2013. */
+/* >  Article 90, 12 pages. */
+/* >  http://doi.acm.org/10.1145/2503210.2503292 */
+/* > */
+/* >  A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */
+/* >  A novel hybrid CPU-GPU generalized eigensolver for electronic structure */
+/* >  calculations based on fine-grained memory aware tasks. */
+/* >  International Journal of High Performance Computing Applications. */
+/* >  Volume 28 Issue 2, Pages 196-209, May 2014. */
+/* >  http://hpc.sagepub.com/content/28/2/196 */
+/* > */
+/* > \endverbatim */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssyevd_2stage_(char *jobz, char *uplo, integer *n, real 
+	*a, integer *lda, real *w, real *work, integer *lwork, integer *iwork,
+	 integer *liwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1;
+    real r__1;
+
+    /* Local variables */
+    integer inde;
+    extern integer ilaenv2stage_(integer *, char *, char *, integer *, 
+	    integer *, integer *, integer *);
+    real anrm, rmin, rmax, sigma;
+    extern logical lsame_(char *, char *);
+    integer iinfo;
+    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+    integer lhtrd, lwmin;
+    logical lower;
+    integer lwtrd;
+    extern /* Subroutine */ int ssytrd_2stage_(char *, char *, integer *, 
+	    real *, integer *, real *, real *, real *, real *, integer *, 
+	    real *, integer *, integer *);
+    logical wantz;
+    integer indwk2, ib, llwrk2, kd, iscale;
+    extern real slamch_(char *);
+    real safmin;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    real bignum;
+    extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, 
+	    real *, integer *, integer *, real *, integer *, integer *);
+    integer indtau;
+    extern /* Subroutine */ int sstedc_(char *, integer *, real *, real *, 
+	    real *, integer *, real *, integer *, integer *, integer *, 
+	    integer *), slacpy_(char *, integer *, integer *, real *, 
+	    integer *, real *, integer *);
+    integer indwrk, liwmin;
+    extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
+    extern real slansy_(char *, char *, integer *, real *, integer *, real *);
+    integer llwork;
+    real smlnum;
+    logical lquery;
+    extern /* Subroutine */ int sormtr_(char *, char *, char *, integer *, 
+	    integer *, real *, integer *, real *, real *, integer *, real *, 
+	    integer *, integer *);
+    real eps;
+    integer indhous;
+
+
+
+/*  -- LAPACK driver 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 */
+
+
+/*  ===================================================================== */
+
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --w;
+    --work;
+    --iwork;
+
+    /* Function Body */
+    wantz = lsame_(jobz, "V");
+    lower = lsame_(uplo, "L");
+    lquery = *lwork == -1 || *liwork == -1;
+
+    *info = 0;
+    if (! lsame_(jobz, "N")) {
+	*info = -1;
+    } else if (! (lower || lsame_(uplo, "U"))) {
+	*info = -2;
+    } else if (*n < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    }
+
+    if (*info == 0) {
+	if (*n <= 1) {
+	    liwmin = 1;
+	    lwmin = 1;
+	} else {
+	    kd = ilaenv2stage_(&c__1, "SSYTRD_2STAGE", jobz, n, &c_n1, &c_n1, 
+		    &c_n1);
+	    ib = ilaenv2stage_(&c__2, "SSYTRD_2STAGE", jobz, n, &kd, &c_n1, &
+		    c_n1);
+	    lhtrd = ilaenv2stage_(&c__3, "SSYTRD_2STAGE", jobz, n, &kd, &ib, &
+		    c_n1);
+	    lwtrd = ilaenv2stage_(&c__4, "SSYTRD_2STAGE", jobz, n, &kd, &ib, &
+		    c_n1);
+	    if (wantz) {
+		liwmin = *n * 5 + 3;
+/* Computing 2nd power */
+		i__1 = *n;
+		lwmin = *n * 6 + 1 + (i__1 * i__1 << 1);
+	    } else {
+		liwmin = 1;
+		lwmin = (*n << 1) + 1 + lhtrd + lwtrd;
+	    }
+	}
+	work[1] = (real) lwmin;
+	iwork[1] = liwmin;
+
+	if (*lwork < lwmin && ! lquery) {
+	    *info = -8;
+	} else if (*liwork < liwmin && ! lquery) {
+	    *info = -10;
+	}
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYEVD_2STAGE", &i__1, (ftnlen)13);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+    if (*n == 1) {
+	w[1] = a[a_dim1 + 1];
+	if (wantz) {
+	    a[a_dim1 + 1] = 1.f;
+	}
+	return 0;
+    }
+
+/*     Get machine constants. */
+
+    safmin = slamch_("Safe minimum");
+    eps = slamch_("Precision");
+    smlnum = safmin / eps;
+    bignum = 1.f / smlnum;
+    rmin = sqrt(smlnum);
+    rmax = sqrt(bignum);
+
+/*     Scale matrix to allowable range, if necessary. */
+
+    anrm = slansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
+    iscale = 0;
+    if (anrm > 0.f && anrm < rmin) {
+	iscale = 1;
+	sigma = rmin / anrm;
+    } else if (anrm > rmax) {
+	iscale = 1;
+	sigma = rmax / anrm;
+    }
+    if (iscale == 1) {
+	slascl_(uplo, &c__0, &c__0, &c_b27, &sigma, n, n, &a[a_offset], lda, 
+		info);
+    }
+
+/*     Call SSYTRD_2STAGE to reduce symmetric matrix to tridiagonal form. */
+
+    inde = 1;
+    indtau = inde + *n;
+    indhous = indtau + *n;
+    indwrk = indhous + lhtrd;
+    llwork = *lwork - indwrk + 1;
+    indwk2 = indwrk + *n * *n;
+    llwrk2 = *lwork - indwk2 + 1;
+
+    ssytrd_2stage_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[inde], &
+	    work[indtau], &work[indhous], &lhtrd, &work[indwrk], &llwork, &
+	    iinfo);
+
+/*     For eigenvalues only, call SSTERF.  For eigenvectors, first call */
+/*     SSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the */
+/*     tridiagonal matrix, then call SORMTR to multiply it by the */
+/*     Householder transformations stored in A. */
+
+    if (! wantz) {
+	ssterf_(n, &w[1], &work[inde], info);
+    } else {
+/*        Not available in this release, and argument checking should not */
+/*        let it getting here */
+	return 0;
+	sstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], &
+		llwrk2, &iwork[1], liwork, info);
+	sormtr_("L", uplo, "N", n, n, &a[a_offset], lda, &work[indtau], &work[
+		indwrk], n, &work[indwk2], &llwrk2, &iinfo);
+	slacpy_("A", n, n, &work[indwrk], n, &a[a_offset], lda);
+    }
+
+/*     If matrix was scaled, then rescale eigenvalues appropriately. */
+
+    if (iscale == 1) {
+	r__1 = 1.f / sigma;
+	sscal_(n, &r__1, &w[1], &c__1);
+    }
+
+    work[1] = (real) lwmin;
+    iwork[1] = liwmin;
+
+    return 0;
+
+/*     End of SSYEVD_2STAGE */
+
+} /* ssyevd_2stage__ */
+

lapack-netlib/SRC/ssygs2.c

@@ -0,0 +1,729 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define 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_b6 = -1.f;
+static integer c__1 = 1;
+static real c_b27 = 1.f;
+
+/* > \brief \b SSYGS2 reduces a symmetric definite generalized eigenproblem to standard form, using the factor
+ization results obtained from spotrf (unblocked algorithm). */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYGS2 + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssygs2.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssygs2.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssygs2.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, ITYPE, LDA, LDB, N */
+/*       REAL               A( LDA, * ), B( LDB, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYGS2 reduces a real symmetric-definite generalized eigenproblem */
+/* > to standard form. */
+/* > */
+/* > If ITYPE = 1, the problem is A*x = lambda*B*x, */
+/* > and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) */
+/* > */
+/* > If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
+/* > B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T *A*L. */
+/* > */
+/* > B must have been previously factorized as U**T *U or L*L**T by SPOTRF. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] ITYPE */
+/* > \verbatim */
+/* >          ITYPE is INTEGER */
+/* >          = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); */
+/* >          = 2 or 3: compute U*A*U**T or L**T *A*L. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the upper or lower triangular part of the */
+/* >          symmetric matrix A is stored, and how B has been factorized. */
+/* >          = 'U':  Upper triangular */
+/* >          = 'L':  Lower triangular */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrices A and B.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          On entry, the symmetric matrix A.  If UPLO = 'U', the leading */
+/* >          n by n upper triangular part of A contains the upper */
+/* >          triangular part of the matrix A, and the strictly lower */
+/* >          triangular part of A is not referenced.  If UPLO = 'L', the */
+/* >          leading n by n lower triangular part of A contains the lower */
+/* >          triangular part of the matrix A, and the strictly upper */
+/* >          triangular part of A is not referenced. */
+/* > */
+/* >          On exit, if INFO = 0, the transformed matrix, stored in the */
+/* >          same format as A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB,N) */
+/* >          The triangular factor from the Cholesky factorization of B, */
+/* >          as returned by SPOTRF. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit. */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realSYcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssygs2_(integer *itype, char *uplo, integer *n, real *a, 
+	integer *lda, real *b, integer *ldb, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+    real r__1;
+
+    /* Local variables */
+    integer k;
+    extern /* Subroutine */ int ssyr2_(char *, integer *, real *, real *, 
+	    integer *, real *, integer *, real *, integer *);
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+    logical upper;
+    extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, 
+	    real *, integer *), strmv_(char *, char *, char *, integer *, 
+	    real *, integer *, real *, integer *), 
+	    strsv_(char *, char *, char *, integer *, real *, integer *, real 
+	    *, integer *);
+    real ct;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    real akk, bkk;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    if (*itype < 1 || *itype > 3) {
+	*info = -1;
+    } else if (! upper && ! lsame_(uplo, "L")) {
+	*info = -2;
+    } else if (*n < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -7;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYGS2", &i__1, (ftnlen)6);
+	return 0;
+    }
+
+    if (*itype == 1) {
+	if (upper) {
+
+/*           Compute inv(U**T)*A*inv(U) */
+
+	    i__1 = *n;
+	    for (k = 1; k <= i__1; ++k) {
+
+/*              Update the upper triangle of A(k:n,k:n) */
+
+		akk = a[k + k * a_dim1];
+		bkk = b[k + k * b_dim1];
+/* Computing 2nd power */
+		r__1 = bkk;
+		akk /= r__1 * r__1;
+		a[k + k * a_dim1] = akk;
+		if (k < *n) {
+		    i__2 = *n - k;
+		    r__1 = 1.f / bkk;
+		    sscal_(&i__2, &r__1, &a[k + (k + 1) * a_dim1], lda);
+		    ct = akk * -.5f;
+		    i__2 = *n - k;
+		    saxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
+			    k + 1) * a_dim1], lda);
+		    i__2 = *n - k;
+		    ssyr2_(uplo, &i__2, &c_b6, &a[k + (k + 1) * a_dim1], lda, 
+			    &b[k + (k + 1) * b_dim1], ldb, &a[k + 1 + (k + 1) 
+			    * a_dim1], lda);
+		    i__2 = *n - k;
+		    saxpy_(&i__2, &ct, &b[k + (k + 1) * b_dim1], ldb, &a[k + (
+			    k + 1) * a_dim1], lda);
+		    i__2 = *n - k;
+		    strsv_(uplo, "Transpose", "Non-unit", &i__2, &b[k + 1 + (
+			    k + 1) * b_dim1], ldb, &a[k + (k + 1) * a_dim1], 
+			    lda);
+		}
+/* L10: */
+	    }
+	} else {
+
+/*           Compute inv(L)*A*inv(L**T) */
+
+	    i__1 = *n;
+	    for (k = 1; k <= i__1; ++k) {
+
+/*              Update the lower triangle of A(k:n,k:n) */
+
+		akk = a[k + k * a_dim1];
+		bkk = b[k + k * b_dim1];
+/* Computing 2nd power */
+		r__1 = bkk;
+		akk /= r__1 * r__1;
+		a[k + k * a_dim1] = akk;
+		if (k < *n) {
+		    i__2 = *n - k;
+		    r__1 = 1.f / bkk;
+		    sscal_(&i__2, &r__1, &a[k + 1 + k * a_dim1], &c__1);
+		    ct = akk * -.5f;
+		    i__2 = *n - k;
+		    saxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k + 
+			    1 + k * a_dim1], &c__1);
+		    i__2 = *n - k;
+		    ssyr2_(uplo, &i__2, &c_b6, &a[k + 1 + k * a_dim1], &c__1, 
+			    &b[k + 1 + k * b_dim1], &c__1, &a[k + 1 + (k + 1) 
+			    * a_dim1], lda);
+		    i__2 = *n - k;
+		    saxpy_(&i__2, &ct, &b[k + 1 + k * b_dim1], &c__1, &a[k + 
+			    1 + k * a_dim1], &c__1);
+		    i__2 = *n - k;
+		    strsv_(uplo, "No transpose", "Non-unit", &i__2, &b[k + 1 
+			    + (k + 1) * b_dim1], ldb, &a[k + 1 + k * a_dim1], 
+			    &c__1);
+		}
+/* L20: */
+	    }
+	}
+    } else {
+	if (upper) {
+
+/*           Compute U*A*U**T */
+
+	    i__1 = *n;
+	    for (k = 1; k <= i__1; ++k) {
+
+/*              Update the upper triangle of A(1:k,1:k) */
+
+		akk = a[k + k * a_dim1];
+		bkk = b[k + k * b_dim1];
+		i__2 = k - 1;
+		strmv_(uplo, "No transpose", "Non-unit", &i__2, &b[b_offset], 
+			ldb, &a[k * a_dim1 + 1], &c__1);
+		ct = akk * .5f;
+		i__2 = k - 1;
+		saxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 + 
+			1], &c__1);
+		i__2 = k - 1;
+		ssyr2_(uplo, &i__2, &c_b27, &a[k * a_dim1 + 1], &c__1, &b[k * 
+			b_dim1 + 1], &c__1, &a[a_offset], lda);
+		i__2 = k - 1;
+		saxpy_(&i__2, &ct, &b[k * b_dim1 + 1], &c__1, &a[k * a_dim1 + 
+			1], &c__1);
+		i__2 = k - 1;
+		sscal_(&i__2, &bkk, &a[k * a_dim1 + 1], &c__1);
+/* Computing 2nd power */
+		r__1 = bkk;
+		a[k + k * a_dim1] = akk * (r__1 * r__1);
+/* L30: */
+	    }
+	} else {
+
+/*           Compute L**T *A*L */
+
+	    i__1 = *n;
+	    for (k = 1; k <= i__1; ++k) {
+
+/*              Update the lower triangle of A(1:k,1:k) */
+
+		akk = a[k + k * a_dim1];
+		bkk = b[k + k * b_dim1];
+		i__2 = k - 1;
+		strmv_(uplo, "Transpose", "Non-unit", &i__2, &b[b_offset], 
+			ldb, &a[k + a_dim1], lda);
+		ct = akk * .5f;
+		i__2 = k - 1;
+		saxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
+		i__2 = k - 1;
+		ssyr2_(uplo, &i__2, &c_b27, &a[k + a_dim1], lda, &b[k + 
+			b_dim1], ldb, &a[a_offset], lda);
+		i__2 = k - 1;
+		saxpy_(&i__2, &ct, &b[k + b_dim1], ldb, &a[k + a_dim1], lda);
+		i__2 = k - 1;
+		sscal_(&i__2, &bkk, &a[k + a_dim1], lda);
+/* Computing 2nd power */
+		r__1 = bkk;
+		a[k + k * a_dim1] = akk * (r__1 * r__1);
+/* L40: */
+	    }
+	}
+    }
+    return 0;
+
+/*     End of SSYGS2 */
+
+} /* ssygs2_ */
+

lapack-netlib/SRC/ssygst.c

@@ -0,0 +1,775 @@
+/* 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_n1 = -1;
+static real c_b14 = 1.f;
+static real c_b16 = -.5f;
+static real c_b19 = -1.f;
+static real c_b52 = .5f;
+
+/* > \brief \b SSYGST */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYGST + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssygst.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssygst.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssygst.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, ITYPE, LDA, LDB, N */
+/*       REAL               A( LDA, * ), B( LDB, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYGST reduces a real symmetric-definite generalized eigenproblem */
+/* > to standard form. */
+/* > */
+/* > If ITYPE = 1, the problem is A*x = lambda*B*x, */
+/* > and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T) */
+/* > */
+/* > If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */
+/* > B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L. */
+/* > */
+/* > B must have been previously factorized as U**T*U or L*L**T by SPOTRF. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] ITYPE */
+/* > \verbatim */
+/* >          ITYPE is INTEGER */
+/* >          = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T); */
+/* >          = 2 or 3: compute U*A*U**T or L**T*A*L. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored and B is factored as */
+/* >                  U**T*U; */
+/* >          = 'L':  Lower triangle of A is stored and B is factored as */
+/* >                  L*L**T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrices A and B.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          On entry, the symmetric matrix A.  If UPLO = 'U', the leading */
+/* >          N-by-N upper triangular part of A contains the upper */
+/* >          triangular part of the matrix A, and the strictly lower */
+/* >          triangular part of A is not referenced.  If UPLO = 'L', the */
+/* >          leading N-by-N lower triangular part of A contains the lower */
+/* >          triangular part of the matrix A, and the strictly upper */
+/* >          triangular part of A is not referenced. */
+/* > */
+/* >          On exit, if INFO = 0, the transformed matrix, stored in the */
+/* >          same format as A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB,N) */
+/* >          The triangular factor from the Cholesky factorization of B, */
+/* >          as returned by SPOTRF. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realSYcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssygst_(integer *itype, char *uplo, integer *n, real *a, 
+	integer *lda, real *b, integer *ldb, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+
+    /* Local variables */
+    integer k;
+    extern logical lsame_(char *, char *);
+    logical upper;
+    extern /* Subroutine */ int strmm_(char *, char *, char *, char *, 
+	    integer *, integer *, real *, real *, integer *, real *, integer *
+	    ), ssymm_(char *, char *, integer 
+	    *, integer *, real *, real *, integer *, real *, integer *, real *
+	    , real *, integer *), strsm_(char *, char *, char 
+	    *, char *, integer *, integer *, real *, real *, integer *, real *
+	    , integer *);
+    integer kb, nb;
+    extern /* Subroutine */ int ssygs2_(integer *, char *, integer *, real *, 
+	    integer *, real *, integer *, integer *), ssyr2k_(char *, 
+	    char *, integer *, integer *, real *, real *, integer *, real *, 
+	    integer *, real *, real *, integer *), xerbla_( char *, integer *, ftnlen);
+    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
+	    integer *, integer *, ftnlen, ftnlen);
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    if (*itype < 1 || *itype > 3) {
+	*info = -1;
+    } else if (! upper && ! lsame_(uplo, "L")) {
+	*info = -2;
+    } else if (*n < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -7;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYGST", &i__1, (ftnlen)6);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+/*     Determine the block size for this environment. */
+
+    nb = ilaenv_(&c__1, "SSYGST", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (
+	    ftnlen)1);
+
+    if (nb <= 1 || nb >= *n) {
+
+/*        Use unblocked code */
+
+	ssygs2_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
+    } else {
+
+/*        Use blocked code */
+
+	if (*itype == 1) {
+	    if (upper) {
+
+/*              Compute inv(U**T)*A*inv(U) */
+
+		i__1 = *n;
+		i__2 = nb;
+		for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+/* Computing MIN */
+		    i__3 = *n - k + 1;
+		    kb = f2cmin(i__3,nb);
+
+/*                 Update the upper triangle of A(k:n,k:n) */
+
+		    ssygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + 
+			    k * b_dim1], ldb, info);
+		    if (k + kb <= *n) {
+			i__3 = *n - k - kb + 1;
+			strsm_("Left", uplo, "Transpose", "Non-unit", &kb, &
+				i__3, &c_b14, &b[k + k * b_dim1], ldb, &a[k + 
+				(k + kb) * a_dim1], lda);
+			i__3 = *n - k - kb + 1;
+			ssymm_("Left", uplo, &kb, &i__3, &c_b16, &a[k + k * 
+				a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb, 
+				&c_b14, &a[k + (k + kb) * a_dim1], lda);
+			i__3 = *n - k - kb + 1;
+			ssyr2k_(uplo, "Transpose", &i__3, &kb, &c_b19, &a[k + 
+				(k + kb) * a_dim1], lda, &b[k + (k + kb) * 
+				b_dim1], ldb, &c_b14, &a[k + kb + (k + kb) * 
+				a_dim1], lda);
+			i__3 = *n - k - kb + 1;
+			ssymm_("Left", uplo, &kb, &i__3, &c_b16, &a[k + k * 
+				a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb, 
+				&c_b14, &a[k + (k + kb) * a_dim1], lda);
+			i__3 = *n - k - kb + 1;
+			strsm_("Right", uplo, "No transpose", "Non-unit", &kb,
+				 &i__3, &c_b14, &b[k + kb + (k + kb) * b_dim1]
+				, ldb, &a[k + (k + kb) * a_dim1], lda);
+		    }
+/* L10: */
+		}
+	    } else {
+
+/*              Compute inv(L)*A*inv(L**T) */
+
+		i__2 = *n;
+		i__1 = nb;
+		for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+/* Computing MIN */
+		    i__3 = *n - k + 1;
+		    kb = f2cmin(i__3,nb);
+
+/*                 Update the lower triangle of A(k:n,k:n) */
+
+		    ssygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + 
+			    k * b_dim1], ldb, info);
+		    if (k + kb <= *n) {
+			i__3 = *n - k - kb + 1;
+			strsm_("Right", uplo, "Transpose", "Non-unit", &i__3, 
+				&kb, &c_b14, &b[k + k * b_dim1], ldb, &a[k + 
+				kb + k * a_dim1], lda);
+			i__3 = *n - k - kb + 1;
+			ssymm_("Right", uplo, &i__3, &kb, &c_b16, &a[k + k * 
+				a_dim1], lda, &b[k + kb + k * b_dim1], ldb, &
+				c_b14, &a[k + kb + k * a_dim1], lda);
+			i__3 = *n - k - kb + 1;
+			ssyr2k_(uplo, "No transpose", &i__3, &kb, &c_b19, &a[
+				k + kb + k * a_dim1], lda, &b[k + kb + k * 
+				b_dim1], ldb, &c_b14, &a[k + kb + (k + kb) * 
+				a_dim1], lda);
+			i__3 = *n - k - kb + 1;
+			ssymm_("Right", uplo, &i__3, &kb, &c_b16, &a[k + k * 
+				a_dim1], lda, &b[k + kb + k * b_dim1], ldb, &
+				c_b14, &a[k + kb + k * a_dim1], lda);
+			i__3 = *n - k - kb + 1;
+			strsm_("Left", uplo, "No transpose", "Non-unit", &
+				i__3, &kb, &c_b14, &b[k + kb + (k + kb) * 
+				b_dim1], ldb, &a[k + kb + k * a_dim1], lda);
+		    }
+/* L20: */
+		}
+	    }
+	} else {
+	    if (upper) {
+
+/*              Compute U*A*U**T */
+
+		i__1 = *n;
+		i__2 = nb;
+		for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) {
+/* Computing MIN */
+		    i__3 = *n - k + 1;
+		    kb = f2cmin(i__3,nb);
+
+/*                 Update the upper triangle of A(1:k+kb-1,1:k+kb-1) */
+
+		    i__3 = k - 1;
+		    strmm_("Left", uplo, "No transpose", "Non-unit", &i__3, &
+			    kb, &c_b14, &b[b_offset], ldb, &a[k * a_dim1 + 1],
+			     lda)
+			    ;
+		    i__3 = k - 1;
+		    ssymm_("Right", uplo, &i__3, &kb, &c_b52, &a[k + k * 
+			    a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, &a[
+			    k * a_dim1 + 1], lda);
+		    i__3 = k - 1;
+		    ssyr2k_(uplo, "No transpose", &i__3, &kb, &c_b14, &a[k * 
+			    a_dim1 + 1], lda, &b[k * b_dim1 + 1], ldb, &c_b14,
+			     &a[a_offset], lda);
+		    i__3 = k - 1;
+		    ssymm_("Right", uplo, &i__3, &kb, &c_b52, &a[k + k * 
+			    a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b14, &a[
+			    k * a_dim1 + 1], lda);
+		    i__3 = k - 1;
+		    strmm_("Right", uplo, "Transpose", "Non-unit", &i__3, &kb,
+			     &c_b14, &b[k + k * b_dim1], ldb, &a[k * a_dim1 + 
+			    1], lda);
+		    ssygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + 
+			    k * b_dim1], ldb, info);
+/* L30: */
+		}
+	    } else {
+
+/*              Compute L**T*A*L */
+
+		i__2 = *n;
+		i__1 = nb;
+		for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) {
+/* Computing MIN */
+		    i__3 = *n - k + 1;
+		    kb = f2cmin(i__3,nb);
+
+/*                 Update the lower triangle of A(1:k+kb-1,1:k+kb-1) */
+
+		    i__3 = k - 1;
+		    strmm_("Right", uplo, "No transpose", "Non-unit", &kb, &
+			    i__3, &c_b14, &b[b_offset], ldb, &a[k + a_dim1], 
+			    lda);
+		    i__3 = k - 1;
+		    ssymm_("Left", uplo, &kb, &i__3, &c_b52, &a[k + k * 
+			    a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[k + 
+			    a_dim1], lda);
+		    i__3 = k - 1;
+		    ssyr2k_(uplo, "Transpose", &i__3, &kb, &c_b14, &a[k + 
+			    a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[
+			    a_offset], lda);
+		    i__3 = k - 1;
+		    ssymm_("Left", uplo, &kb, &i__3, &c_b52, &a[k + k * 
+			    a_dim1], lda, &b[k + b_dim1], ldb, &c_b14, &a[k + 
+			    a_dim1], lda);
+		    i__3 = k - 1;
+		    strmm_("Left", uplo, "Transpose", "Non-unit", &kb, &i__3, 
+			    &c_b14, &b[k + k * b_dim1], ldb, &a[k + a_dim1], 
+			    lda);
+		    ssygs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + 
+			    k * b_dim1], ldb, info);
+/* L40: */
+		}
+	    }
+	}
+    }
+    return 0;
+
+/*     End of SSYGST */
+
+} /* ssygst_ */
+

lapack-netlib/SRC/ssygv.c

@@ -0,0 +1,729 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define 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_n1 = -1;
+static real c_b16 = 1.f;
+
+/* > \brief \b SSYGV */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYGV + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssygv.f
+"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssygv.f
+"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssygv.f
+"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, */
+/*                         LWORK, INFO ) */
+
+/*       CHARACTER          JOBZ, UPLO */
+/*       INTEGER            INFO, ITYPE, LDA, LDB, LWORK, N */
+/*       REAL               A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYGV computes all the eigenvalues, and optionally, the eigenvectors */
+/* > of a real generalized symmetric-definite eigenproblem, of the form */
+/* > A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x. */
+/* > Here A and B are assumed to be symmetric and B is also */
+/* > positive definite. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] ITYPE */
+/* > \verbatim */
+/* >          ITYPE is INTEGER */
+/* >          Specifies the problem type to be solved: */
+/* >          = 1:  A*x = (lambda)*B*x */
+/* >          = 2:  A*B*x = (lambda)*x */
+/* >          = 3:  B*A*x = (lambda)*x */
+/* > \endverbatim */
+/* > */
+/* > \param[in] JOBZ */
+/* > \verbatim */
+/* >          JOBZ is CHARACTER*1 */
+/* >          = 'N':  Compute eigenvalues only; */
+/* >          = 'V':  Compute eigenvalues and eigenvectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangles of A and B are stored; */
+/* >          = 'L':  Lower triangles of A and B are stored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrices A and B.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA, N) */
+/* >          On entry, the symmetric matrix A.  If UPLO = 'U', the */
+/* >          leading N-by-N upper triangular part of A contains the */
+/* >          upper triangular part of the matrix A.  If UPLO = 'L', */
+/* >          the leading N-by-N lower triangular part of A contains */
+/* >          the lower triangular part of the matrix A. */
+/* > */
+/* >          On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* >          matrix Z of eigenvectors.  The eigenvectors are normalized */
+/* >          as follows: */
+/* >          if ITYPE = 1 or 2, Z**T*B*Z = I; */
+/* >          if ITYPE = 3, Z**T*inv(B)*Z = I. */
+/* >          If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */
+/* >          or the lower triangle (if UPLO='L') of A, including the */
+/* >          diagonal, is destroyed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB, N) */
+/* >          On entry, the symmetric positive definite matrix B. */
+/* >          If UPLO = 'U', the leading N-by-N upper triangular part of B */
+/* >          contains the upper triangular part of the matrix B. */
+/* >          If UPLO = 'L', the leading N-by-N lower triangular part of B */
+/* >          contains the lower triangular part of the matrix B. */
+/* > */
+/* >          On exit, if INFO <= N, the part of B containing the matrix is */
+/* >          overwritten by the triangular factor U or L from the Cholesky */
+/* >          factorization B = U**T*U or B = L*L**T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] W */
+/* > \verbatim */
+/* >          W is REAL array, dimension (N) */
+/* >          If INFO = 0, the eigenvalues in ascending order. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (MAX(1,LWORK)) */
+/* >          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The length of the array WORK.  LWORK >= f2cmax(1,3*N-1). */
+/* >          For optimal efficiency, LWORK >= (NB+2)*N, */
+/* >          where NB is the blocksize for SSYTRD returned by ILAENV. */
+/* > */
+/* >          If LWORK = -1, then a workspace query is assumed; the routine */
+/* >          only calculates the optimal size of the WORK array, returns */
+/* >          this value as the first entry of the WORK array, and no error */
+/* >          message related to LWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0:  SPOTRF or SSYEV returned an error code: */
+/* >             <= N:  if INFO = i, SSYEV failed to converge; */
+/* >                    i off-diagonal elements of an intermediate */
+/* >                    tridiagonal form did not converge to zero; */
+/* >             > N:   if INFO = N + i, for 1 <= i <= N, then the leading */
+/* >                    minor of order i of B is not positive definite. */
+/* >                    The factorization of B could not be completed and */
+/* >                    no eigenvalues or eigenvectors were computed. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realSYeigen */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssygv_(integer *itype, char *jobz, char *uplo, integer *
+	n, real *a, integer *lda, real *b, integer *ldb, real *w, real *work, 
+	integer *lwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+
+    /* Local variables */
+    integer neig;
+    extern logical lsame_(char *, char *);
+    char trans[1];
+    logical upper;
+    extern /* Subroutine */ int strmm_(char *, char *, char *, char *, 
+	    integer *, integer *, real *, real *, integer *, real *, integer *
+	    );
+    logical wantz;
+    extern /* Subroutine */ int strsm_(char *, char *, char *, char *, 
+	    integer *, integer *, real *, real *, integer *, real *, integer *
+	    ), ssyev_(char *, char *, integer 
+	    *, real *, integer *, real *, real *, integer *, integer *);
+    integer nb;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
+	    integer *, integer *, ftnlen, ftnlen);
+    integer lwkmin;
+    extern /* Subroutine */ int spotrf_(char *, integer *, real *, integer *, 
+	    integer *);
+    integer lwkopt;
+    logical lquery;
+    extern /* Subroutine */ int ssygst_(integer *, char *, integer *, real *, 
+	    integer *, real *, integer *, integer *);
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    --w;
+    --work;
+
+    /* Function Body */
+    wantz = lsame_(jobz, "V");
+    upper = lsame_(uplo, "U");
+    lquery = *lwork == -1;
+
+    *info = 0;
+    if (*itype < 1 || *itype > 3) {
+	*info = -1;
+    } else if (! (wantz || lsame_(jobz, "N"))) {
+	*info = -2;
+    } else if (! (upper || lsame_(uplo, "L"))) {
+	*info = -3;
+    } else if (*n < 0) {
+	*info = -4;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -6;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -8;
+    }
+
+    if (*info == 0) {
+/* Computing MAX */
+	i__1 = 1, i__2 = *n * 3 - 1;
+	lwkmin = f2cmax(i__1,i__2);
+	nb = ilaenv_(&c__1, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
+		 (ftnlen)1);
+/* Computing MAX */
+	i__1 = lwkmin, i__2 = (nb + 2) * *n;
+	lwkopt = f2cmax(i__1,i__2);
+	work[1] = (real) lwkopt;
+
+	if (*lwork < lwkmin && ! lquery) {
+	    *info = -11;
+	}
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYGV ", &i__1, (ftnlen)6);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+/*     Form a Cholesky factorization of B. */
+
+    spotrf_(uplo, n, &b[b_offset], ldb, info);
+    if (*info != 0) {
+	*info = *n + *info;
+	return 0;
+    }
+
+/*     Transform problem to standard eigenvalue problem and solve. */
+
+    ssygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
+    ssyev_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, info);
+
+    if (wantz) {
+
+/*        Backtransform eigenvectors to the original problem. */
+
+	neig = *n;
+	if (*info > 0) {
+	    neig = *info - 1;
+	}
+	if (*itype == 1 || *itype == 2) {
+
+/*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/*           backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y */
+
+	    if (upper) {
+		*(unsigned char *)trans = 'N';
+	    } else {
+		*(unsigned char *)trans = 'T';
+	    }
+
+	    strsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b16, &b[
+		    b_offset], ldb, &a[a_offset], lda);
+
+	} else if (*itype == 3) {
+
+/*           For B*A*x=(lambda)*x; */
+/*           backtransform eigenvectors: x = L*y or U**T*y */
+
+	    if (upper) {
+		*(unsigned char *)trans = 'T';
+	    } else {
+		*(unsigned char *)trans = 'N';
+	    }
+
+	    strmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b16, &b[
+		    b_offset], ldb, &a[a_offset], lda);
+	}
+    }
+
+    work[1] = (real) lwkopt;
+    return 0;
+
+/*     End of SSYGV */
+
+} /* ssygv_ */
+

lapack-netlib/SRC/ssygv_2stage.c

@@ -0,0 +1,785 @@
+/* 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_n1 = -1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static real c_b26 = 1.f;
+
+/* > \brief \b SSYGV_2STAGE */
+
+/*  @generated from dsygv_2stage.f, fortran d -> s, Sun Nov  6 12:54:29 2016 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYGV_2STAGE + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssygv_2
+stage.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssygv_2
+stage.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssygv_2
+stage.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYGV_2STAGE( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, */
+/*                                WORK, LWORK, INFO ) */
+
+/*       IMPLICIT NONE */
+
+/*       CHARACTER          JOBZ, UPLO */
+/*       INTEGER            INFO, ITYPE, LDA, LDB, LWORK, N */
+/*       REAL               A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYGV_2STAGE computes all the eigenvalues, and optionally, the eigenvectors */
+/* > of a real generalized symmetric-definite eigenproblem, of the form */
+/* > A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x. */
+/* > Here A and B are assumed to be symmetric and B is also */
+/* > positive definite. */
+/* > This routine use the 2stage technique for the reduction to tridiagonal */
+/* > which showed higher performance on recent architecture and for large */
+/* > sizes N>2000. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] ITYPE */
+/* > \verbatim */
+/* >          ITYPE is INTEGER */
+/* >          Specifies the problem type to be solved: */
+/* >          = 1:  A*x = (lambda)*B*x */
+/* >          = 2:  A*B*x = (lambda)*x */
+/* >          = 3:  B*A*x = (lambda)*x */
+/* > \endverbatim */
+/* > */
+/* > \param[in] JOBZ */
+/* > \verbatim */
+/* >          JOBZ is CHARACTER*1 */
+/* >          = 'N':  Compute eigenvalues only; */
+/* >          = 'V':  Compute eigenvalues and eigenvectors. */
+/* >                  Not available in this release. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangles of A and B are stored; */
+/* >          = 'L':  Lower triangles of A and B are stored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrices A and B.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA, N) */
+/* >          On entry, the symmetric matrix A.  If UPLO = 'U', the */
+/* >          leading N-by-N upper triangular part of A contains the */
+/* >          upper triangular part of the matrix A.  If UPLO = 'L', */
+/* >          the leading N-by-N lower triangular part of A contains */
+/* >          the lower triangular part of the matrix A. */
+/* > */
+/* >          On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* >          matrix Z of eigenvectors.  The eigenvectors are normalized */
+/* >          as follows: */
+/* >          if ITYPE = 1 or 2, Z**T*B*Z = I; */
+/* >          if ITYPE = 3, Z**T*inv(B)*Z = I. */
+/* >          If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */
+/* >          or the lower triangle (if UPLO='L') of A, including the */
+/* >          diagonal, is destroyed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB, N) */
+/* >          On entry, the symmetric positive definite matrix B. */
+/* >          If UPLO = 'U', the leading N-by-N upper triangular part of B */
+/* >          contains the upper triangular part of the matrix B. */
+/* >          If UPLO = 'L', the leading N-by-N lower triangular part of B */
+/* >          contains the lower triangular part of the matrix B. */
+/* > */
+/* >          On exit, if INFO <= N, the part of B containing the matrix is */
+/* >          overwritten by the triangular factor U or L from the Cholesky */
+/* >          factorization B = U**T*U or B = L*L**T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] W */
+/* > \verbatim */
+/* >          W is REAL array, dimension (N) */
+/* >          If INFO = 0, the eigenvalues in ascending order. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (MAX(1,LWORK)) */
+/* >          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The length of the array WORK. LWORK >= 1, when N <= 1; */
+/* >          otherwise */
+/* >          If JOBZ = 'N' and N > 1, LWORK must be queried. */
+/* >                                   LWORK = MAX(1, dimension) where */
+/* >                                   dimension = f2cmax(stage1,stage2) + (KD+1)*N + 2*N */
+/* >                                             = N*KD + N*f2cmax(KD+1,FACTOPTNB) */
+/* >                                               + f2cmax(2*KD*KD, KD*NTHREADS) */
+/* >                                               + (KD+1)*N + 2*N */
+/* >                                   where KD is the blocking size of the reduction, */
+/* >                                   FACTOPTNB is the blocking used by the QR or LQ */
+/* >                                   algorithm, usually FACTOPTNB=128 is a good choice */
+/* >                                   NTHREADS is the number of threads used when */
+/* >                                   openMP compilation is enabled, otherwise =1. */
+/* >          If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available */
+/* > */
+/* >          If LWORK = -1, then a workspace query is assumed; the routine */
+/* >          only calculates the optimal size of the WORK array, returns */
+/* >          this value as the first entry of the WORK array, and no error */
+/* >          message related to LWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0:  SPOTRF or SSYEV returned an error code: */
+/* >             <= N:  if INFO = i, SSYEV failed to converge; */
+/* >                    i off-diagonal elements of an intermediate */
+/* >                    tridiagonal form did not converge to zero; */
+/* >             > N:   if INFO = N + i, for 1 <= i <= N, then the leading */
+/* >                    minor of order i of B is not positive definite. */
+/* >                    The factorization of B could not be completed and */
+/* >                    no eigenvalues or eigenvectors were computed. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date November 2017 */
+
+/* > \ingroup realSYeigen */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  All details about the 2stage techniques are available in: */
+/* > */
+/* >  Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */
+/* >  Parallel reduction to condensed forms for symmetric eigenvalue problems */
+/* >  using aggregated fine-grained and memory-aware kernels. In Proceedings */
+/* >  of 2011 International Conference for High Performance Computing, */
+/* >  Networking, Storage and Analysis (SC '11), New York, NY, USA, */
+/* >  Article 8 , 11 pages. */
+/* >  http://doi.acm.org/10.1145/2063384.2063394 */
+/* > */
+/* >  A. Haidar, J. Kurzak, P. Luszczek, 2013. */
+/* >  An improved parallel singular value algorithm and its implementation */
+/* >  for multicore hardware, In Proceedings of 2013 International Conference */
+/* >  for High Performance Computing, Networking, Storage and Analysis (SC '13). */
+/* >  Denver, Colorado, USA, 2013. */
+/* >  Article 90, 12 pages. */
+/* >  http://doi.acm.org/10.1145/2503210.2503292 */
+/* > */
+/* >  A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */
+/* >  A novel hybrid CPU-GPU generalized eigensolver for electronic structure */
+/* >  calculations based on fine-grained memory aware tasks. */
+/* >  International Journal of High Performance Computing Applications. */
+/* >  Volume 28 Issue 2, Pages 196-209, May 2014. */
+/* >  http://hpc.sagepub.com/content/28/2/196 */
+/* > */
+/* > \endverbatim */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssygv_2stage_(integer *itype, char *jobz, char *uplo, 
+	integer *n, real *a, integer *lda, real *b, integer *ldb, real *w, 
+	real *work, integer *lwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+    /* Local variables */
+    integer neig;
+    extern integer ilaenv2stage_(integer *, char *, char *, integer *, 
+	    integer *, integer *, integer *);
+    extern /* Subroutine */ int ssyev_2stage_(char *, char *, integer *, 
+	    real *, integer *, real *, real *, integer *, integer *);
+    extern logical lsame_(char *, char *);
+    integer lhtrd, lwmin;
+    char trans[1];
+    logical upper;
+    integer lwtrd;
+    extern /* Subroutine */ int strmm_(char *, char *, char *, char *, 
+	    integer *, integer *, real *, real *, integer *, real *, integer *
+	    );
+    logical wantz;
+    extern /* Subroutine */ int strsm_(char *, char *, char *, char *, 
+	    integer *, integer *, real *, real *, integer *, real *, integer *
+	    );
+    integer ib, kd;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), spotrf_(
+	    char *, integer *, real *, integer *, integer *);
+    logical lquery;
+    extern /* Subroutine */ int ssygst_(integer *, char *, integer *, real *, 
+	    integer *, real *, integer *, integer *);
+
+
+
+/*  -- LAPACK driver 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    --w;
+    --work;
+
+    /* Function Body */
+    wantz = lsame_(jobz, "V");
+    upper = lsame_(uplo, "U");
+    lquery = *lwork == -1;
+
+    *info = 0;
+    if (*itype < 1 || *itype > 3) {
+	*info = -1;
+    } else if (! lsame_(jobz, "N")) {
+	*info = -2;
+    } else if (! (upper || lsame_(uplo, "L"))) {
+	*info = -3;
+    } else if (*n < 0) {
+	*info = -4;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -6;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -8;
+    }
+
+    if (*info == 0) {
+	kd = ilaenv2stage_(&c__1, "SSYTRD_2STAGE", jobz, n, &c_n1, &c_n1, &
+		c_n1);
+	ib = ilaenv2stage_(&c__2, "SSYTRD_2STAGE", jobz, n, &kd, &c_n1, &c_n1);
+	lhtrd = ilaenv2stage_(&c__3, "SSYTRD_2STAGE", jobz, n, &kd, &ib, &
+		c_n1);
+	lwtrd = ilaenv2stage_(&c__4, "SSYTRD_2STAGE", jobz, n, &kd, &ib, &
+		c_n1);
+	lwmin = (*n << 1) + lhtrd + lwtrd;
+	work[1] = (real) lwmin;
+
+	if (*lwork < lwmin && ! lquery) {
+	    *info = -11;
+	}
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYGV_2STAGE ", &i__1, (ftnlen)13);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+/*     Form a Cholesky factorization of B. */
+
+    spotrf_(uplo, n, &b[b_offset], ldb, info);
+    if (*info != 0) {
+	*info = *n + *info;
+	return 0;
+    }
+
+/*     Transform problem to standard eigenvalue problem and solve. */
+
+    ssygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
+    ssyev_2stage_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, 
+	    info);
+
+    if (wantz) {
+
+/*        Backtransform eigenvectors to the original problem. */
+
+	neig = *n;
+	if (*info > 0) {
+	    neig = *info - 1;
+	}
+	if (*itype == 1 || *itype == 2) {
+
+/*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/*           backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y */
+
+	    if (upper) {
+		*(unsigned char *)trans = 'N';
+	    } else {
+		*(unsigned char *)trans = 'T';
+	    }
+
+	    strsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b26, &b[
+		    b_offset], ldb, &a[a_offset], lda);
+
+	} else if (*itype == 3) {
+
+/*           For B*A*x=(lambda)*x; */
+/*           backtransform eigenvectors: x = L*y or U**T*y */
+
+	    if (upper) {
+		*(unsigned char *)trans = 'T';
+	    } else {
+		*(unsigned char *)trans = 'N';
+	    }
+
+	    strmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b26, &b[
+		    b_offset], ldb, &a[a_offset], lda);
+	}
+    }
+
+    work[1] = (real) lwmin;
+    return 0;
+
+/*     End of SSYGV_2STAGE */
+
+} /* ssygv_2stage__ */
+

lapack-netlib/SRC/ssygvd.c

@@ -0,0 +1,793 @@
+/* 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_b11 = 1.f;
+
+/* > \brief \b SSYGVD */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYGVD + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssygvd.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssygvd.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssygvd.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK, */
+/*                          LWORK, IWORK, LIWORK, INFO ) */
+
+/*       CHARACTER          JOBZ, UPLO */
+/*       INTEGER            INFO, ITYPE, LDA, LDB, LIWORK, LWORK, N */
+/*       INTEGER            IWORK( * ) */
+/*       REAL               A( LDA, * ), B( LDB, * ), W( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYGVD computes all the eigenvalues, and optionally, the eigenvectors */
+/* > of a real generalized symmetric-definite eigenproblem, of the form */
+/* > A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A and */
+/* > B are assumed to be symmetric and B is also positive definite. */
+/* > If eigenvectors are desired, it uses a divide and conquer algorithm. */
+/* > */
+/* > The divide and conquer algorithm makes very mild assumptions about */
+/* > floating point arithmetic. It will work on machines with a guard */
+/* > digit in add/subtract, or on those binary machines without guard */
+/* > digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
+/* > Cray-2. It could conceivably fail on hexadecimal or decimal machines */
+/* > without guard digits, but we know of none. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] ITYPE */
+/* > \verbatim */
+/* >          ITYPE is INTEGER */
+/* >          Specifies the problem type to be solved: */
+/* >          = 1:  A*x = (lambda)*B*x */
+/* >          = 2:  A*B*x = (lambda)*x */
+/* >          = 3:  B*A*x = (lambda)*x */
+/* > \endverbatim */
+/* > */
+/* > \param[in] JOBZ */
+/* > \verbatim */
+/* >          JOBZ is CHARACTER*1 */
+/* >          = 'N':  Compute eigenvalues only; */
+/* >          = 'V':  Compute eigenvalues and eigenvectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangles of A and B are stored; */
+/* >          = 'L':  Lower triangles of A and B are stored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrices A and B.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA, N) */
+/* >          On entry, the symmetric matrix A.  If UPLO = 'U', the */
+/* >          leading N-by-N upper triangular part of A contains the */
+/* >          upper triangular part of the matrix A.  If UPLO = 'L', */
+/* >          the leading N-by-N lower triangular part of A contains */
+/* >          the lower triangular part of the matrix A. */
+/* > */
+/* >          On exit, if JOBZ = 'V', then if INFO = 0, A contains the */
+/* >          matrix Z of eigenvectors.  The eigenvectors are normalized */
+/* >          as follows: */
+/* >          if ITYPE = 1 or 2, Z**T*B*Z = I; */
+/* >          if ITYPE = 3, Z**T*inv(B)*Z = I. */
+/* >          If JOBZ = 'N', then on exit the upper triangle (if UPLO='U') */
+/* >          or the lower triangle (if UPLO='L') of A, including the */
+/* >          diagonal, is destroyed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB, N) */
+/* >          On entry, the symmetric matrix B.  If UPLO = 'U', the */
+/* >          leading N-by-N upper triangular part of B contains the */
+/* >          upper triangular part of the matrix B.  If UPLO = 'L', */
+/* >          the leading N-by-N lower triangular part of B contains */
+/* >          the lower triangular part of the matrix B. */
+/* > */
+/* >          On exit, if INFO <= N, the part of B containing the matrix is */
+/* >          overwritten by the triangular factor U or L from the Cholesky */
+/* >          factorization B = U**T*U or B = L*L**T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] W */
+/* > \verbatim */
+/* >          W is REAL array, dimension (N) */
+/* >          If INFO = 0, the eigenvalues in ascending order. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (MAX(1,LWORK)) */
+/* >          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The dimension of the array WORK. */
+/* >          If N <= 1,               LWORK >= 1. */
+/* >          If JOBZ = 'N' and N > 1, LWORK >= 2*N+1. */
+/* >          If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2. */
+/* > */
+/* >          If LWORK = -1, then a workspace query is assumed; the routine */
+/* >          only calculates the optimal sizes of the WORK and IWORK */
+/* >          arrays, returns these values as the first entries of the WORK */
+/* >          and IWORK arrays, and no error message related to LWORK or */
+/* >          LIWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */
+/* >          On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LIWORK */
+/* > \verbatim */
+/* >          LIWORK is INTEGER */
+/* >          The dimension of the array IWORK. */
+/* >          If N <= 1,                LIWORK >= 1. */
+/* >          If JOBZ  = 'N' and N > 1, LIWORK >= 1. */
+/* >          If JOBZ  = 'V' and N > 1, LIWORK >= 3 + 5*N. */
+/* > */
+/* >          If LIWORK = -1, then a workspace query is assumed; the */
+/* >          routine only calculates the optimal sizes of the WORK and */
+/* >          IWORK arrays, returns these values as the first entries of */
+/* >          the WORK and IWORK arrays, and no error message related to */
+/* >          LWORK or LIWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0:  SPOTRF or SSYEVD returned an error code: */
+/* >             <= N:  if INFO = i and JOBZ = 'N', then the algorithm */
+/* >                    failed to converge; i off-diagonal elements of an */
+/* >                    intermediate tridiagonal form did not converge to */
+/* >                    zero; */
+/* >                    if INFO = i and JOBZ = 'V', then the algorithm */
+/* >                    failed to compute an eigenvalue while working on */
+/* >                    the submatrix lying in rows and columns INFO/(N+1) */
+/* >                    through mod(INFO,N+1); */
+/* >             > N:   if INFO = N + i, for 1 <= i <= N, then the leading */
+/* >                    minor of order i of B is not positive definite. */
+/* >                    The factorization of B could not be completed and */
+/* >                    no eigenvalues or eigenvectors were computed. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realSYeigen */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  Modified so that no backsubstitution is performed if SSYEVD fails to */
+/* >  converge (NEIG in old code could be greater than N causing out of */
+/* >  bounds reference to A - reported by Ralf Meyer).  Also corrected the */
+/* >  description of INFO and the test on ITYPE. Sven, 16 Feb 05. */
+/* > \endverbatim */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > */
+/* >     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int ssygvd_(integer *itype, char *jobz, char *uplo, integer *
+	n, real *a, integer *lda, real *b, integer *ldb, real *w, real *work, 
+	integer *lwork, integer *iwork, integer *liwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+    real r__1, r__2;
+
+    /* Local variables */
+    integer lopt;
+    extern logical lsame_(char *, char *);
+    integer lwmin;
+    char trans[1];
+    integer liopt;
+    logical upper;
+    extern /* Subroutine */ int strmm_(char *, char *, char *, char *, 
+	    integer *, integer *, real *, real *, integer *, real *, integer *
+	    );
+    logical wantz;
+    extern /* Subroutine */ int strsm_(char *, char *, char *, char *, 
+	    integer *, integer *, real *, real *, integer *, real *, integer *
+	    ), xerbla_(char *, integer *, ftnlen);
+    integer liwmin;
+    extern /* Subroutine */ int spotrf_(char *, integer *, real *, integer *, 
+	    integer *), ssyevd_(char *, char *, integer *, real *, 
+	    integer *, real *, real *, integer *, integer *, integer *, 
+	    integer *);
+    logical lquery;
+    extern /* Subroutine */ int ssygst_(integer *, char *, integer *, real *, 
+	    integer *, real *, integer *, integer *);
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    --w;
+    --work;
+    --iwork;
+
+    /* Function Body */
+    wantz = lsame_(jobz, "V");
+    upper = lsame_(uplo, "U");
+    lquery = *lwork == -1 || *liwork == -1;
+
+    *info = 0;
+    if (*n <= 1) {
+	liwmin = 1;
+	lwmin = 1;
+    } else if (wantz) {
+	liwmin = *n * 5 + 3;
+/* Computing 2nd power */
+	i__1 = *n;
+	lwmin = *n * 6 + 1 + (i__1 * i__1 << 1);
+    } else {
+	liwmin = 1;
+	lwmin = (*n << 1) + 1;
+    }
+    lopt = lwmin;
+    liopt = liwmin;
+    if (*itype < 1 || *itype > 3) {
+	*info = -1;
+    } else if (! (wantz || lsame_(jobz, "N"))) {
+	*info = -2;
+    } else if (! (upper || lsame_(uplo, "L"))) {
+	*info = -3;
+    } else if (*n < 0) {
+	*info = -4;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -6;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -8;
+    }
+
+    if (*info == 0) {
+	work[1] = (real) lopt;
+	iwork[1] = liopt;
+
+	if (*lwork < lwmin && ! lquery) {
+	    *info = -11;
+	} else if (*liwork < liwmin && ! lquery) {
+	    *info = -13;
+	}
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYGVD", &i__1, (ftnlen)6);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+/*     Form a Cholesky factorization of B. */
+
+    spotrf_(uplo, n, &b[b_offset], ldb, info);
+    if (*info != 0) {
+	*info = *n + *info;
+	return 0;
+    }
+
+/*     Transform problem to standard eigenvalue problem and solve. */
+
+    ssygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
+    ssyevd_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &iwork[
+	    1], liwork, info);
+/* Computing MAX */
+    r__1 = (real) lopt;
+    lopt = f2cmax(r__1,work[1]);
+/* Computing MAX */
+    r__1 = (real) liopt, r__2 = (real) iwork[1];
+    liopt = f2cmax(r__1,r__2);
+
+    if (wantz && *info == 0) {
+
+/*        Backtransform eigenvectors to the original problem. */
+
+	if (*itype == 1 || *itype == 2) {
+
+/*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/*           backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y */
+
+	    if (upper) {
+		*(unsigned char *)trans = 'N';
+	    } else {
+		*(unsigned char *)trans = 'T';
+	    }
+
+	    strsm_("Left", uplo, trans, "Non-unit", n, n, &c_b11, &b[b_offset]
+		    , ldb, &a[a_offset], lda);
+
+	} else if (*itype == 3) {
+
+/*           For B*A*x=(lambda)*x; */
+/*           backtransform eigenvectors: x = L*y or U**T*y */
+
+	    if (upper) {
+		*(unsigned char *)trans = 'T';
+	    } else {
+		*(unsigned char *)trans = 'N';
+	    }
+
+	    strmm_("Left", uplo, trans, "Non-unit", n, n, &c_b11, &b[b_offset]
+		    , ldb, &a[a_offset], lda);
+	}
+    }
+
+    work[1] = (real) lopt;
+    iwork[1] = liopt;
+
+    return 0;
+
+/*     End of SSYGVD */
+
+} /* ssygvd_ */
+

lapack-netlib/SRC/ssygvx.c

@@ -0,0 +1,886 @@
+/* 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_n1 = -1;
+static real c_b19 = 1.f;
+
+/* > \brief \b SSYGVX */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYGVX + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssygvx.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssygvx.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssygvx.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYGVX( ITYPE, JOBZ, RANGE, UPLO, N, A, LDA, B, LDB, */
+/*                          VL, VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, */
+/*                          LWORK, IWORK, IFAIL, INFO ) */
+
+/*       CHARACTER          JOBZ, RANGE, UPLO */
+/*       INTEGER            IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N */
+/*       REAL               ABSTOL, VL, VU */
+/*       INTEGER            IFAIL( * ), IWORK( * ) */
+/*       REAL               A( LDA, * ), B( LDB, * ), W( * ), WORK( * ), */
+/*      $                   Z( LDZ, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYGVX computes selected eigenvalues, and optionally, eigenvectors */
+/* > of a real generalized symmetric-definite eigenproblem, of the form */
+/* > A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A */
+/* > and B are assumed to be symmetric and B is also positive definite. */
+/* > Eigenvalues and eigenvectors can be selected by specifying either a */
+/* > range of values or a range of indices for the desired eigenvalues. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] ITYPE */
+/* > \verbatim */
+/* >          ITYPE is INTEGER */
+/* >          Specifies the problem type to be solved: */
+/* >          = 1:  A*x = (lambda)*B*x */
+/* >          = 2:  A*B*x = (lambda)*x */
+/* >          = 3:  B*A*x = (lambda)*x */
+/* > \endverbatim */
+/* > */
+/* > \param[in] JOBZ */
+/* > \verbatim */
+/* >          JOBZ is CHARACTER*1 */
+/* >          = 'N':  Compute eigenvalues only; */
+/* >          = 'V':  Compute eigenvalues and eigenvectors. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] RANGE */
+/* > \verbatim */
+/* >          RANGE is CHARACTER*1 */
+/* >          = 'A': all eigenvalues will be found. */
+/* >          = 'V': all eigenvalues in the half-open interval (VL,VU] */
+/* >                 will be found. */
+/* >          = 'I': the IL-th through IU-th eigenvalues will be found. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A and B are stored; */
+/* >          = 'L':  Lower triangle of A and B are stored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix pencil (A,B).  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA, N) */
+/* >          On entry, the symmetric matrix A.  If UPLO = 'U', the */
+/* >          leading N-by-N upper triangular part of A contains the */
+/* >          upper triangular part of the matrix A.  If UPLO = 'L', */
+/* >          the leading N-by-N lower triangular part of A contains */
+/* >          the lower triangular part of the matrix A. */
+/* > */
+/* >          On exit, the lower triangle (if UPLO='L') or the upper */
+/* >          triangle (if UPLO='U') of A, including the diagonal, is */
+/* >          destroyed. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB, N) */
+/* >          On entry, the symmetric matrix B.  If UPLO = 'U', the */
+/* >          leading N-by-N upper triangular part of B contains the */
+/* >          upper triangular part of the matrix B.  If UPLO = 'L', */
+/* >          the leading N-by-N lower triangular part of B contains */
+/* >          the lower triangular part of the matrix B. */
+/* > */
+/* >          On exit, if INFO <= N, the part of B containing the matrix is */
+/* >          overwritten by the triangular factor U or L from the Cholesky */
+/* >          factorization B = U**T*U or B = L*L**T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] VL */
+/* > \verbatim */
+/* >          VL is REAL */
+/* >          If RANGE='V', the lower bound of the interval to */
+/* >          be searched for eigenvalues. VL < VU. */
+/* >          Not referenced if RANGE = 'A' or 'I'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] VU */
+/* > \verbatim */
+/* >          VU is REAL */
+/* >          If RANGE='V', the upper bound of the interval to */
+/* >          be searched for eigenvalues. VL < VU. */
+/* >          Not referenced if RANGE = 'A' or 'I'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IL */
+/* > \verbatim */
+/* >          IL is INTEGER */
+/* >          If RANGE='I', the index of the */
+/* >          smallest eigenvalue to be returned. */
+/* >          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* >          Not referenced if RANGE = 'A' or 'V'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IU */
+/* > \verbatim */
+/* >          IU is INTEGER */
+/* >          If RANGE='I', the index of the */
+/* >          largest eigenvalue to be returned. */
+/* >          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
+/* >          Not referenced if RANGE = 'A' or 'V'. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] ABSTOL */
+/* > \verbatim */
+/* >          ABSTOL is REAL */
+/* >          The absolute error tolerance for the eigenvalues. */
+/* >          An approximate eigenvalue is accepted as converged */
+/* >          when it is determined to lie in an interval [a,b] */
+/* >          of width less than or equal to */
+/* > */
+/* >                  ABSTOL + EPS *   f2cmax( |a|,|b| ) , */
+/* > */
+/* >          where EPS is the machine precision.  If ABSTOL is less than */
+/* >          or equal to zero, then  EPS*|T|  will be used in its place, */
+/* >          where |T| is the 1-norm of the tridiagonal matrix obtained */
+/* >          by reducing C to tridiagonal form, where C is the symmetric */
+/* >          matrix of the standard symmetric problem to which the */
+/* >          generalized problem is transformed. */
+/* > */
+/* >          Eigenvalues will be computed most accurately when ABSTOL is */
+/* >          set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
+/* >          If this routine returns with INFO>0, indicating that some */
+/* >          eigenvectors did not converge, try setting ABSTOL to */
+/* >          2*SLAMCH('S'). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] M */
+/* > \verbatim */
+/* >          M is INTEGER */
+/* >          The total number of eigenvalues found.  0 <= M <= N. */
+/* >          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] W */
+/* > \verbatim */
+/* >          W is REAL array, dimension (N) */
+/* >          On normal exit, the first M elements contain the selected */
+/* >          eigenvalues in ascending order. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] Z */
+/* > \verbatim */
+/* >          Z is REAL array, dimension (LDZ, f2cmax(1,M)) */
+/* >          If JOBZ = 'N', then Z is not referenced. */
+/* >          If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
+/* >          contain the orthonormal eigenvectors of the matrix A */
+/* >          corresponding to the selected eigenvalues, with the i-th */
+/* >          column of Z holding the eigenvector associated with W(i). */
+/* >          The eigenvectors are normalized as follows: */
+/* >          if ITYPE = 1 or 2, Z**T*B*Z = I; */
+/* >          if ITYPE = 3, Z**T*inv(B)*Z = I. */
+/* > */
+/* >          If an eigenvector fails to converge, then that column of Z */
+/* >          contains the latest approximation to the eigenvector, and the */
+/* >          index of the eigenvector is returned in IFAIL. */
+/* >          Note: the user must ensure that at least f2cmax(1,M) columns are */
+/* >          supplied in the array Z; if RANGE = 'V', the exact value of M */
+/* >          is not known in advance and an upper bound must be used. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDZ */
+/* > \verbatim */
+/* >          LDZ is INTEGER */
+/* >          The leading dimension of the array Z.  LDZ >= 1, and if */
+/* >          JOBZ = 'V', LDZ >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (MAX(1,LWORK)) */
+/* >          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The length of the array WORK.  LWORK >= f2cmax(1,8*N). */
+/* >          For optimal efficiency, LWORK >= (NB+3)*N, */
+/* >          where NB is the blocksize for SSYTRD returned by ILAENV. */
+/* > */
+/* >          If LWORK = -1, then a workspace query is assumed; the routine */
+/* >          only calculates the optimal size of the WORK array, returns */
+/* >          this value as the first entry of the WORK array, and no error */
+/* >          message related to LWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (5*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IFAIL */
+/* > \verbatim */
+/* >          IFAIL is INTEGER array, dimension (N) */
+/* >          If JOBZ = 'V', then if INFO = 0, the first M elements of */
+/* >          IFAIL are zero.  If INFO > 0, then IFAIL contains the */
+/* >          indices of the eigenvectors that failed to converge. */
+/* >          If JOBZ = 'N', then IFAIL is not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0:  SPOTRF or SSYEVX returned an error code: */
+/* >             <= N:  if INFO = i, SSYEVX failed to converge; */
+/* >                    i eigenvectors failed to converge.  Their indices */
+/* >                    are stored in array IFAIL. */
+/* >             > N:   if INFO = N + i, for 1 <= i <= N, then the leading */
+/* >                    minor of order i of B is not positive definite. */
+/* >                    The factorization of B could not be completed and */
+/* >                    no eigenvalues or eigenvectors were computed. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date June 2016 */
+
+/* > \ingroup realSYeigen */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > */
+/* >     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssygvx_(integer *itype, char *jobz, char *range, char *
+	uplo, integer *n, real *a, integer *lda, real *b, integer *ldb, real *
+	vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, 
+	real *w, real *z__, integer *ldz, real *work, integer *lwork, integer 
+	*iwork, integer *ifail, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1, i__2;
+
+    /* Local variables */
+    extern logical lsame_(char *, char *);
+    char trans[1];
+    logical upper;
+    extern /* Subroutine */ int strmm_(char *, char *, char *, char *, 
+	    integer *, integer *, real *, real *, integer *, real *, integer *
+	    );
+    logical wantz;
+    extern /* Subroutine */ int strsm_(char *, char *, char *, char *, 
+	    integer *, integer *, real *, real *, integer *, real *, integer *
+	    );
+    integer nb;
+    logical alleig, indeig, valeig;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
+	    integer *, integer *, ftnlen, ftnlen);
+    integer lwkmin;
+    extern /* Subroutine */ int spotrf_(char *, integer *, real *, integer *, 
+	    integer *);
+    integer lwkopt;
+    logical lquery;
+    extern /* Subroutine */ int ssygst_(integer *, char *, integer *, real *, 
+	    integer *, real *, integer *, integer *), ssyevx_(char *, 
+	    char *, char *, integer *, real *, integer *, real *, real *, 
+	    integer *, integer *, real *, integer *, real *, real *, integer *
+	    , real *, integer *, integer *, integer *, integer *);
+
+
+/*  -- LAPACK driver routine (version 3.7.1) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     June 2016 */
+
+
+/* ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    --w;
+    z_dim1 = *ldz;
+    z_offset = 1 + z_dim1 * 1;
+    z__ -= z_offset;
+    --work;
+    --iwork;
+    --ifail;
+
+    /* Function Body */
+    upper = lsame_(uplo, "U");
+    wantz = lsame_(jobz, "V");
+    alleig = lsame_(range, "A");
+    valeig = lsame_(range, "V");
+    indeig = lsame_(range, "I");
+    lquery = *lwork == -1;
+
+    *info = 0;
+    if (*itype < 1 || *itype > 3) {
+	*info = -1;
+    } else if (! (wantz || lsame_(jobz, "N"))) {
+	*info = -2;
+    } else if (! (alleig || valeig || indeig)) {
+	*info = -3;
+    } else if (! (upper || lsame_(uplo, "L"))) {
+	*info = -4;
+    } else if (*n < 0) {
+	*info = -5;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -7;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -9;
+    } else {
+	if (valeig) {
+	    if (*n > 0 && *vu <= *vl) {
+		*info = -11;
+	    }
+	} else if (indeig) {
+	    if (*il < 1 || *il > f2cmax(1,*n)) {
+		*info = -12;
+	    } else if (*iu < f2cmin(*n,*il) || *iu > *n) {
+		*info = -13;
+	    }
+	}
+    }
+    if (*info == 0) {
+	if (*ldz < 1 || wantz && *ldz < *n) {
+	    *info = -18;
+	}
+    }
+
+    if (*info == 0) {
+/* Computing MAX */
+	i__1 = 1, i__2 = *n << 3;
+	lwkmin = f2cmax(i__1,i__2);
+	nb = ilaenv_(&c__1, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
+		 (ftnlen)1);
+/* Computing MAX */
+	i__1 = lwkmin, i__2 = (nb + 3) * *n;
+	lwkopt = f2cmax(i__1,i__2);
+	work[1] = (real) lwkopt;
+
+	if (*lwork < lwkmin && ! lquery) {
+	    *info = -20;
+	}
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYGVX", &i__1, (ftnlen)6);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    *m = 0;
+    if (*n == 0) {
+	return 0;
+    }
+
+/*     Form a Cholesky factorization of B. */
+
+    spotrf_(uplo, n, &b[b_offset], ldb, info);
+    if (*info != 0) {
+	*info = *n + *info;
+	return 0;
+    }
+
+/*     Transform problem to standard eigenvalue problem and solve. */
+
+    ssygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
+    ssyevx_(jobz, range, uplo, n, &a[a_offset], lda, vl, vu, il, iu, abstol, 
+	    m, &w[1], &z__[z_offset], ldz, &work[1], lwork, &iwork[1], &ifail[
+	    1], info);
+
+    if (wantz) {
+
+/*        Backtransform eigenvectors to the original problem. */
+
+	if (*info > 0) {
+	    *m = *info - 1;
+	}
+	if (*itype == 1 || *itype == 2) {
+
+/*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
+/*           backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y */
+
+	    if (upper) {
+		*(unsigned char *)trans = 'N';
+	    } else {
+		*(unsigned char *)trans = 'T';
+	    }
+
+	    strsm_("Left", uplo, trans, "Non-unit", n, m, &c_b19, &b[b_offset]
+		    , ldb, &z__[z_offset], ldz);
+
+	} else if (*itype == 3) {
+
+/*           For B*A*x=(lambda)*x; */
+/*           backtransform eigenvectors: x = L*y or U**T*y */
+
+	    if (upper) {
+		*(unsigned char *)trans = 'T';
+	    } else {
+		*(unsigned char *)trans = 'N';
+	    }
+
+	    strmm_("Left", uplo, trans, "Non-unit", n, m, &c_b19, &b[b_offset]
+		    , ldb, &z__[z_offset], ldz);
+	}
+    }
+
+/*     Set WORK(1) to optimal workspace size. */
+
+    work[1] = (real) lwkopt;
+
+    return 0;
+
+/*     End of SSYGVX */
+
+} /* ssygvx_ */
+

lapack-netlib/SRC/ssyrfs.c

@@ -0,0 +1,884 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define 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 real c_b12 = -1.f;
+static real c_b14 = 1.f;
+
+/* > \brief \b SSYRFS */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYRFS + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssyrfs.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssyrfs.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssyrfs.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, */
+/*                          X, LDX, FERR, BERR, WORK, IWORK, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDA, LDAF, LDB, LDX, N, NRHS */
+/*       INTEGER            IPIV( * ), IWORK( * ) */
+/*       REAL               A( LDA, * ), AF( LDAF, * ), B( LDB, * ), */
+/*      $                   BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYRFS improves the computed solution to a system of linear */
+/* > equations when the coefficient matrix is symmetric indefinite, and */
+/* > provides error bounds and backward error estimates for the solution. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The number of right hand sides, i.e., the number of columns */
+/* >          of the matrices B and X.  NRHS >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          The symmetric matrix A.  If UPLO = 'U', the leading N-by-N */
+/* >          upper triangular part of A contains the upper triangular part */
+/* >          of the matrix A, and the strictly lower triangular part of A */
+/* >          is not referenced.  If UPLO = 'L', the leading N-by-N lower */
+/* >          triangular part of A contains the lower triangular part of */
+/* >          the matrix A, and the strictly upper triangular part of A is */
+/* >          not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] AF */
+/* > \verbatim */
+/* >          AF is REAL array, dimension (LDAF,N) */
+/* >          The factored form of the matrix A.  AF contains the block */
+/* >          diagonal matrix D and the multipliers used to obtain the */
+/* >          factor U or L from the factorization A = U*D*U**T or */
+/* >          A = L*D*L**T as computed by SSYTRF. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDAF */
+/* > \verbatim */
+/* >          LDAF is INTEGER */
+/* >          The leading dimension of the array AF.  LDAF >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges and the block structure of D */
+/* >          as determined by SSYTRF. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB,NRHS) */
+/* >          The right hand side matrix B. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] X */
+/* > \verbatim */
+/* >          X is REAL array, dimension (LDX,NRHS) */
+/* >          On entry, the solution matrix X, as computed by SSYTRS. */
+/* >          On exit, the improved solution matrix X. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDX */
+/* > \verbatim */
+/* >          LDX is INTEGER */
+/* >          The leading dimension of the array X.  LDX >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] FERR */
+/* > \verbatim */
+/* >          FERR is REAL array, dimension (NRHS) */
+/* >          The estimated forward error bound for each solution vector */
+/* >          X(j) (the j-th column of the solution matrix X). */
+/* >          If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* >          is an estimated upper bound for the magnitude of the largest */
+/* >          element in (X(j) - XTRUE) divided by the magnitude of the */
+/* >          largest element in X(j).  The estimate is as reliable as */
+/* >          the estimate for RCOND, and is almost always a slight */
+/* >          overestimate of the true error. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] BERR */
+/* > \verbatim */
+/* >          BERR is REAL array, dimension (NRHS) */
+/* >          The componentwise relative backward error of each solution */
+/* >          vector X(j) (i.e., the smallest relative change in */
+/* >          any element of A or B that makes X(j) an exact solution). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (3*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/* > \par Internal Parameters: */
+/*  ========================= */
+/* > */
+/* > \verbatim */
+/* >  ITMAX is the maximum number of steps of iterative refinement. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realSYcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssyrfs_(char *uplo, integer *n, integer *nrhs, real *a, 
+	integer *lda, real *af, integer *ldaf, integer *ipiv, real *b, 
+	integer *ldb, real *x, integer *ldx, real *ferr, real *berr, real *
+	work, integer *iwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, 
+	    x_offset, i__1, i__2, i__3;
+    real r__1, r__2, r__3;
+
+    /* Local variables */
+    integer kase;
+    real safe1, safe2;
+    integer i__, j, k;
+    real s;
+    extern logical lsame_(char *, char *);
+    integer isave[3], count;
+    logical upper;
+    extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, 
+	    integer *), saxpy_(integer *, real *, real *, integer *, real *, 
+	    integer *), ssymv_(char *, integer *, real *, real *, integer *, 
+	    real *, integer *, real *, real *, integer *), slacn2_(
+	    integer *, real *, real *, integer *, real *, integer *, integer *
+	    );
+    real xk;
+    extern real slamch_(char *);
+    integer nz;
+    real safmin;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    real lstres;
+    extern /* Subroutine */ int ssytrs_(char *, integer *, integer *, real *, 
+	    integer *, integer *, real *, integer *, integer *);
+    real eps;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    af_dim1 = *ldaf;
+    af_offset = 1 + af_dim1 * 1;
+    af -= af_offset;
+    --ipiv;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    x_dim1 = *ldx;
+    x_offset = 1 + x_dim1 * 1;
+    x -= x_offset;
+    --ferr;
+    --berr;
+    --work;
+    --iwork;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*nrhs < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    } else if (*ldaf < f2cmax(1,*n)) {
+	*info = -7;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -10;
+    } else if (*ldx < f2cmax(1,*n)) {
+	*info = -12;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYRFS", &i__1, (ftnlen)6);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0 || *nrhs == 0) {
+	i__1 = *nrhs;
+	for (j = 1; j <= i__1; ++j) {
+	    ferr[j] = 0.f;
+	    berr[j] = 0.f;
+/* L10: */
+	}
+	return 0;
+    }
+
+/*     NZ = maximum number of nonzero elements in each row of A, plus 1 */
+
+    nz = *n + 1;
+    eps = slamch_("Epsilon");
+    safmin = slamch_("Safe minimum");
+    safe1 = nz * safmin;
+    safe2 = safe1 / eps;
+
+/*     Do for each right hand side */
+
+    i__1 = *nrhs;
+    for (j = 1; j <= i__1; ++j) {
+
+	count = 1;
+	lstres = 3.f;
+L20:
+
+/*        Loop until stopping criterion is satisfied. */
+
+/*        Compute residual R = B - A * X */
+
+	scopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1);
+	ssymv_(uplo, n, &c_b12, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, 
+		&c_b14, &work[*n + 1], &c__1);
+
+/*        Compute componentwise relative backward error from formula */
+
+/*        f2cmax(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */
+
+/*        where abs(Z) is the componentwise absolute value of the matrix */
+/*        or vector Z.  If the i-th component of the denominator is less */
+/*        than SAFE2, then SAFE1 is added to the i-th components of the */
+/*        numerator and denominator before dividing. */
+
+	i__2 = *n;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    work[i__] = (r__1 = b[i__ + j * b_dim1], abs(r__1));
+/* L30: */
+	}
+
+/*        Compute abs(A)*abs(X) + abs(B). */
+
+	if (upper) {
+	    i__2 = *n;
+	    for (k = 1; k <= i__2; ++k) {
+		s = 0.f;
+		xk = (r__1 = x[k + j * x_dim1], abs(r__1));
+		i__3 = k - 1;
+		for (i__ = 1; i__ <= i__3; ++i__) {
+		    work[i__] += (r__1 = a[i__ + k * a_dim1], abs(r__1)) * xk;
+		    s += (r__1 = a[i__ + k * a_dim1], abs(r__1)) * (r__2 = x[
+			    i__ + j * x_dim1], abs(r__2));
+/* L40: */
+		}
+		work[k] = work[k] + (r__1 = a[k + k * a_dim1], abs(r__1)) * 
+			xk + s;
+/* L50: */
+	    }
+	} else {
+	    i__2 = *n;
+	    for (k = 1; k <= i__2; ++k) {
+		s = 0.f;
+		xk = (r__1 = x[k + j * x_dim1], abs(r__1));
+		work[k] += (r__1 = a[k + k * a_dim1], abs(r__1)) * xk;
+		i__3 = *n;
+		for (i__ = k + 1; i__ <= i__3; ++i__) {
+		    work[i__] += (r__1 = a[i__ + k * a_dim1], abs(r__1)) * xk;
+		    s += (r__1 = a[i__ + k * a_dim1], abs(r__1)) * (r__2 = x[
+			    i__ + j * x_dim1], abs(r__2));
+/* L60: */
+		}
+		work[k] += s;
+/* L70: */
+	    }
+	}
+	s = 0.f;
+	i__2 = *n;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    if (work[i__] > safe2) {
+/* Computing MAX */
+		r__2 = s, r__3 = (r__1 = work[*n + i__], abs(r__1)) / work[
+			i__];
+		s = f2cmax(r__2,r__3);
+	    } else {
+/* Computing MAX */
+		r__2 = s, r__3 = ((r__1 = work[*n + i__], abs(r__1)) + safe1) 
+			/ (work[i__] + safe1);
+		s = f2cmax(r__2,r__3);
+	    }
+/* L80: */
+	}
+	berr[j] = s;
+
+/*        Test stopping criterion. Continue iterating if */
+/*           1) The residual BERR(J) is larger than machine epsilon, and */
+/*           2) BERR(J) decreased by at least a factor of 2 during the */
+/*              last iteration, and */
+/*           3) At most ITMAX iterations tried. */
+
+	if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) {
+
+/*           Update solution and try again. */
+
+	    ssytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[*n 
+		    + 1], n, info);
+	    saxpy_(n, &c_b14, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1)
+		    ;
+	    lstres = berr[j];
+	    ++count;
+	    goto L20;
+	}
+
+/*        Bound error from formula */
+
+/*        norm(X - XTRUE) / norm(X) .le. FERR = */
+/*        norm( abs(inv(A))* */
+/*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */
+
+/*        where */
+/*          norm(Z) is the magnitude of the largest component of Z */
+/*          inv(A) is the inverse of A */
+/*          abs(Z) is the componentwise absolute value of the matrix or */
+/*             vector Z */
+/*          NZ is the maximum number of nonzeros in any row of A, plus 1 */
+/*          EPS is machine epsilon */
+
+/*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */
+/*        is incremented by SAFE1 if the i-th component of */
+/*        abs(A)*abs(X) + abs(B) is less than SAFE2. */
+
+/*        Use SLACN2 to estimate the infinity-norm of the matrix */
+/*           inv(A) * diag(W), */
+/*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */
+
+	i__2 = *n;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+	    if (work[i__] > safe2) {
+		work[i__] = (r__1 = work[*n + i__], abs(r__1)) + nz * eps * 
+			work[i__];
+	    } else {
+		work[i__] = (r__1 = work[*n + i__], abs(r__1)) + nz * eps * 
+			work[i__] + safe1;
+	    }
+/* L90: */
+	}
+
+	kase = 0;
+L100:
+	slacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], &
+		kase, isave);
+	if (kase != 0) {
+	    if (kase == 1) {
+
+/*              Multiply by diag(W)*inv(A**T). */
+
+		ssytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+			*n + 1], n, info);
+		i__2 = *n;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    work[*n + i__] = work[i__] * work[*n + i__];
+/* L110: */
+		}
+	    } else if (kase == 2) {
+
+/*              Multiply by inv(A)*diag(W). */
+
+		i__2 = *n;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    work[*n + i__] = work[i__] * work[*n + i__];
+/* L120: */
+		}
+		ssytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[
+			*n + 1], n, info);
+	    }
+	    goto L100;
+	}
+
+/*        Normalize error. */
+
+	lstres = 0.f;
+	i__2 = *n;
+	for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+	    r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], abs(r__1));
+	    lstres = f2cmax(r__2,r__3);
+/* L130: */
+	}
+	if (lstres != 0.f) {
+	    ferr[j] /= lstres;
+	}
+
+/* L140: */
+    }
+
+    return 0;
+
+/*     End of SSYRFS */
+
+} /* ssyrfs_ */
+

lapack-netlib/SRC/ssysv.c

@@ -0,0 +1,671 @@
+/* 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_n1 = -1;
+
+/* > \brief <b> SSYSV computes the solution to system of linear equations A * X = B for SY matrices</b> */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYSV + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssysv.f
+"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssysv.f
+"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssysv.f
+"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, */
+/*                         LWORK, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDA, LDB, LWORK, N, NRHS */
+/*       INTEGER            IPIV( * ) */
+/*       REAL               A( LDA, * ), B( LDB, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYSV computes the solution to a real system of linear equations */
+/* >    A * X = B, */
+/* > where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */
+/* > matrices. */
+/* > */
+/* > The diagonal pivoting method is used to factor A as */
+/* >    A = U * D * U**T,  if UPLO = 'U', or */
+/* >    A = L * D * L**T,  if UPLO = 'L', */
+/* > where U (or L) is a product of permutation and unit upper (lower) */
+/* > triangular matrices, and D is symmetric and block diagonal with */
+/* > 1-by-1 and 2-by-2 diagonal blocks.  The factored form of A is then */
+/* > used to solve the system of equations A * X = B. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of linear equations, i.e., the order of the */
+/* >          matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The number of right hand sides, i.e., the number of columns */
+/* >          of the matrix B.  NRHS >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          On entry, the symmetric matrix A.  If UPLO = 'U', the leading */
+/* >          N-by-N upper triangular part of A contains the upper */
+/* >          triangular part of the matrix A, and the strictly lower */
+/* >          triangular part of A is not referenced.  If UPLO = 'L', the */
+/* >          leading N-by-N lower triangular part of A contains the lower */
+/* >          triangular part of the matrix A, and the strictly upper */
+/* >          triangular part of A is not referenced. */
+/* > */
+/* >          On exit, if INFO = 0, the block diagonal matrix D and the */
+/* >          multipliers used to obtain the factor U or L from the */
+/* >          factorization A = U*D*U**T or A = L*D*L**T as computed by */
+/* >          SSYTRF. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges and the block structure of D, as */
+/* >          determined by SSYTRF.  If IPIV(k) > 0, then rows and columns */
+/* >          k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 */
+/* >          diagonal block.  If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, */
+/* >          then rows and columns k-1 and -IPIV(k) were interchanged and */
+/* >          D(k-1:k,k-1:k) is a 2-by-2 diagonal block.  If UPLO = 'L' and */
+/* >          IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and */
+/* >          -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 */
+/* >          diagonal block. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB,NRHS) */
+/* >          On entry, the N-by-NRHS right hand side matrix B. */
+/* >          On exit, if INFO = 0, the N-by-NRHS solution matrix X. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (MAX(1,LWORK)) */
+/* >          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The length of WORK.  LWORK >= 1, and for best performance */
+/* >          LWORK >= f2cmax(1,N*NB), where NB is the optimal blocksize for */
+/* >          SSYTRF. */
+/* >          for LWORK < N, TRS will be done with Level BLAS 2 */
+/* >          for LWORK >= N, TRS will be done with Level BLAS 3 */
+/* > */
+/* >          If LWORK = -1, then a workspace query is assumed; the routine */
+/* >          only calculates the optimal size of the WORK array, returns */
+/* >          this value as the first entry of the WORK array, and no error */
+/* >          message related to LWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit */
+/* >          < 0: if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0: if INFO = i, D(i,i) is exactly zero.  The factorization */
+/* >               has been completed, but the block diagonal matrix D is */
+/* >               exactly singular, so the solution could not be computed. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realSYsolve */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssysv_(char *uplo, integer *n, integer *nrhs, real *a, 
+	integer *lda, integer *ipiv, real *b, integer *ldb, real *work, 
+	integer *lwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+    /* Local variables */
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    integer lwkopt;
+    logical lquery;
+    extern /* Subroutine */ int ssytrf_(char *, integer *, real *, integer *, 
+	    integer *, real *, integer *, integer *), ssytrs_(char *, 
+	    integer *, integer *, real *, integer *, integer *, real *, 
+	    integer *, integer *), ssytrs2_(char *, integer *, 
+	    integer *, real *, integer *, integer *, real *, integer *, real *
+	    , integer *);
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --ipiv;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    lquery = *lwork == -1;
+    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*nrhs < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -8;
+    } else if (*lwork < 1 && ! lquery) {
+	*info = -10;
+    }
+
+    if (*info == 0) {
+	if (*n == 0) {
+	    lwkopt = 1;
+	} else {
+	    ssytrf_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], &c_n1, 
+		    info);
+	    lwkopt = work[1];
+	}
+	work[1] = (real) lwkopt;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYSV ", &i__1, (ftnlen)6);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Compute the factorization A = U*D*U**T or A = L*D*L**T. */
+
+    ssytrf_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], lwork, info);
+    if (*info == 0) {
+
+/*        Solve the system A*X = B, overwriting B with X. */
+
+	if (*lwork < *n) {
+
+/*        Solve with TRS ( Use Level BLAS 2) */
+
+	    ssytrs_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], 
+		    ldb, info);
+
+	} else {
+
+/*        Solve with TRS2 ( Use Level BLAS 3) */
+
+	    ssytrs2_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset],
+		     ldb, &work[1], info);
+
+	}
+
+    }
+
+    work[1] = (real) lwkopt;
+
+    return 0;
+
+/*     End of SSYSV */
+
+} /* ssysv_ */
+

lapack-netlib/SRC/ssysv_aa.c

@@ -0,0 +1,651 @@
+/* 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_n1 = -1;
+
+/* > \brief <b> SSYSV_AA computes the solution to system of linear equations A * X = B for SY matrices</b> */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYSV_AA + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssysv_a
+a.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssysv_a
+a.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssysv_a
+a.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYSV_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, */
+/*                            LWORK, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            N, NRHS, LDA, LDB, LWORK, INFO */
+/*       INTEGER            IPIV( * ) */
+/*       REAL               A( LDA, * ), B( LDB, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYSV computes the solution to a real system of linear equations */
+/* >    A * X = B, */
+/* > where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */
+/* > matrices. */
+/* > */
+/* > Aasen's algorithm is used to factor A as */
+/* >    A = U**T * T * U,  if UPLO = 'U', or */
+/* >    A = L * T * L**T,  if UPLO = 'L', */
+/* > where U (or L) is a product of permutation and unit upper (lower) */
+/* > triangular matrices, and T is symmetric tridiagonal. The factored */
+/* > form of A is then used to solve the system of equations A * X = B. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of linear equations, i.e., the order of the */
+/* >          matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The number of right hand sides, i.e., the number of columns */
+/* >          of the matrix B.  NRHS >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          On entry, the symmetric matrix A.  If UPLO = 'U', the leading */
+/* >          N-by-N upper triangular part of A contains the upper */
+/* >          triangular part of the matrix A, and the strictly lower */
+/* >          triangular part of A is not referenced.  If UPLO = 'L', the */
+/* >          leading N-by-N lower triangular part of A contains the lower */
+/* >          triangular part of the matrix A, and the strictly upper */
+/* >          triangular part of A is not referenced. */
+/* > */
+/* >          On exit, if INFO = 0, the tridiagonal matrix T and the */
+/* >          multipliers used to obtain the factor U or L from the */
+/* >          factorization A = U**T*T*U or A = L*T*L**T as computed by */
+/* >          SSYTRF. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          On exit, it contains the details of the interchanges, i.e., */
+/* >          the row and column k of A were interchanged with the */
+/* >          row and column IPIV(k). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB,NRHS) */
+/* >          On entry, the N-by-NRHS right hand side matrix B. */
+/* >          On exit, if INFO = 0, the N-by-NRHS solution matrix X. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (MAX(1,LWORK)) */
+/* >          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The length of WORK.  LWORK >= MAX(1,2*N,3*N-2), and for */
+/* >          the best performance, LWORK >= MAX(1,N*NB), where NB is */
+/* >          the optimal blocksize for SSYTRF_AA. */
+/* > */
+/* >          If LWORK = -1, then a workspace query is assumed; the routine */
+/* >          only calculates the optimal size of the WORK array, returns */
+/* >          this value as the first entry of the WORK array, and no error */
+/* >          message related to LWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit */
+/* >          < 0: if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0: if INFO = i, D(i,i) is exactly zero.  The factorization */
+/* >               has been completed, but the block diagonal matrix D is */
+/* >               exactly singular, so the solution could not be computed. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date November 2017 */
+
+/* > \ingroup realSYsolve */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssysv_aa_(char *uplo, integer *n, integer *nrhs, real *
+	a, integer *lda, integer *ipiv, real *b, integer *ldb, real *work, 
+	integer *lwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+
+    /* Local variables */
+    extern logical lsame_(char *, char *);
+    integer lwkopt_sytrf__, lwkopt_sytrs__;
+    extern /* Subroutine */ int ssytrf_aa_(char *, integer *, real *, 
+	    integer *, integer *, real *, integer *, integer *), 
+	    ssytrs_aa_(char *, integer *, integer *, real *, integer *, 
+	    integer *, real *, integer *, real *, integer *, integer *), xerbla_(char *, integer *, ftnlen);
+    integer lwkopt;
+    logical lquery;
+
+
+/*  -- LAPACK driver 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 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --ipiv;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    lquery = *lwork == -1;
+    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*nrhs < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -8;
+    } else /* if(complicated condition) */ {
+/* Computing MAX */
+	i__1 = *n << 1, i__2 = *n * 3 - 2;
+	if (*lwork < f2cmax(i__1,i__2) && ! lquery) {
+	    *info = -10;
+	}
+    }
+
+    if (*info == 0) {
+	ssytrf_aa_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], &c_n1, 
+		info);
+	lwkopt_sytrf__ = (integer) work[1];
+	ssytrs_aa_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], 
+		ldb, &work[1], &c_n1, info);
+	lwkopt_sytrs__ = (integer) work[1];
+	lwkopt = f2cmax(lwkopt_sytrf__,lwkopt_sytrs__);
+	work[1] = (real) lwkopt;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYSV_AA", &i__1, (ftnlen)8);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Compute the factorization A = U**T*T*U or A = L*T*L**T. */
+
+    ssytrf_aa_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], lwork, info);
+    if (*info == 0) {
+
+/*        Solve the system A*X = B, overwriting B with X. */
+
+	ssytrs_aa_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset], 
+		ldb, &work[1], lwork, info);
+
+    }
+
+    work[1] = (real) lwkopt;
+
+    return 0;
+
+/*     End of SSYSV_AA */
+
+} /* ssysv_aa__ */
+

lapack-netlib/SRC/ssysv_aa_2stage.c

@@ -0,0 +1,678 @@
+/* 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_n1 = -1;
+
+/* > \brief <b> SSYSV_AA_2STAGE computes the solution to system of linear equations A * X = B for SY matrices
+</b> */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYSV_AA_2STAGE + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssysv_a
+a_2stage.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssysv_a
+a_2stage.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssysv_a
+a_2stage.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*      SUBROUTINE SSYSV_AA_2STAGE( UPLO, N, NRHS, A, LDA, TB, LTB, */
+/*                                  IPIV, IPIV2, B, LDB, WORK, LWORK, */
+/*                                  INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            N, NRHS, LDA, LTB, LDB, LWORK, INFO */
+/*       INTEGER            IPIV( * ), IPIV2( * ) */
+/*       REAL               A( LDA, * ), TB( * ), B( LDB, *), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYSV_AA_2STAGE computes the solution to a real system of */
+/* > linear equations */
+/* >    A * X = B, */
+/* > where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */
+/* > matrices. */
+/* > */
+/* > Aasen's 2-stage algorithm is used to factor A as */
+/* >    A = U**T * T * U,  if UPLO = 'U', or */
+/* >    A = L * T * L**T,  if UPLO = 'L', */
+/* > where U (or L) is a product of permutation and unit upper (lower) */
+/* > triangular matrices, and T is symmetric and band. The matrix T is */
+/* > then LU-factored with partial pivoting. The factored form of A */
+/* > is then used to solve the system of equations A * X = B. */
+/* > */
+/* > This is the blocked version of the algorithm, calling Level 3 BLAS. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The number of right hand sides, i.e., the number of columns */
+/* >          of the matrix B.  NRHS >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          On entry, the symmetric matrix A.  If UPLO = 'U', the leading */
+/* >          N-by-N upper triangular part of A contains the upper */
+/* >          triangular part of the matrix A, and the strictly lower */
+/* >          triangular part of A is not referenced.  If UPLO = 'L', the */
+/* >          leading N-by-N lower triangular part of A contains the lower */
+/* >          triangular part of the matrix A, and the strictly upper */
+/* >          triangular part of A is not referenced. */
+/* > */
+/* >          On exit, L is stored below (or above) the subdiaonal blocks, */
+/* >          when UPLO  is 'L' (or 'U'). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] TB */
+/* > \verbatim */
+/* >          TB is REAL array, dimension (LTB) */
+/* >          On exit, details of the LU factorization of the band matrix. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LTB */
+/* > \verbatim */
+/* >          LTB is INTEGER */
+/* >          The size of the array TB. LTB >= 4*N, internally */
+/* >          used to select NB such that LTB >= (3*NB+1)*N. */
+/* > */
+/* >          If LTB = -1, then a workspace query is assumed; the */
+/* >          routine only calculates the optimal size of LTB, */
+/* >          returns this value as the first entry of TB, and */
+/* >          no error message related to LTB is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          On exit, it contains the details of the interchanges, i.e., */
+/* >          the row and column k of A were interchanged with the */
+/* >          row and column IPIV(k). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IPIV2 */
+/* > \verbatim */
+/* >          IPIV2 is INTEGER array, dimension (N) */
+/* >          On exit, it contains the details of the interchanges, i.e., */
+/* >          the row and column k of T were interchanged with the */
+/* >          row and column IPIV(k). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB,NRHS) */
+/* >          On entry, the right hand side matrix B. */
+/* >          On exit, the solution matrix X. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL workspace of size LWORK */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The size of WORK. LWORK >= N, internally used to select NB */
+/* >          such that LWORK >= N*NB. */
+/* > */
+/* >          If LWORK = -1, then a workspace query is assumed; the */
+/* >          routine only calculates the optimal size of the WORK array, */
+/* >          returns this value as the first entry of the WORK array, and */
+/* >          no error message related to LWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value. */
+/* >          > 0:  if INFO = i, band LU factorization failed on i-th column */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date November 2017 */
+
+/* > \ingroup realSYsolve */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssysv_aa_2stage_(char *uplo, integer *n, integer *nrhs, 
+	real *a, integer *lda, real *tb, integer *ltb, integer *ipiv, integer 
+	*ipiv2, real *b, integer *ldb, real *work, integer *lwork, integer *
+	info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+    /* Local variables */
+    extern /* Subroutine */ int ssytrf_aa_2stage_(char *, integer *, real *, 
+	    integer *, real *, integer *, integer *, integer *, real *, 
+	    integer *, integer *), ssytrs_aa_2stage_(char *, integer 
+	    *, integer *, real *, integer *, real *, integer *, integer *, 
+	    integer *, real *, integer *, integer *);
+    extern logical lsame_(char *, char *);
+    logical upper;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    integer lwkopt;
+    logical tquery, wquery;
+
+
+/*  -- LAPACK driver 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 */
+
+
+
+/*  ===================================================================== */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --tb;
+    --ipiv;
+    --ipiv2;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    wquery = *lwork == -1;
+    tquery = *ltb == -1;
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*nrhs < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    } else if (*ltb < *n << 2 && ! tquery) {
+	*info = -7;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -11;
+    } else if (*lwork < *n && ! wquery) {
+	*info = -13;
+    }
+
+    if (*info == 0) {
+	ssytrf_aa_2stage_(uplo, n, &a[a_offset], lda, &tb[1], &c_n1, &ipiv[1]
+		, &ipiv2[1], &work[1], &c_n1, info);
+	lwkopt = (integer) work[1];
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYSV_AA_2STAGE", &i__1, (ftnlen)15);
+	return 0;
+    } else if (wquery || tquery) {
+	return 0;
+    }
+
+
+/*     Compute the factorization A = U**T*T*U or A = L*T*L**T. */
+
+    ssytrf_aa_2stage_(uplo, n, &a[a_offset], lda, &tb[1], ltb, &ipiv[1], &
+	    ipiv2[1], &work[1], lwork, info);
+    if (*info == 0) {
+
+/*        Solve the system A*X = B, overwriting B with X. */
+
+	ssytrs_aa_2stage_(uplo, n, nrhs, &a[a_offset], lda, &tb[1], ltb, &
+		ipiv[1], &ipiv2[1], &b[b_offset], ldb, info);
+
+    }
+
+    work[1] = (real) lwkopt;
+
+    return 0;
+
+/*     End of SSYSV_AA_2STAGE */
+
+} /* ssysv_aa_2stage__ */
+

lapack-netlib/SRC/ssysv_rk.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)
+*/
+
+
+
+/* Table of constant values */
+
+static integer c_n1 = -1;
+
+/* > \brief <b> SSYSV_RK computes the solution to system of linear equations A * X = B for SY matrices</b> */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYSV_RK + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssysv_r
+k.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssysv_r
+k.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssysv_r
+k.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYSV_RK( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, */
+/*                            WORK, LWORK, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDA, LDB, LWORK, N, NRHS */
+/*       INTEGER            IPIV( * ) */
+/*       REAL               A( LDA, * ), B( LDB, * ), E( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > SSYSV_RK computes the solution to a real system of linear */
+/* > equations A * X = B, where A is an N-by-N symmetric matrix */
+/* > and X and B are N-by-NRHS matrices. */
+/* > */
+/* > The bounded Bunch-Kaufman (rook) diagonal pivoting method is used */
+/* > to factor A as */
+/* >    A = P*U*D*(U**T)*(P**T),  if UPLO = 'U', or */
+/* >    A = P*L*D*(L**T)*(P**T),  if UPLO = 'L', */
+/* > where U (or L) is unit upper (or lower) triangular matrix, */
+/* > U**T (or L**T) is the transpose of U (or L), P is a permutation */
+/* > matrix, P**T is the transpose of P, and D is symmetric and block */
+/* > diagonal with 1-by-1 and 2-by-2 diagonal blocks. */
+/* > */
+/* > SSYTRF_RK is called to compute the factorization of a real */
+/* > symmetric matrix.  The factored form of A is then used to solve */
+/* > the system of equations A * X = B by calling BLAS3 routine SSYTRS_3. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the upper or lower triangular part of the */
+/* >          symmetric matrix A is stored: */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of linear equations, i.e., the order of the */
+/* >          matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The number of right hand sides, i.e., the number of columns */
+/* >          of the matrix B.  NRHS >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          On entry, the symmetric matrix A. */
+/* >            If UPLO = 'U': the leading N-by-N upper triangular part */
+/* >            of A contains the upper triangular part of the matrix A, */
+/* >            and the strictly lower triangular part of A is not */
+/* >            referenced. */
+/* > */
+/* >            If UPLO = 'L': the leading N-by-N lower triangular part */
+/* >            of A contains the lower triangular part of the matrix A, */
+/* >            and the strictly upper triangular part of A is not */
+/* >            referenced. */
+/* > */
+/* >          On exit, if INFO = 0, diagonal of the block diagonal */
+/* >          matrix D and factors U or L  as computed by SSYTRF_RK: */
+/* >            a) ONLY diagonal elements of the symmetric block diagonal */
+/* >               matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */
+/* >               (superdiagonal (or subdiagonal) elements of D */
+/* >                are stored on exit in array E), and */
+/* >            b) If UPLO = 'U': factor U in the superdiagonal part of A. */
+/* >               If UPLO = 'L': factor L in the subdiagonal part of A. */
+/* > */
+/* >          For more info see the description of DSYTRF_RK routine. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] E */
+/* > \verbatim */
+/* >          E is REAL array, dimension (N) */
+/* >          On exit, contains the output computed by the factorization */
+/* >          routine DSYTRF_RK, i.e. the superdiagonal (or subdiagonal) */
+/* >          elements of the symmetric block diagonal matrix D */
+/* >          with 1-by-1 or 2-by-2 diagonal blocks, where */
+/* >          If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; */
+/* >          If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. */
+/* > */
+/* >          NOTE: For 1-by-1 diagonal block D(k), where */
+/* >          1 <= k <= N, the element E(k) is set to 0 in both */
+/* >          UPLO = 'U' or UPLO = 'L' cases. */
+/* > */
+/* >          For more info see the description of DSYTRF_RK routine. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges and the block structure of D, */
+/* >          as determined by SSYTRF_RK. */
+/* > */
+/* >          For more info see the description of DSYTRF_RK routine. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB,NRHS) */
+/* >          On entry, the N-by-NRHS right hand side matrix B. */
+/* >          On exit, if INFO = 0, the N-by-NRHS solution matrix X. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension ( MAX(1,LWORK) ). */
+/* >          Work array used in the factorization stage. */
+/* >          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The length of WORK.  LWORK >= 1. For best performance */
+/* >          of factorization stage LWORK >= f2cmax(1,N*NB), where NB is */
+/* >          the optimal blocksize for DSYTRF_RK. */
+/* > */
+/* >          If LWORK = -1, then a workspace query is assumed; */
+/* >          the routine only calculates the optimal size of the WORK */
+/* >          array for factorization stage, returns this value as */
+/* >          the first entry of the WORK array, and no error message */
+/* >          related to LWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit */
+/* > */
+/* >          < 0: If INFO = -k, the k-th argument had an illegal value */
+/* > */
+/* >          > 0: If INFO = k, the matrix A is singular, because: */
+/* >                 If UPLO = 'U': column k in the upper */
+/* >                 triangular part of A contains all zeros. */
+/* >                 If UPLO = 'L': column k in the lower */
+/* >                 triangular part of A contains all zeros. */
+/* > */
+/* >               Therefore D(k,k) is exactly zero, and superdiagonal */
+/* >               elements of column k of U (or subdiagonal elements of */
+/* >               column k of L ) are all zeros. The factorization has */
+/* >               been completed, but the block diagonal matrix D is */
+/* >               exactly singular, and division by zero will occur if */
+/* >               it is used to solve a system of equations. */
+/* > */
+/* >               NOTE: INFO only stores the first occurrence of */
+/* >               a singularity, any subsequent occurrence of singularity */
+/* >               is not stored in INFO even though the factorization */
+/* >               always completes. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup singleSYsolve */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  December 2016,  Igor Kozachenko, */
+/* >                  Computer Science Division, */
+/* >                  University of California, Berkeley */
+/* > */
+/* >  September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */
+/* >                  School of Mathematics, */
+/* >                  University of Manchester */
+/* > */
+/* > \endverbatim */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssysv_rk_(char *uplo, integer *n, integer *nrhs, real *
+	a, integer *lda, real *e, integer *ipiv, real *b, integer *ldb, real *
+	work, integer *lwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+    /* Local variables */
+    extern /* Subroutine */ int ssytrs_3_(char *, integer *, integer *, real 
+	    *, integer *, real *, integer *, real *, integer *, integer *);
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int ssytrf_rk_(char *, integer *, real *, 
+	    integer *, real *, integer *, real *, integer *, integer *), xerbla_(char *, integer *, ftnlen);
+    integer lwkopt;
+    logical lquery;
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --e;
+    --ipiv;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    lquery = *lwork == -1;
+    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*nrhs < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -9;
+    } else if (*lwork < 1 && ! lquery) {
+	*info = -11;
+    }
+
+    if (*info == 0) {
+	if (*n == 0) {
+	    lwkopt = 1;
+	} else {
+	    ssytrf_rk_(uplo, n, &a[a_offset], lda, &e[1], &ipiv[1], &work[1],
+		     &c_n1, info);
+	    lwkopt = work[1];
+	}
+	work[1] = (real) lwkopt;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYSV_RK ", &i__1, (ftnlen)9);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Compute the factorization A = P*U*D*(U**T)*(P**T) or */
+/*     A = P*U*D*(U**T)*(P**T). */
+
+    ssytrf_rk_(uplo, n, &a[a_offset], lda, &e[1], &ipiv[1], &work[1], lwork, 
+	    info);
+
+    if (*info == 0) {
+
+/*        Solve the system A*X = B with BLAS3 solver, overwriting B with X. */
+
+	ssytrs_3_(uplo, n, nrhs, &a[a_offset], lda, &e[1], &ipiv[1], &b[
+		b_offset], ldb, info);
+
+    }
+
+    work[1] = (real) lwkopt;
+
+    return 0;
+
+/*     End of SSYSV_RK */
+
+} /* ssysv_rk__ */
+

lapack-netlib/SRC/ssysv_rook.c

@@ -0,0 +1,692 @@
+/* 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_n1 = -1;
+
+/* > \brief <b> SSYSV_ROOK computes the solution to system of linear equations A * X = B for SY matrices</b> 
+*/
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYSV_ROOK + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssysv_r
+ook.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssysv_r
+ook.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssysv_r
+ook.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYSV_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK, */
+/*                         LWORK, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDA, LDB, LWORK, N, NRHS */
+/*       INTEGER            IPIV( * ) */
+/*       REAL               A( LDA, * ), B( LDB, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYSV_ROOK computes the solution to a real system of linear */
+/* > equations */
+/* >    A * X = B, */
+/* > where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */
+/* > matrices. */
+/* > */
+/* > The diagonal pivoting method is used to factor A as */
+/* >    A = U * D * U**T,  if UPLO = 'U', or */
+/* >    A = L * D * L**T,  if UPLO = 'L', */
+/* > where U (or L) is a product of permutation and unit upper (lower) */
+/* > triangular matrices, and D is symmetric and block diagonal with */
+/* > 1-by-1 and 2-by-2 diagonal blocks. */
+/* > */
+/* > SSYTRF_ROOK is called to compute the factorization of a real */
+/* > symmetric matrix A using the bounded Bunch-Kaufman ("rook") diagonal */
+/* > pivoting method. */
+/* > */
+/* > The factored form of A is then used to solve the system */
+/* > of equations A * X = B by calling SSYTRS_ROOK. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of linear equations, i.e., the order of the */
+/* >          matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The number of right hand sides, i.e., the number of columns */
+/* >          of the matrix B.  NRHS >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          On entry, the symmetric matrix A.  If UPLO = 'U', the leading */
+/* >          N-by-N upper triangular part of A contains the upper */
+/* >          triangular part of the matrix A, and the strictly lower */
+/* >          triangular part of A is not referenced.  If UPLO = 'L', the */
+/* >          leading N-by-N lower triangular part of A contains the lower */
+/* >          triangular part of the matrix A, and the strictly upper */
+/* >          triangular part of A is not referenced. */
+/* > */
+/* >          On exit, if INFO = 0, the block diagonal matrix D and the */
+/* >          multipliers used to obtain the factor U or L from the */
+/* >          factorization A = U*D*U**T or A = L*D*L**T as computed by */
+/* >          SSYTRF_ROOK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges and the block structure of D, */
+/* >          as determined by SSYTRF_ROOK. */
+/* > */
+/* >          If UPLO = 'U': */
+/* >               If IPIV(k) > 0, then rows and columns k and IPIV(k) */
+/* >               were interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* > */
+/* >               If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and */
+/* >               columns k and -IPIV(k) were interchanged and rows and */
+/* >               columns k-1 and -IPIV(k-1) were inerchaged, */
+/* >               D(k-1:k,k-1:k) is a 2-by-2 diagonal block. */
+/* > */
+/* >          If UPLO = 'L': */
+/* >               If IPIV(k) > 0, then rows and columns k and IPIV(k) */
+/* >               were interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* > */
+/* >               If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and */
+/* >               columns k and -IPIV(k) were interchanged and rows and */
+/* >               columns k+1 and -IPIV(k+1) were inerchaged, */
+/* >               D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB,NRHS) */
+/* >          On entry, the N-by-NRHS right hand side matrix B. */
+/* >          On exit, if INFO = 0, the N-by-NRHS solution matrix X. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (MAX(1,LWORK)) */
+/* >          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The length of WORK.  LWORK >= 1, and for best performance */
+/* >          LWORK >= f2cmax(1,N*NB), where NB is the optimal blocksize for */
+/* >          SSYTRF_ROOK. */
+/* > */
+/* >          TRS will be done with Level 2 BLAS */
+/* > */
+/* >          If LWORK = -1, then a workspace query is assumed; the routine */
+/* >          only calculates the optimal size of the WORK array, returns */
+/* >          this value as the first entry of the WORK array, and no error */
+/* >          message related to LWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit */
+/* >          < 0: if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0: if INFO = i, D(i,i) is exactly zero.  The factorization */
+/* >               has been completed, but the block diagonal matrix D is */
+/* >               exactly singular, so the solution could not be computed. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date April 2012 */
+
+/* > \ingroup realSYsolve */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >   April 2012, Igor Kozachenko, */
+/* >                  Computer Science Division, */
+/* >                  University of California, Berkeley */
+/* > */
+/* >  September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */
+/* >                  School of Mathematics, */
+/* >                  University of Manchester */
+/* > */
+/* > \endverbatim */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssysv_rook_(char *uplo, integer *n, integer *nrhs, real 
+	*a, integer *lda, integer *ipiv, real *b, integer *ldb, real *work, 
+	integer *lwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+    /* Local variables */
+    extern /* Subroutine */ int ssytrf_rook_(char *, integer *, real *, 
+	    integer *, integer *, real *, integer *, integer *), 
+	    ssytrs_rook_(char *, integer *, integer *, real *, integer *, 
+	    integer *, real *, integer *, integer *);
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    integer lwkopt;
+    logical lquery;
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     April 2012 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --ipiv;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    lquery = *lwork == -1;
+    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*nrhs < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -8;
+    } else if (*lwork < 1 && ! lquery) {
+	*info = -10;
+    }
+
+    if (*info == 0) {
+	if (*n == 0) {
+	    lwkopt = 1;
+	} else {
+	    ssytrf_rook_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], &
+		    c_n1, info);
+	    lwkopt = work[1];
+	}
+	work[1] = (real) lwkopt;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYSV_ROOK ", &i__1, (ftnlen)11);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Compute the factorization A = U*D*U**T or A = L*D*L**T. */
+
+    ssytrf_rook_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], lwork, info);
+    if (*info == 0) {
+
+/*        Solve the system A*X = B, overwriting B with X. */
+
+/*        Solve with TRS_ROOK ( Use Level 2 BLAS) */
+
+	ssytrs_rook_(uplo, n, nrhs, &a[a_offset], lda, &ipiv[1], &b[b_offset]
+		, ldb, info);
+
+    }
+
+    work[1] = (real) lwkopt;
+
+    return 0;
+
+/*     End of SSYSV_ROOK */
+
+} /* ssysv_rook__ */
+

lapack-netlib/SRC/ssysvx.c

@@ -0,0 +1,842 @@
+/* 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_n1 = -1;
+
+/* > \brief <b> SSYSVX computes the solution to system of linear equations A * X = B for SY matrices</b> */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYSVX + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssysvx.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssysvx.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssysvx.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, */
+/*                          LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK, */
+/*                          IWORK, INFO ) */
+
+/*       CHARACTER          FACT, UPLO */
+/*       INTEGER            INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS */
+/*       REAL               RCOND */
+/*       INTEGER            IPIV( * ), IWORK( * ) */
+/*       REAL               A( LDA, * ), AF( LDAF, * ), B( LDB, * ), */
+/*      $                   BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYSVX uses the diagonal pivoting factorization to compute the */
+/* > solution to a real system of linear equations A * X = B, */
+/* > where A is an N-by-N symmetric matrix and X and B are N-by-NRHS */
+/* > matrices. */
+/* > */
+/* > Error bounds on the solution and a condition estimate are also */
+/* > provided. */
+/* > \endverbatim */
+
+/* > \par Description: */
+/*  ================= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > The following steps are performed: */
+/* > */
+/* > 1. If FACT = 'N', the diagonal pivoting method is used to factor A. */
+/* >    The form of the factorization is */
+/* >       A = U * D * U**T,  if UPLO = 'U', or */
+/* >       A = L * D * L**T,  if UPLO = 'L', */
+/* >    where U (or L) is a product of permutation and unit upper (lower) */
+/* >    triangular matrices, and D is symmetric and block diagonal with */
+/* >    1-by-1 and 2-by-2 diagonal blocks. */
+/* > */
+/* > 2. If some D(i,i)=0, so that D is exactly singular, then the routine */
+/* >    returns with INFO = i. Otherwise, the factored form of A is used */
+/* >    to estimate the condition number of the matrix A.  If the */
+/* >    reciprocal of the condition number is less than machine precision, */
+/* >    INFO = N+1 is returned as a warning, but the routine still goes on */
+/* >    to solve for X and compute error bounds as described below. */
+/* > */
+/* > 3. The system of equations is solved for X using the factored form */
+/* >    of A. */
+/* > */
+/* > 4. Iterative refinement is applied to improve the computed solution */
+/* >    matrix and calculate error bounds and backward error estimates */
+/* >    for it. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] FACT */
+/* > \verbatim */
+/* >          FACT is CHARACTER*1 */
+/* >          Specifies whether or not the factored form of A has been */
+/* >          supplied on entry. */
+/* >          = 'F':  On entry, AF and IPIV contain the factored form of */
+/* >                  A.  AF and IPIV will not be modified. */
+/* >          = 'N':  The matrix A will be copied to AF and factored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The number of linear equations, i.e., the order of the */
+/* >          matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The number of right hand sides, i.e., the number of columns */
+/* >          of the matrices B and X.  NRHS >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          The symmetric matrix A.  If UPLO = 'U', the leading N-by-N */
+/* >          upper triangular part of A contains the upper triangular part */
+/* >          of the matrix A, and the strictly lower triangular part of A */
+/* >          is not referenced.  If UPLO = 'L', the leading N-by-N lower */
+/* >          triangular part of A contains the lower triangular part of */
+/* >          the matrix A, and the strictly upper triangular part of A is */
+/* >          not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] AF */
+/* > \verbatim */
+/* >          AF is REAL array, dimension (LDAF,N) */
+/* >          If FACT = 'F', then AF is an input argument and on entry */
+/* >          contains the block diagonal matrix D and the multipliers used */
+/* >          to obtain the factor U or L from the factorization */
+/* >          A = U*D*U**T or A = L*D*L**T as computed by SSYTRF. */
+/* > */
+/* >          If FACT = 'N', then AF is an output argument and on exit */
+/* >          returns the block diagonal matrix D and the multipliers used */
+/* >          to obtain the factor U or L from the factorization */
+/* >          A = U*D*U**T or A = L*D*L**T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDAF */
+/* > \verbatim */
+/* >          LDAF is INTEGER */
+/* >          The leading dimension of the array AF.  LDAF >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          If FACT = 'F', then IPIV is an input argument and on entry */
+/* >          contains details of the interchanges and the block structure */
+/* >          of D, as determined by SSYTRF. */
+/* >          If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* >          interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* >          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* >          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* >          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) = */
+/* >          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* >          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+/* > */
+/* >          If FACT = 'N', then IPIV is an output argument and on exit */
+/* >          contains details of the interchanges and the block structure */
+/* >          of D, as determined by SSYTRF. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB,NRHS) */
+/* >          The N-by-NRHS right hand side matrix B. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] X */
+/* > \verbatim */
+/* >          X is REAL array, dimension (LDX,NRHS) */
+/* >          If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDX */
+/* > \verbatim */
+/* >          LDX is INTEGER */
+/* >          The leading dimension of the array X.  LDX >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] RCOND */
+/* > \verbatim */
+/* >          RCOND is REAL */
+/* >          The estimate of the reciprocal condition number of the matrix */
+/* >          A.  If RCOND is less than the machine precision (in */
+/* >          particular, if RCOND = 0), the matrix is singular to working */
+/* >          precision.  This condition is indicated by a return code of */
+/* >          INFO > 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] FERR */
+/* > \verbatim */
+/* >          FERR is REAL array, dimension (NRHS) */
+/* >          The estimated forward error bound for each solution vector */
+/* >          X(j) (the j-th column of the solution matrix X). */
+/* >          If XTRUE is the true solution corresponding to X(j), FERR(j) */
+/* >          is an estimated upper bound for the magnitude of the largest */
+/* >          element in (X(j) - XTRUE) divided by the magnitude of the */
+/* >          largest element in X(j).  The estimate is as reliable as */
+/* >          the estimate for RCOND, and is almost always a slight */
+/* >          overestimate of the true error. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] BERR */
+/* > \verbatim */
+/* >          BERR is REAL array, dimension (NRHS) */
+/* >          The componentwise relative backward error of each solution */
+/* >          vector X(j) (i.e., the smallest relative change in */
+/* >          any element of A or B that makes X(j) an exact solution). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (MAX(1,LWORK)) */
+/* >          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The length of WORK.  LWORK >= f2cmax(1,3*N), and for best */
+/* >          performance, when FACT = 'N', LWORK >= f2cmax(1,3*N,N*NB), where */
+/* >          NB is the optimal blocksize for SSYTRF. */
+/* > */
+/* >          If LWORK = -1, then a workspace query is assumed; the routine */
+/* >          only calculates the optimal size of the WORK array, returns */
+/* >          this value as the first entry of the WORK array, and no error */
+/* >          message related to LWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit */
+/* >          < 0: if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0: if INFO = i, and i is */
+/* >                <= N:  D(i,i) is exactly zero.  The factorization */
+/* >                       has been completed but the factor D is exactly */
+/* >                       singular, so the solution and error bounds could */
+/* >                       not be computed. RCOND = 0 is returned. */
+/* >                = N+1: D is nonsingular, but RCOND is less than machine */
+/* >                       precision, meaning that the matrix is singular */
+/* >                       to working precision.  Nevertheless, the */
+/* >                       solution and error bounds are computed because */
+/* >                       there are a number of situations where the */
+/* >                       computed solution can be more accurate than the */
+/* >                       value of RCOND would suggest. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date April 2012 */
+
+/* > \ingroup realSYsolve */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssysvx_(char *fact, char *uplo, integer *n, integer *
+	nrhs, real *a, integer *lda, real *af, integer *ldaf, integer *ipiv, 
+	real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *ferr,
+	 real *berr, real *work, integer *lwork, integer *iwork, integer *
+	info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1, 
+	    x_offset, i__1, i__2;
+
+    /* Local variables */
+    extern logical lsame_(char *, char *);
+    real anorm;
+    integer nb;
+    extern real slamch_(char *);
+    logical nofact;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
+	    integer *, integer *, ftnlen, ftnlen);
+    extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, 
+	    integer *, real *, integer *);
+    extern real slansy_(char *, char *, integer *, real *, integer *, real *);
+    extern /* Subroutine */ int ssycon_(char *, integer *, real *, integer *, 
+	    integer *, real *, real *, real *, integer *, integer *);
+    integer lwkopt;
+    logical lquery;
+    extern /* Subroutine */ int ssyrfs_(char *, integer *, integer *, real *, 
+	    integer *, real *, integer *, integer *, real *, integer *, real *
+	    , integer *, real *, real *, real *, integer *, integer *)
+	    , ssytrf_(char *, integer *, real *, integer *, integer *, real *,
+	     integer *, integer *), ssytrs_(char *, integer *, 
+	    integer *, real *, integer *, integer *, real *, integer *, 
+	    integer *);
+
+
+/*  -- LAPACK driver routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     April 2012 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    af_dim1 = *ldaf;
+    af_offset = 1 + af_dim1 * 1;
+    af -= af_offset;
+    --ipiv;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    x_dim1 = *ldx;
+    x_offset = 1 + x_dim1 * 1;
+    x -= x_offset;
+    --ferr;
+    --berr;
+    --work;
+    --iwork;
+
+    /* Function Body */
+    *info = 0;
+    nofact = lsame_(fact, "N");
+    lquery = *lwork == -1;
+    if (! nofact && ! lsame_(fact, "F")) {
+	*info = -1;
+    } else if (! lsame_(uplo, "U") && ! lsame_(uplo, 
+	    "L")) {
+	*info = -2;
+    } else if (*n < 0) {
+	*info = -3;
+    } else if (*nrhs < 0) {
+	*info = -4;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -6;
+    } else if (*ldaf < f2cmax(1,*n)) {
+	*info = -8;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -11;
+    } else if (*ldx < f2cmax(1,*n)) {
+	*info = -13;
+    } else /* if(complicated condition) */ {
+/* Computing MAX */
+	i__1 = 1, i__2 = *n * 3;
+	if (*lwork < f2cmax(i__1,i__2) && ! lquery) {
+	    *info = -18;
+	}
+    }
+
+    if (*info == 0) {
+/* Computing MAX */
+	i__1 = 1, i__2 = *n * 3;
+	lwkopt = f2cmax(i__1,i__2);
+	if (nofact) {
+	    nb = ilaenv_(&c__1, "SSYTRF", uplo, n, &c_n1, &c_n1, &c_n1, (
+		    ftnlen)6, (ftnlen)1);
+/* Computing MAX */
+	    i__1 = lwkopt, i__2 = *n * nb;
+	    lwkopt = f2cmax(i__1,i__2);
+	}
+	work[1] = (real) lwkopt;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYSVX", &i__1, (ftnlen)6);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+    if (nofact) {
+
+/*        Compute the factorization A = U*D*U**T or A = L*D*L**T. */
+
+	slacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
+	ssytrf_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &work[1], lwork, 
+		info);
+
+/*        Return if INFO is non-zero. */
+
+	if (*info > 0) {
+	    *rcond = 0.f;
+	    return 0;
+	}
+    }
+
+/*     Compute the norm of the matrix A. */
+
+    anorm = slansy_("I", uplo, n, &a[a_offset], lda, &work[1]);
+
+/*     Compute the reciprocal of the condition number of A. */
+
+    ssycon_(uplo, n, &af[af_offset], ldaf, &ipiv[1], &anorm, rcond, &work[1], 
+	    &iwork[1], info);
+
+/*     Compute the solution vectors X. */
+
+    slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
+    ssytrs_(uplo, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx, 
+	    info);
+
+/*     Use iterative refinement to improve the computed solutions and */
+/*     compute error bounds and backward error estimates for them. */
+
+    ssyrfs_(uplo, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1], 
+	    &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[1]
+	    , &iwork[1], info);
+
+/*     Set INFO = N+1 if the matrix is singular to working precision. */
+
+    if (*rcond < slamch_("Epsilon")) {
+	*info = *n + 1;
+    }
+
+    work[1] = (real) lwkopt;
+
+    return 0;
+
+/*     End of SSYSVX */
+
+} /* ssysvx_ */
+

lapack-netlib/SRC/ssyswapr.c

@@ -0,0 +1,593 @@
+/* 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;
+
+/* > \brief \b SSYSWAPR applies an elementary permutation on the rows and columns of a symmetric matrix. */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYSWAPR + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssyswap
+r.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssyswap
+r.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssyswap
+r.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYSWAPR( UPLO, N, A, LDA, I1, I2) */
+
+/*       CHARACTER        UPLO */
+/*       INTEGER          I1, I2, LDA, N */
+/*       REAL             A( LDA, N ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYSWAPR applies an elementary permutation on the rows and the columns of */
+/* > a symmetric matrix. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the details of the factorization are stored */
+/* >          as an upper or lower triangular matrix. */
+/* >          = 'U':  Upper triangular, form is A = U*D*U**T; */
+/* >          = 'L':  Lower triangular, form is A = L*D*L**T. */
+/* > \endverbatim */
+/* > */
+/* > \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 NB diagonal matrix D and the multipliers */
+/* >          used to obtain the factor U or L as computed by SSYTRF. */
+/* > */
+/* >          On exit, if INFO = 0, the (symmetric) inverse of the original */
+/* >          matrix.  If UPLO = 'U', the upper triangular part of the */
+/* >          inverse is formed and the part of A below the diagonal is not */
+/* >          referenced; if UPLO = 'L' the lower triangular part of the */
+/* >          inverse is formed and the part of A above the diagonal is */
+/* >          not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] I1 */
+/* > \verbatim */
+/* >          I1 is INTEGER */
+/* >          Index of the first row to swap */
+/* > \endverbatim */
+/* > */
+/* > \param[in] I2 */
+/* > \verbatim */
+/* >          I2 is INTEGER */
+/* >          Index of the second row to swap */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realSYauxiliary */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssyswapr_(char *uplo, integer *n, real *a, integer *lda, 
+	integer *i1, integer *i2)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1;
+
+    /* Local variables */
+    integer i__;
+    extern logical lsame_(char *, char *);
+    logical upper;
+    extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, 
+	    integer *);
+    real tmp;
+
+
+/*  -- 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;
+
+    /* Function Body */
+    upper = lsame_(uplo, "U");
+    if (upper) {
+
+/*         UPPER */
+/*         first swap */
+/*          - swap column I1 and I2 from I1 to I1-1 */
+	i__1 = *i1 - 1;
+	sswap_(&i__1, &a[*i1 * a_dim1 + 1], &c__1, &a[*i2 * a_dim1 + 1], &
+		c__1);
+
+/*          second swap : */
+/*          - swap A(I1,I1) and A(I2,I2) */
+/*          - swap row I1 from I1+1 to I2-1 with col I2 from I1+1 to I2-1 */
+	tmp = a[*i1 + *i1 * a_dim1];
+	a[*i1 + *i1 * a_dim1] = a[*i2 + *i2 * a_dim1];
+	a[*i2 + *i2 * a_dim1] = tmp;
+
+	i__1 = *i2 - *i1 - 1;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    tmp = a[*i1 + (*i1 + i__) * a_dim1];
+	    a[*i1 + (*i1 + i__) * a_dim1] = a[*i1 + i__ + *i2 * a_dim1];
+	    a[*i1 + i__ + *i2 * a_dim1] = tmp;
+	}
+
+/*          third swap */
+/*          - swap row I1 and I2 from I2+1 to N */
+	i__1 = *n;
+	for (i__ = *i2 + 1; i__ <= i__1; ++i__) {
+	    tmp = a[*i1 + i__ * a_dim1];
+	    a[*i1 + i__ * a_dim1] = a[*i2 + i__ * a_dim1];
+	    a[*i2 + i__ * a_dim1] = tmp;
+	}
+
+    } else {
+
+/*         LOWER */
+/*         first swap */
+/*          - swap row I1 and I2 from I1 to I1-1 */
+	i__1 = *i1 - 1;
+	sswap_(&i__1, &a[*i1 + a_dim1], lda, &a[*i2 + a_dim1], lda);
+
+/*         second swap : */
+/*          - swap A(I1,I1) and A(I2,I2) */
+/*          - swap col I1 from I1+1 to I2-1 with row I2 from I1+1 to I2-1 */
+	tmp = a[*i1 + *i1 * a_dim1];
+	a[*i1 + *i1 * a_dim1] = a[*i2 + *i2 * a_dim1];
+	a[*i2 + *i2 * a_dim1] = tmp;
+
+	i__1 = *i2 - *i1 - 1;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    tmp = a[*i1 + i__ + *i1 * a_dim1];
+	    a[*i1 + i__ + *i1 * a_dim1] = a[*i2 + (*i1 + i__) * a_dim1];
+	    a[*i2 + (*i1 + i__) * a_dim1] = tmp;
+	}
+
+/*         third swap */
+/*          - swap col I1 and I2 from I2+1 to N */
+	i__1 = *n;
+	for (i__ = *i2 + 1; i__ <= i__1; ++i__) {
+	    tmp = a[i__ + *i1 * a_dim1];
+	    a[i__ + *i1 * a_dim1] = a[i__ + *i2 * a_dim1];
+	    a[i__ + *i2 * a_dim1] = tmp;
+	}
+
+    }
+    return 0;
+} /* ssyswapr_ */
+

lapack-netlib/SRC/ssytd2.c

@@ -0,0 +1,736 @@
+/* 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 real c_b8 = 0.f;
+static real c_b14 = -1.f;
+
+/* > \brief \b SSYTD2 reduces a symmetric matrix to real symmetric tridiagonal form by an orthogonal similarit
+y transformation (unblocked algorithm). */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYTD2 + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytd2.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytd2.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytd2.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDA, N */
+/*       REAL               A( LDA, * ), D( * ), E( * ), TAU( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal */
+/* > form T by an orthogonal similarity transformation: Q**T * A * Q = T. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the upper or lower triangular part of the */
+/* >          symmetric matrix A is stored: */
+/* >          = 'U':  Upper triangular */
+/* >          = 'L':  Lower triangular */
+/* > \endverbatim */
+/* > */
+/* > \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 symmetric matrix A.  If UPLO = 'U', the leading */
+/* >          n-by-n upper triangular part of A contains the upper */
+/* >          triangular part of the matrix A, and the strictly lower */
+/* >          triangular part of A is not referenced.  If UPLO = 'L', the */
+/* >          leading n-by-n lower triangular part of A contains the lower */
+/* >          triangular part of the matrix A, and the strictly upper */
+/* >          triangular part of A is not referenced. */
+/* >          On exit, if UPLO = 'U', the diagonal and first superdiagonal */
+/* >          of A are overwritten by the corresponding elements of the */
+/* >          tridiagonal matrix T, and the elements above the first */
+/* >          superdiagonal, with the array TAU, represent the orthogonal */
+/* >          matrix Q as a product of elementary reflectors; if UPLO */
+/* >          = 'L', the diagonal and first subdiagonal of A are over- */
+/* >          written by the corresponding elements of the tridiagonal */
+/* >          matrix T, and the elements below the first subdiagonal, with */
+/* >          the array TAU, represent the orthogonal matrix Q as a product */
+/* >          of elementary reflectors. See Further Details. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] D */
+/* > \verbatim */
+/* >          D is REAL array, dimension (N) */
+/* >          The diagonal elements of the tridiagonal matrix T: */
+/* >          D(i) = A(i,i). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] E */
+/* > \verbatim */
+/* >          E is REAL array, dimension (N-1) */
+/* >          The off-diagonal elements of the tridiagonal matrix T: */
+/* >          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] TAU */
+/* > \verbatim */
+/* >          TAU is REAL array, dimension (N-1) */
+/* >          The scalar factors of the elementary reflectors (see Further */
+/* >          Details). */
+/* > \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 realSYcomputational */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  If UPLO = 'U', the matrix Q is represented as a product of elementary */
+/* >  reflectors */
+/* > */
+/* >     Q = H(n-1) . . . H(2) H(1). */
+/* > */
+/* >  Each H(i) has the form */
+/* > */
+/* >     H(i) = I - tau * v * v**T */
+/* > */
+/* >  where tau is a real scalar, and v is a real vector with */
+/* >  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */
+/* >  A(1:i-1,i+1), and tau in TAU(i). */
+/* > */
+/* >  If UPLO = 'L', the matrix Q is represented as a product of elementary */
+/* >  reflectors */
+/* > */
+/* >     Q = H(1) H(2) . . . H(n-1). */
+/* > */
+/* >  Each H(i) has the form */
+/* > */
+/* >     H(i) = I - tau * v * v**T */
+/* > */
+/* >  where tau is a real scalar, and v is a real vector with */
+/* >  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */
+/* >  and tau in TAU(i). */
+/* > */
+/* >  The contents of A on exit are illustrated by the following examples */
+/* >  with n = 5: */
+/* > */
+/* >  if UPLO = 'U':                       if UPLO = 'L': */
+/* > */
+/* >    (  d   e   v2  v3  v4 )              (  d                  ) */
+/* >    (      d   e   v3  v4 )              (  e   d              ) */
+/* >    (          d   e   v4 )              (  v1  e   d          ) */
+/* >    (              d   e  )              (  v1  v2  e   d      ) */
+/* >    (                  d  )              (  v1  v2  v3  e   d  ) */
+/* > */
+/* >  where d and e denote diagonal and off-diagonal elements of T, and vi */
+/* >  denotes an element of the vector defining H(i). */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int ssytd2_(char *uplo, integer *n, real *a, integer *lda, 
+	real *d__, real *e, real *tau, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+
+    /* Local variables */
+    real taui;
+    extern real sdot_(integer *, real *, integer *, real *, integer *);
+    integer i__;
+    extern /* Subroutine */ int ssyr2_(char *, integer *, real *, real *, 
+	    integer *, real *, integer *, real *, integer *);
+    real alpha;
+    extern logical lsame_(char *, char *);
+    logical upper;
+    extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, 
+	    real *, integer *), ssymv_(char *, integer *, real *, real *, 
+	    integer *, real *, integer *, real *, real *, integer *), 
+	    xerbla_(char *, integer *, ftnlen), slarfg_(integer *, real *, 
+	    real *, integer *, real *);
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --d__;
+    --e;
+    --tau;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -4;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYTD2", &i__1, (ftnlen)6);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n <= 0) {
+	return 0;
+    }
+
+    if (upper) {
+
+/*        Reduce the upper triangle of A */
+
+	for (i__ = *n - 1; i__ >= 1; --i__) {
+
+/*           Generate elementary reflector H(i) = I - tau * v * v**T */
+/*           to annihilate A(1:i-1,i+1) */
+
+	    slarfg_(&i__, &a[i__ + (i__ + 1) * a_dim1], &a[(i__ + 1) * a_dim1 
+		    + 1], &c__1, &taui);
+	    e[i__] = a[i__ + (i__ + 1) * a_dim1];
+
+	    if (taui != 0.f) {
+
+/*              Apply H(i) from both sides to A(1:i,1:i) */
+
+		a[i__ + (i__ + 1) * a_dim1] = 1.f;
+
+/*              Compute  x := tau * A * v  storing x in TAU(1:i) */
+
+		ssymv_(uplo, &i__, &taui, &a[a_offset], lda, &a[(i__ + 1) * 
+			a_dim1 + 1], &c__1, &c_b8, &tau[1], &c__1);
+
+/*              Compute  w := x - 1/2 * tau * (x**T * v) * v */
+
+		alpha = taui * -.5f * sdot_(&i__, &tau[1], &c__1, &a[(i__ + 1)
+			 * a_dim1 + 1], &c__1);
+		saxpy_(&i__, &alpha, &a[(i__ + 1) * a_dim1 + 1], &c__1, &tau[
+			1], &c__1);
+
+/*              Apply the transformation as a rank-2 update: */
+/*                 A := A - v * w**T - w * v**T */
+
+		ssyr2_(uplo, &i__, &c_b14, &a[(i__ + 1) * a_dim1 + 1], &c__1, 
+			&tau[1], &c__1, &a[a_offset], lda);
+
+		a[i__ + (i__ + 1) * a_dim1] = e[i__];
+	    }
+	    d__[i__ + 1] = a[i__ + 1 + (i__ + 1) * a_dim1];
+	    tau[i__] = taui;
+/* L10: */
+	}
+	d__[1] = a[a_dim1 + 1];
+    } else {
+
+/*        Reduce the lower triangle of A */
+
+	i__1 = *n - 1;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+
+/*           Generate elementary reflector H(i) = I - tau * v * v**T */
+/*           to annihilate A(i+2:n,i) */
+
+	    i__2 = *n - i__;
+/* Computing MIN */
+	    i__3 = i__ + 2;
+	    slarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[f2cmin(i__3,*n) + i__ *
+		     a_dim1], &c__1, &taui);
+	    e[i__] = a[i__ + 1 + i__ * a_dim1];
+
+	    if (taui != 0.f) {
+
+/*              Apply H(i) from both sides to A(i+1:n,i+1:n) */
+
+		a[i__ + 1 + i__ * a_dim1] = 1.f;
+
+/*              Compute  x := tau * A * v  storing y in TAU(i:n-1) */
+
+		i__2 = *n - i__;
+		ssymv_(uplo, &i__2, &taui, &a[i__ + 1 + (i__ + 1) * a_dim1], 
+			lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b8, &tau[
+			i__], &c__1);
+
+/*              Compute  w := x - 1/2 * tau * (x**T * v) * v */
+
+		i__2 = *n - i__;
+		alpha = taui * -.5f * sdot_(&i__2, &tau[i__], &c__1, &a[i__ + 
+			1 + i__ * a_dim1], &c__1);
+		i__2 = *n - i__;
+		saxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[
+			i__], &c__1);
+
+/*              Apply the transformation as a rank-2 update: */
+/*                 A := A - v * w**T - w * v**T */
+
+		i__2 = *n - i__;
+		ssyr2_(uplo, &i__2, &c_b14, &a[i__ + 1 + i__ * a_dim1], &c__1,
+			 &tau[i__], &c__1, &a[i__ + 1 + (i__ + 1) * a_dim1], 
+			lda);
+
+		a[i__ + 1 + i__ * a_dim1] = e[i__];
+	    }
+	    d__[i__] = a[i__ + i__ * a_dim1];
+	    tau[i__] = taui;
+/* L20: */
+	}
+	d__[*n] = a[*n + *n * a_dim1];
+    }
+
+    return 0;
+
+/*     End of SSYTD2 */
+
+} /* ssytd2_ */
+

lapack-netlib/SRC/ssytrd.c

@@ -0,0 +1,805 @@
+/* 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_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+static real c_b22 = -1.f;
+static real c_b23 = 1.f;
+
+/* > \brief \b SSYTRD */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYTRD + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytrd.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytrd.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytrd.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDA, LWORK, N */
+/*       REAL               A( LDA, * ), D( * ), E( * ), TAU( * ), */
+/*      $                   WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYTRD reduces a real symmetric matrix A to real symmetric */
+/* > tridiagonal form T by an orthogonal similarity transformation: */
+/* > Q**T * A * Q = T. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \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 symmetric matrix A.  If UPLO = 'U', the leading */
+/* >          N-by-N upper triangular part of A contains the upper */
+/* >          triangular part of the matrix A, and the strictly lower */
+/* >          triangular part of A is not referenced.  If UPLO = 'L', the */
+/* >          leading N-by-N lower triangular part of A contains the lower */
+/* >          triangular part of the matrix A, and the strictly upper */
+/* >          triangular part of A is not referenced. */
+/* >          On exit, if UPLO = 'U', the diagonal and first superdiagonal */
+/* >          of A are overwritten by the corresponding elements of the */
+/* >          tridiagonal matrix T, and the elements above the first */
+/* >          superdiagonal, with the array TAU, represent the orthogonal */
+/* >          matrix Q as a product of elementary reflectors; if UPLO */
+/* >          = 'L', the diagonal and first subdiagonal of A are over- */
+/* >          written by the corresponding elements of the tridiagonal */
+/* >          matrix T, and the elements below the first subdiagonal, with */
+/* >          the array TAU, represent the orthogonal matrix Q as a product */
+/* >          of elementary reflectors. See Further Details. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] D */
+/* > \verbatim */
+/* >          D is REAL array, dimension (N) */
+/* >          The diagonal elements of the tridiagonal matrix T: */
+/* >          D(i) = A(i,i). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] E */
+/* > \verbatim */
+/* >          E is REAL array, dimension (N-1) */
+/* >          The off-diagonal elements of the tridiagonal matrix T: */
+/* >          E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] TAU */
+/* > \verbatim */
+/* >          TAU is REAL array, dimension (N-1) */
+/* >          The scalar factors of the elementary reflectors (see Further */
+/* >          Details). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (MAX(1,LWORK)) */
+/* >          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The dimension of the array WORK.  LWORK >= 1. */
+/* >          For optimum performance LWORK >= N*NB, where NB is the */
+/* >          optimal blocksize. */
+/* > */
+/* >          If LWORK = -1, then a workspace query is assumed; the routine */
+/* >          only calculates the optimal size of the WORK array, returns */
+/* >          this value as the first entry of the WORK array, and no error */
+/* >          message related to LWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realSYcomputational */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  If UPLO = 'U', the matrix Q is represented as a product of elementary */
+/* >  reflectors */
+/* > */
+/* >     Q = H(n-1) . . . H(2) H(1). */
+/* > */
+/* >  Each H(i) has the form */
+/* > */
+/* >     H(i) = I - tau * v * v**T */
+/* > */
+/* >  where tau is a real scalar, and v is a real vector with */
+/* >  v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in */
+/* >  A(1:i-1,i+1), and tau in TAU(i). */
+/* > */
+/* >  If UPLO = 'L', the matrix Q is represented as a product of elementary */
+/* >  reflectors */
+/* > */
+/* >     Q = H(1) H(2) . . . H(n-1). */
+/* > */
+/* >  Each H(i) has the form */
+/* > */
+/* >     H(i) = I - tau * v * v**T */
+/* > */
+/* >  where tau is a real scalar, and v is a real vector with */
+/* >  v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i), */
+/* >  and tau in TAU(i). */
+/* > */
+/* >  The contents of A on exit are illustrated by the following examples */
+/* >  with n = 5: */
+/* > */
+/* >  if UPLO = 'U':                       if UPLO = 'L': */
+/* > */
+/* >    (  d   e   v2  v3  v4 )              (  d                  ) */
+/* >    (      d   e   v3  v4 )              (  e   d              ) */
+/* >    (          d   e   v4 )              (  v1  e   d          ) */
+/* >    (              d   e  )              (  v1  v2  e   d      ) */
+/* >    (                  d  )              (  v1  v2  v3  e   d  ) */
+/* > */
+/* >  where d and e denote diagonal and off-diagonal elements of T, and vi */
+/* >  denotes an element of the vector defining H(i). */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int ssytrd_(char *uplo, integer *n, real *a, integer *lda, 
+	real *d__, real *e, real *tau, real *work, integer *lwork, integer *
+	info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+
+    /* Local variables */
+    integer i__, j;
+    extern logical lsame_(char *, char *);
+    integer nbmin, iinfo;
+    logical upper;
+    integer nb, kk;
+    extern /* Subroutine */ int ssytd2_(char *, integer *, real *, integer *, 
+	    real *, real *, real *, integer *), ssyr2k_(char *, char *
+	    , integer *, integer *, real *, real *, integer *, real *, 
+	    integer *, real *, real *, integer *);
+    integer nx;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
+	    integer *, integer *, ftnlen, ftnlen);
+    extern /* Subroutine */ int slatrd_(char *, integer *, integer *, real *, 
+	    integer *, real *, real *, real *, integer *);
+    integer ldwork, lwkopt;
+    logical lquery;
+    integer iws;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --d__;
+    --e;
+    --tau;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    lquery = *lwork == -1;
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -4;
+    } else if (*lwork < 1 && ! lquery) {
+	*info = -9;
+    }
+
+    if (*info == 0) {
+
+/*        Determine the block size. */
+
+	nb = ilaenv_(&c__1, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
+		 (ftnlen)1);
+	lwkopt = *n * nb;
+	work[1] = (real) lwkopt;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYTRD", &i__1,(ftnlen)6);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	work[1] = 1.f;
+	return 0;
+    }
+
+    nx = *n;
+    iws = 1;
+    if (nb > 1 && nb < *n) {
+
+/*        Determine when to cross over from blocked to unblocked code */
+/*        (last block is always handled by unblocked code). */
+
+/* Computing MAX */
+	i__1 = nb, i__2 = ilaenv_(&c__3, "SSYTRD", uplo, n, &c_n1, &c_n1, &
+		c_n1, (ftnlen)6, (ftnlen)1);
+	nx = f2cmax(i__1,i__2);
+	if (nx < *n) {
+
+/*           Determine if workspace is large enough for blocked code. */
+
+	    ldwork = *n;
+	    iws = ldwork * nb;
+	    if (*lwork < iws) {
+
+/*              Not enough workspace to use optimal NB:  determine the */
+/*              minimum value of NB, and reduce NB or force use of */
+/*              unblocked code by setting NX = N. */
+
+/* Computing MAX */
+		i__1 = *lwork / ldwork;
+		nb = f2cmax(i__1,1);
+		nbmin = ilaenv_(&c__2, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1,
+			 (ftnlen)6, (ftnlen)1);
+		if (nb < nbmin) {
+		    nx = *n;
+		}
+	    }
+	} else {
+	    nx = *n;
+	}
+    } else {
+	nb = 1;
+    }
+
+    if (upper) {
+
+/*        Reduce the upper triangle of A. */
+/*        Columns 1:kk are handled by the unblocked method. */
+
+	kk = *n - (*n - nx + nb - 1) / nb * nb;
+	i__1 = kk + 1;
+	i__2 = -nb;
+	for (i__ = *n - nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += 
+		i__2) {
+
+/*           Reduce columns i:i+nb-1 to tridiagonal form and form the */
+/*           matrix W which is needed to update the unreduced part of */
+/*           the matrix */
+
+	    i__3 = i__ + nb - 1;
+	    slatrd_(uplo, &i__3, &nb, &a[a_offset], lda, &e[1], &tau[1], &
+		    work[1], &ldwork);
+
+/*           Update the unreduced submatrix A(1:i-1,1:i-1), using an */
+/*           update of the form:  A := A - V*W**T - W*V**T */
+
+	    i__3 = i__ - 1;
+	    ssyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a[i__ * a_dim1 
+		    + 1], lda, &work[1], &ldwork, &c_b23, &a[a_offset], lda);
+
+/*           Copy superdiagonal elements back into A, and diagonal */
+/*           elements into D */
+
+	    i__3 = i__ + nb - 1;
+	    for (j = i__; j <= i__3; ++j) {
+		a[j - 1 + j * a_dim1] = e[j - 1];
+		d__[j] = a[j + j * a_dim1];
+/* L10: */
+	    }
+/* L20: */
+	}
+
+/*        Use unblocked code to reduce the last or only block */
+
+	ssytd2_(uplo, &kk, &a[a_offset], lda, &d__[1], &e[1], &tau[1], &iinfo);
+    } else {
+
+/*        Reduce the lower triangle of A */
+
+	i__2 = *n - nx;
+	i__1 = nb;
+	for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
+
+/*           Reduce columns i:i+nb-1 to tridiagonal form and form the */
+/*           matrix W which is needed to update the unreduced part of */
+/*           the matrix */
+
+	    i__3 = *n - i__ + 1;
+	    slatrd_(uplo, &i__3, &nb, &a[i__ + i__ * a_dim1], lda, &e[i__], &
+		    tau[i__], &work[1], &ldwork);
+
+/*           Update the unreduced submatrix A(i+ib:n,i+ib:n), using */
+/*           an update of the form:  A := A - V*W**T - W*V**T */
+
+	    i__3 = *n - i__ - nb + 1;
+	    ssyr2k_(uplo, "No transpose", &i__3, &nb, &c_b22, &a[i__ + nb + 
+		    i__ * a_dim1], lda, &work[nb + 1], &ldwork, &c_b23, &a[
+		    i__ + nb + (i__ + nb) * a_dim1], lda);
+
+/*           Copy subdiagonal elements back into A, and diagonal */
+/*           elements into D */
+
+	    i__3 = i__ + nb - 1;
+	    for (j = i__; j <= i__3; ++j) {
+		a[j + 1 + j * a_dim1] = e[j];
+		d__[j] = a[j + j * a_dim1];
+/* L30: */
+	    }
+/* L40: */
+	}
+
+/*        Use unblocked code to reduce the last or only block */
+
+	i__1 = *n - i__ + 1;
+	ssytd2_(uplo, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], 
+		&tau[i__], &iinfo);
+    }
+
+    work[1] = (real) lwkopt;
+    return 0;
+
+/*     End of SSYTRD */
+
+} /* ssytrd_ */
+

lapack-netlib/SRC/ssytrd_2stage.c

@@ -0,0 +1,743 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define 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_n1 = -1;
+static integer c__2 = 2;
+static integer c__3 = 3;
+static integer c__4 = 4;
+
+/* > \brief \b SSYTRD_2STAGE */
+
+/*  @generated from zhetrd_2stage.f, fortran z -> s, Sun Nov  6 19:34:06 2016 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYTRD_2STAGE + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytrd_
+2stage.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytrd_
+2stage.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytrd_
+2stage.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYTRD_2STAGE( VECT, UPLO, N, A, LDA, D, E, TAU, */
+/*                                 HOUS2, LHOUS2, WORK, LWORK, INFO ) */
+
+/*       IMPLICIT NONE */
+
+/*       CHARACTER          VECT, UPLO */
+/*       INTEGER            N, LDA, LWORK, LHOUS2, INFO */
+/*       REAL               D( * ), E( * ) */
+/*       REAL               A( LDA, * ), TAU( * ), */
+/*                          HOUS2( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYTRD_2STAGE reduces a real symmetric matrix A to real symmetric */
+/* > tridiagonal form T by a orthogonal similarity transformation: */
+/* > Q1**T Q2**T* A * Q2 * Q1 = T. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] VECT */
+/* > \verbatim */
+/* >          VECT is CHARACTER*1 */
+/* >          = 'N':  No need for the Housholder representation, */
+/* >                  in particular for the second stage (Band to */
+/* >                  tridiagonal) and thus LHOUS2 is of size f2cmax(1, 4*N); */
+/* >          = 'V':  the Householder representation is needed to */
+/* >                  either generate Q1 Q2 or to apply Q1 Q2, */
+/* >                  then LHOUS2 is to be queried and computed. */
+/* >                  (NOT AVAILABLE IN THIS RELEASE). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \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 symmetric matrix A.  If UPLO = 'U', the leading */
+/* >          N-by-N upper triangular part of A contains the upper */
+/* >          triangular part of the matrix A, and the strictly lower */
+/* >          triangular part of A is not referenced.  If UPLO = 'L', the */
+/* >          leading N-by-N lower triangular part of A contains the lower */
+/* >          triangular part of the matrix A, and the strictly upper */
+/* >          triangular part of A is not referenced. */
+/* >          On exit, if UPLO = 'U', the band superdiagonal */
+/* >          of A are overwritten by the corresponding elements of the */
+/* >          internal band-diagonal matrix AB, and the elements above */
+/* >          the KD superdiagonal, with the array TAU, represent the orthogonal */
+/* >          matrix Q1 as a product of elementary reflectors; if UPLO */
+/* >          = 'L', the diagonal and band subdiagonal of A are over- */
+/* >          written by the corresponding elements of the internal band-diagonal */
+/* >          matrix AB, and the elements below the KD subdiagonal, with */
+/* >          the array TAU, represent the orthogonal matrix Q1 as a product */
+/* >          of elementary reflectors. See Further Details. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] D */
+/* > \verbatim */
+/* >          D is REAL array, dimension (N) */
+/* >          The diagonal elements of the tridiagonal matrix T. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] E */
+/* > \verbatim */
+/* >          E is REAL array, dimension (N-1) */
+/* >          The off-diagonal elements of the tridiagonal matrix T. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] TAU */
+/* > \verbatim */
+/* >          TAU is REAL array, dimension (N-KD) */
+/* >          The scalar factors of the elementary reflectors of */
+/* >          the first stage (see Further Details). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] HOUS2 */
+/* > \verbatim */
+/* >          HOUS2 is REAL array, dimension (LHOUS2) */
+/* >          Stores the Householder representation of the stage2 */
+/* >          band to tridiagonal. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LHOUS2 */
+/* > \verbatim */
+/* >          LHOUS2 is INTEGER */
+/* >          The dimension of the array HOUS2. */
+/* >          If LWORK = -1, or LHOUS2 = -1, */
+/* >          then a query is assumed; the routine */
+/* >          only calculates the optimal size of the HOUS2 array, returns */
+/* >          this value as the first entry of the HOUS2 array, and no error */
+/* >          message related to LHOUS2 is issued by XERBLA. */
+/* >          If VECT='N', LHOUS2 = f2cmax(1, 4*n); */
+/* >          if VECT='V', option not yet available. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (LWORK) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The dimension of the array WORK. LWORK = MAX(1, dimension) */
+/* >          If LWORK = -1, or LHOUS2=-1, */
+/* >          then a workspace query is assumed; the routine */
+/* >          only calculates the optimal size of the WORK array, returns */
+/* >          this value as the first entry of the WORK array, and no error */
+/* >          message related to LWORK is issued by XERBLA. */
+/* >          LWORK = MAX(1, dimension) where */
+/* >          dimension   = f2cmax(stage1,stage2) + (KD+1)*N */
+/* >                      = N*KD + N*f2cmax(KD+1,FACTOPTNB) */
+/* >                        + f2cmax(2*KD*KD, KD*NTHREADS) */
+/* >                        + (KD+1)*N */
+/* >          where KD is the blocking size of the reduction, */
+/* >          FACTOPTNB is the blocking used by the QR or LQ */
+/* >          algorithm, usually FACTOPTNB=128 is a good choice */
+/* >          NTHREADS is the number of threads used when */
+/* >          openMP compilation is enabled, otherwise =1. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date November 2017 */
+
+/* > \ingroup realSYcomputational */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  Implemented by Azzam Haidar. */
+/* > */
+/* >  All details are available on technical report, SC11, SC13 papers. */
+/* > */
+/* >  Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */
+/* >  Parallel reduction to condensed forms for symmetric eigenvalue problems */
+/* >  using aggregated fine-grained and memory-aware kernels. In Proceedings */
+/* >  of 2011 International Conference for High Performance Computing, */
+/* >  Networking, Storage and Analysis (SC '11), New York, NY, USA, */
+/* >  Article 8 , 11 pages. */
+/* >  http://doi.acm.org/10.1145/2063384.2063394 */
+/* > */
+/* >  A. Haidar, J. Kurzak, P. Luszczek, 2013. */
+/* >  An improved parallel singular value algorithm and its implementation */
+/* >  for multicore hardware, In Proceedings of 2013 International Conference */
+/* >  for High Performance Computing, Networking, Storage and Analysis (SC '13). */
+/* >  Denver, Colorado, USA, 2013. */
+/* >  Article 90, 12 pages. */
+/* >  http://doi.acm.org/10.1145/2503210.2503292 */
+/* > */
+/* >  A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */
+/* >  A novel hybrid CPU-GPU generalized eigensolver for electronic structure */
+/* >  calculations based on fine-grained memory aware tasks. */
+/* >  International Journal of High Performance Computing Applications. */
+/* >  Volume 28 Issue 2, Pages 196-209, May 2014. */
+/* >  http://hpc.sagepub.com/content/28/2/196 */
+/* > */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int ssytrd_2stage_(char *vect, char *uplo, integer *n, real 
+	*a, integer *lda, real *d__, real *e, real *tau, real *hous2, integer 
+	*lhous2, real *work, integer *lwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1;
+
+    /* Local variables */
+    integer ldab;
+    extern integer ilaenv2stage_(integer *, char *, char *, integer *, 
+	    integer *, integer *, integer *);
+    integer lwrk, wpos;
+    extern /* Subroutine */ int ssytrd_sb2st_(char *, char *, char *, 
+	    integer *, integer *, real *, integer *, real *, real *, real *, 
+	    integer *, real *, integer *, integer *), 
+	    ssytrd_sy2sb_(char *, integer *, integer *, real *, integer *, 
+	    real *, integer *, real *, real *, integer *, integer *);
+    extern logical lsame_(char *, char *);
+    integer abpos, lhmin, lwmin;
+    logical wantq, upper;
+    integer ib, kd;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    logical lquery;
+
+
+
+/*  -- LAPACK computational routine (version 3.8.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     November 2017 */
+
+
+/*  ===================================================================== */
+
+/*     Test the input parameters */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --d__;
+    --e;
+    --tau;
+    --hous2;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    wantq = lsame_(vect, "V");
+    upper = lsame_(uplo, "U");
+    lquery = *lwork == -1 || *lhous2 == -1;
+
+/*     Determine the block size, the workspace size and the hous size. */
+
+    kd = ilaenv2stage_(&c__1, "SSYTRD_2STAGE", vect, n, &c_n1, &c_n1, &c_n1);
+    ib = ilaenv2stage_(&c__2, "SSYTRD_2STAGE", vect, n, &kd, &c_n1, &c_n1);
+    lhmin = ilaenv2stage_(&c__3, "SSYTRD_2STAGE", vect, n, &kd, &ib, &c_n1);
+    lwmin = ilaenv2stage_(&c__4, "SSYTRD_2STAGE", vect, n, &kd, &ib, &c_n1);
+/*      WRITE(*,*),'SSYTRD_2STAGE N KD UPLO LHMIN LWMIN ',N, KD, UPLO, */
+/*     $            LHMIN, LWMIN */
+
+    if (! lsame_(vect, "N")) {
+	*info = -1;
+    } else if (! upper && ! lsame_(uplo, "L")) {
+	*info = -2;
+    } else if (*n < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    } else if (*lhous2 < lhmin && ! lquery) {
+	*info = -10;
+    } else if (*lwork < lwmin && ! lquery) {
+	*info = -12;
+    }
+
+    if (*info == 0) {
+	hous2[1] = (real) lhmin;
+	work[1] = (real) lwmin;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYTRD_2STAGE", &i__1, (ftnlen)13);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	work[1] = 1.f;
+	return 0;
+    }
+
+/*     Determine pointer position */
+
+    ldab = kd + 1;
+    lwrk = *lwork - ldab * *n;
+    abpos = 1;
+    wpos = abpos + ldab * *n;
+    ssytrd_sy2sb_(uplo, n, &kd, &a[a_offset], lda, &work[abpos], &ldab, &tau[
+	    1], &work[wpos], &lwrk, info);
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYTRD_SY2SB", &i__1, (ftnlen)12);
+	return 0;
+    }
+    ssytrd_sb2st_("Y", vect, uplo, n, &kd, &work[abpos], &ldab, &d__[1], &e[
+	    1], &hous2[1], lhous2, &work[wpos], &lwrk, info);
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYTRD_SB2ST", &i__1, (ftnlen)12);
+	return 0;
+    }
+
+
+    hous2[1] = (real) lhmin;
+    work[1] = (real) lwmin;
+    return 0;
+
+/*     End of SSYTRD_2STAGE */
+
+} /* ssytrd_2stage__ */
+

lapack-netlib/SRC/ssytrd_sb2st.c

@@ -0,0 +1,943 @@
+/* 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 integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__4 = 4;
+static real c_b26 = 0.f;
+
+/* > \brief \b SSYTRD_SB2ST reduces a real symmetric band matrix A to real symmetric tridiagonal form T */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYTRD_SB2ST + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytrd_
+sb2t.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytrd_
+sb2t.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytrd_
+sb2t.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYTRD_SB2ST( STAGE1, VECT, UPLO, N, KD, AB, LDAB, */
+/*                               D, E, HOUS, LHOUS, WORK, LWORK, INFO ) */
+
+/*       #if defined(_OPENMP) */
+/*       use omp_lib */
+/*       #endif */
+
+/*       IMPLICIT NONE */
+
+/*       CHARACTER          STAGE1, UPLO, VECT */
+/*       INTEGER            N, KD, IB, LDAB, LHOUS, LWORK, INFO */
+/*       REAL               D( * ), E( * ) */
+/*       REAL               AB( LDAB, * ), HOUS( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYTRD_SB2ST reduces a real symmetric band matrix A to real symmetric */
+/* > tridiagonal form T by a orthogonal similarity transformation: */
+/* > Q**T * A * Q = T. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] STAGE1 */
+/* > \verbatim */
+/* >          STAGE1 is CHARACTER*1 */
+/* >          = 'N':  "No": to mention that the stage 1 of the reduction */
+/* >                  from dense to band using the ssytrd_sy2sb routine */
+/* >                  was not called before this routine to reproduce AB. */
+/* >                  In other term this routine is called as standalone. */
+/* >          = 'Y':  "Yes": to mention that the stage 1 of the */
+/* >                  reduction from dense to band using the ssytrd_sy2sb */
+/* >                  routine has been called to produce AB (e.g., AB is */
+/* >                  the output of ssytrd_sy2sb. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] VECT */
+/* > \verbatim */
+/* >          VECT is CHARACTER*1 */
+/* >          = 'N':  No need for the Housholder representation, */
+/* >                  and thus LHOUS is of size f2cmax(1, 4*N); */
+/* >          = 'V':  the Householder representation is needed to */
+/* >                  either generate or to apply Q later on, */
+/* >                  then LHOUS is to be queried and computed. */
+/* >                  (NOT AVAILABLE IN THIS RELEASE). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KD */
+/* > \verbatim */
+/* >          KD is INTEGER */
+/* >          The number of superdiagonals of the matrix A if UPLO = 'U', */
+/* >          or the number of subdiagonals if UPLO = 'L'.  KD >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] AB */
+/* > \verbatim */
+/* >          AB is REAL array, dimension (LDAB,N) */
+/* >          On entry, the upper or lower triangle of the symmetric band */
+/* >          matrix A, stored in the first KD+1 rows of the array.  The */
+/* >          j-th column of A is stored in the j-th column of the array AB */
+/* >          as follows: */
+/* >          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */
+/* >          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=f2cmin(n,j+kd). */
+/* >          On exit, the diagonal elements of AB are overwritten by the */
+/* >          diagonal elements of the tridiagonal matrix T; if KD > 0, the */
+/* >          elements on the first superdiagonal (if UPLO = 'U') or the */
+/* >          first subdiagonal (if UPLO = 'L') are overwritten by the */
+/* >          off-diagonal elements of T; the rest of AB is overwritten by */
+/* >          values generated during the reduction. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDAB */
+/* > \verbatim */
+/* >          LDAB is INTEGER */
+/* >          The leading dimension of the array AB.  LDAB >= KD+1. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] D */
+/* > \verbatim */
+/* >          D is REAL array, dimension (N) */
+/* >          The diagonal elements of the tridiagonal matrix T. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] E */
+/* > \verbatim */
+/* >          E is REAL array, dimension (N-1) */
+/* >          The off-diagonal elements of the tridiagonal matrix T: */
+/* >          E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] HOUS */
+/* > \verbatim */
+/* >          HOUS is REAL array, dimension LHOUS, that */
+/* >          store the Householder representation. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LHOUS */
+/* > \verbatim */
+/* >          LHOUS is INTEGER */
+/* >          The dimension of the array HOUS. LHOUS = MAX(1, dimension) */
+/* >          If LWORK = -1, or LHOUS=-1, */
+/* >          then a query is assumed; the routine */
+/* >          only calculates the optimal size of the HOUS array, returns */
+/* >          this value as the first entry of the HOUS array, and no error */
+/* >          message related to LHOUS is issued by XERBLA. */
+/* >          LHOUS = MAX(1, dimension) where */
+/* >          dimension = 4*N if VECT='N' */
+/* >          not available now if VECT='H' */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The dimension of the array WORK. LWORK = MAX(1, dimension) */
+/* >          If LWORK = -1, or LHOUS=-1, */
+/* >          then a workspace query is assumed; the routine */
+/* >          only calculates the optimal size of the WORK array, returns */
+/* >          this value as the first entry of the WORK array, and no error */
+/* >          message related to LWORK is issued by XERBLA. */
+/* >          LWORK = MAX(1, dimension) where */
+/* >          dimension   = (2KD+1)*N + KD*NTHREADS */
+/* >          where KD is the blocking size of the reduction, */
+/* >          FACTOPTNB is the blocking used by the QR or LQ */
+/* >          algorithm, usually FACTOPTNB=128 is a good choice */
+/* >          NTHREADS is the number of threads used when */
+/* >          openMP compilation is enabled, otherwise =1. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date November 2017 */
+
+/* > \ingroup real16OTHERcomputational */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  Implemented by Azzam Haidar. */
+/* > */
+/* >  All details are available on technical report, SC11, SC13 papers. */
+/* > */
+/* >  Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */
+/* >  Parallel reduction to condensed forms for symmetric eigenvalue problems */
+/* >  using aggregated fine-grained and memory-aware kernels. In Proceedings */
+/* >  of 2011 International Conference for High Performance Computing, */
+/* >  Networking, Storage and Analysis (SC '11), New York, NY, USA, */
+/* >  Article 8 , 11 pages. */
+/* >  http://doi.acm.org/10.1145/2063384.2063394 */
+/* > */
+/* >  A. Haidar, J. Kurzak, P. Luszczek, 2013. */
+/* >  An improved parallel singular value algorithm and its implementation */
+/* >  for multicore hardware, In Proceedings of 2013 International Conference */
+/* >  for High Performance Computing, Networking, Storage and Analysis (SC '13). */
+/* >  Denver, Colorado, USA, 2013. */
+/* >  Article 90, 12 pages. */
+/* >  http://doi.acm.org/10.1145/2503210.2503292 */
+/* > */
+/* >  A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */
+/* >  A novel hybrid CPU-GPU generalized eigensolver for electronic structure */
+/* >  calculations based on fine-grained memory aware tasks. */
+/* >  International Journal of High Performance Computing Applications. */
+/* >  Volume 28 Issue 2, Pages 196-209, May 2014. */
+/* >  http://hpc.sagepub.com/content/28/2/196 */
+/* > */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int ssytrd_sb2st_(char *stage1, char *vect, char *uplo, 
+	integer *n, integer *kd, real *ab, integer *ldab, real *d__, real *e, 
+	real *hous, integer *lhous, real *work, integer *lwork, integer *info)
+{
+    /* System generated locals */
+    integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5;
+    real r__1;
+
+    /* Local variables */
+    integer inda;
+    extern integer ilaenv2stage_(integer *, char *, char *, integer *, 
+	    integer *, integer *, integer *);
+    integer thed, indv, myid, indw, apos, dpos, abofdpos, nthreads, i__, k, m,
+	     edind, debug;
+    extern logical lsame_(char *, char *);
+    integer lhmin, sizea, shift, stind, colpt, lwmin, awpos;
+    logical wantq, upper;
+    integer sisev, grsiz, ttype, stepercol, ed, ib, st, abdpos;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    integer thgrid, thgrnb, indtau, ofdpos;
+    extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, 
+	    integer *, real *, integer *), slaset_(char *, integer *, 
+	    integer *, real *, real *, real *, integer *), 
+	    ssb2st_kernels_(char *, logical *, integer *, integer *, integer 
+	    *, integer *, integer *, integer *, integer *, real *, integer *, 
+	    real *, real *, integer *, real *);
+    integer blklastind;
+    extern /* Subroutine */ int mecago_();
+    logical lquery, afters1;
+    integer lda, tid, ldv, stt, sweepid, nbtiles, sizetau, thgrsiz;
+
+
+
+
+/*  -- LAPACK computational routine (version 3.8.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     November 2017 */
+
+
+/*  ===================================================================== */
+
+
+/*     Determine the minimal workspace size required. */
+/*     Test the input parameters */
+
+    /* Parameter adjustments */
+    ab_dim1 = *ldab;
+    ab_offset = 1 + ab_dim1 * 1;
+    ab -= ab_offset;
+    --d__;
+    --e;
+    --hous;
+    --work;
+
+    /* Function Body */
+    debug = 0;
+    *info = 0;
+    afters1 = lsame_(stage1, "Y");
+    wantq = lsame_(vect, "V");
+    upper = lsame_(uplo, "U");
+    lquery = *lwork == -1 || *lhous == -1;
+
+/*     Determine the block size, the workspace size and the hous size. */
+
+    ib = ilaenv2stage_(&c__2, "SSYTRD_SB2ST", vect, n, kd, &c_n1, &c_n1);
+    lhmin = ilaenv2stage_(&c__3, "SSYTRD_SB2ST", vect, n, kd, &ib, &c_n1);
+    lwmin = ilaenv2stage_(&c__4, "SSYTRD_SB2ST", vect, n, kd, &ib, &c_n1);
+
+    if (! afters1 && ! lsame_(stage1, "N")) {
+	*info = -1;
+    } else if (! lsame_(vect, "N")) {
+	*info = -2;
+    } else if (! upper && ! lsame_(uplo, "L")) {
+	*info = -3;
+    } else if (*n < 0) {
+	*info = -4;
+    } else if (*kd < 0) {
+	*info = -5;
+    } else if (*ldab < *kd + 1) {
+	*info = -7;
+    } else if (*lhous < lhmin && ! lquery) {
+	*info = -11;
+    } else if (*lwork < lwmin && ! lquery) {
+	*info = -13;
+    }
+
+    if (*info == 0) {
+	hous[1] = (real) lhmin;
+	work[1] = (real) lwmin;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYTRD_SB2ST", &i__1, (ftnlen)12);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	hous[1] = 1.f;
+	work[1] = 1.f;
+	return 0;
+    }
+
+/*     Determine pointer position */
+
+    ldv = *kd + ib;
+    sizetau = *n << 1;
+    sisev = *n << 1;
+    indtau = 1;
+    indv = indtau + sizetau;
+    lda = (*kd << 1) + 1;
+    sizea = lda * *n;
+    inda = 1;
+    indw = inda + sizea;
+    nthreads = 1;
+    tid = 0;
+
+    if (upper) {
+	apos = inda + *kd;
+	awpos = inda;
+	dpos = apos + *kd;
+	ofdpos = dpos - 1;
+	abdpos = *kd + 1;
+	abofdpos = *kd;
+    } else {
+	apos = inda;
+	awpos = inda + *kd + 1;
+	dpos = apos;
+	ofdpos = dpos + 1;
+	abdpos = 1;
+	abofdpos = 2;
+    }
+
+/*     Case KD=0: */
+/*     The matrix is diagonal. We just copy it (convert to "real" for */
+/*     real because D is double and the imaginary part should be 0) */
+/*     and store it in D. A sequential code here is better or */
+/*     in a parallel environment it might need two cores for D and E */
+
+    if (*kd == 0) {
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    d__[i__] = ab[abdpos + i__ * ab_dim1];
+/* L30: */
+	}
+	i__1 = *n - 1;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    e[i__] = 0.f;
+/* L40: */
+	}
+
+	hous[1] = 1.f;
+	work[1] = 1.f;
+	return 0;
+    }
+
+/*     Case KD=1: */
+/*     The matrix is already Tridiagonal. We have to make diagonal */
+/*     and offdiagonal elements real, and store them in D and E. */
+/*     For that, for real precision just copy the diag and offdiag */
+/*     to D and E while for the COMPLEX case the bulge chasing is */
+/*     performed to convert the hermetian tridiagonal to symmetric */
+/*     tridiagonal. A simpler coversion formula might be used, but then */
+/*     updating the Q matrix will be required and based if Q is generated */
+/*     or not this might complicate the story. */
+
+    if (*kd == 1) {
+	i__1 = *n;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    d__[i__] = ab[abdpos + i__ * ab_dim1];
+/* L50: */
+	}
+
+	if (upper) {
+	    i__1 = *n - 1;
+	    for (i__ = 1; i__ <= i__1; ++i__) {
+		e[i__] = ab[abofdpos + (i__ + 1) * ab_dim1];
+/* L60: */
+	    }
+	} else {
+	    i__1 = *n - 1;
+	    for (i__ = 1; i__ <= i__1; ++i__) {
+		e[i__] = ab[abofdpos + i__ * ab_dim1];
+/* L70: */
+	    }
+	}
+
+	hous[1] = 1.f;
+	work[1] = 1.f;
+	return 0;
+    }
+
+/*     Main code start here. */
+/*     Reduce the symmetric band of A to a tridiagonal matrix. */
+
+    thgrsiz = *n;
+    grsiz = 1;
+    shift = 3;
+    r__1 = (real) (*n) / (real) (*kd) + .5f;
+    nbtiles = r_int(&r__1);
+    r__1 = (real) shift / (real) grsiz + .5f;
+    stepercol = r_int(&r__1);
+    r__1 = (real) (*n - 1) / (real) thgrsiz + .5f;
+    thgrnb = r_int(&r__1);
+
+    i__1 = *kd + 1;
+    slacpy_("A", &i__1, n, &ab[ab_offset], ldab, &work[apos], &lda)
+	    ;
+    slaset_("A", kd, n, &c_b26, &c_b26, &work[awpos], &lda);
+
+
+/*     openMP parallelisation start here */
+
+
+/*     main bulge chasing loop */
+
+    i__1 = thgrnb;
+    for (thgrid = 1; thgrid <= i__1; ++thgrid) {
+	stt = (thgrid - 1) * thgrsiz + 1;
+/* Computing MIN */
+	i__2 = stt + thgrsiz - 1, i__3 = *n - 1;
+	thed = f2cmin(i__2,i__3);
+	i__2 = *n - 1;
+	for (i__ = stt; i__ <= i__2; ++i__) {
+	    ed = f2cmin(i__,thed);
+	    if (stt > ed) {
+		myexit_();
+	    }
+	    i__3 = stepercol;
+	    for (m = 1; m <= i__3; ++m) {
+		st = stt;
+		i__4 = ed;
+		for (sweepid = st; sweepid <= i__4; ++sweepid) {
+		    i__5 = grsiz;
+		    for (k = 1; k <= i__5; ++k) {
+			myid = (i__ - sweepid) * (stepercol * grsiz) + (m - 1)
+				 * grsiz + k;
+			if (myid == 1) {
+			    ttype = 1;
+			} else {
+			    ttype = myid % 2 + 2;
+			}
+			if (ttype == 2) {
+			    colpt = myid / 2 * *kd + sweepid;
+			    stind = colpt - *kd + 1;
+			    edind = f2cmin(colpt,*n);
+			    blklastind = colpt;
+			} else {
+			    colpt = (myid + 1) / 2 * *kd + sweepid;
+			    stind = colpt - *kd + 1;
+			    edind = f2cmin(colpt,*n);
+			    if (stind >= edind - 1 && edind == *n) {
+				blklastind = *n;
+			    } else {
+				blklastind = 0;
+			    }
+			}
+
+/*                         Call the kernel */
+
+			ssb2st_kernels_(uplo, &wantq, &ttype, &stind, &edind,
+				 &sweepid, n, kd, &ib, &work[inda], &lda, &
+				hous[indv], &hous[indtau], &ldv, &work[indw + 
+				tid * *kd]);
+			if (blklastind >= *n - 1) {
+			    ++stt;
+			    myexit_();
+			}
+/* L140: */
+		    }
+/* L130: */
+		}
+/* L120: */
+	    }
+/* L110: */
+	}
+/* L100: */
+    }
+
+
+/*     Copy the diagonal from A to D. Note that D is REAL thus only */
+/*     the Real part is needed, the imaginary part should be zero. */
+
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	d__[i__] = work[dpos + (i__ - 1) * lda];
+/* L150: */
+    }
+
+/*     Copy the off diagonal from A to E. Note that E is REAL thus only */
+/*     the Real part is needed, the imaginary part should be zero. */
+
+    if (upper) {
+	i__1 = *n - 1;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    e[i__] = work[ofdpos + i__ * lda];
+/* L160: */
+	}
+    } else {
+	i__1 = *n - 1;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    e[i__] = work[ofdpos + (i__ - 1) * lda];
+/* L170: */
+	}
+    }
+
+    hous[1] = (real) lhmin;
+    work[1] = (real) lwmin;
+    return 0;
+
+/*     End of SSYTRD_SB2ST */
+
+} /* ssytrd_sb2st__ */
+

lapack-netlib/SRC/ssytrd_sy2sb.c

@@ -0,0 +1,957 @@
+/* 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_n1 = -1;
+static integer c__1 = 1;
+static real c_b17 = 0.f;
+static real c_b23 = 1.f;
+static real c_b39 = -.5f;
+static real c_b42 = -1.f;
+
+/* > \brief \b SSYTRD_SY2SB */
+
+/*  @generated from zhetrd_he2hb.f, fortran z -> s, Wed Dec  7 08:22:40 2016 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYTRD_SY2SB + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytrd.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytrd.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytrd.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYTRD_SY2SB( UPLO, N, KD, A, LDA, AB, LDAB, TAU, */
+/*                              WORK, LWORK, INFO ) */
+
+/*       IMPLICIT NONE */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDA, LDAB, LWORK, N, KD */
+/*       REAL               A( LDA, * ), AB( LDAB, * ), */
+/*                          TAU( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYTRD_SY2SB reduces a real symmetric matrix A to real symmetric */
+/* > band-diagonal form AB by a orthogonal similarity transformation: */
+/* > Q**T * A * Q = AB. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KD */
+/* > \verbatim */
+/* >          KD is INTEGER */
+/* >          The number of superdiagonals of the reduced matrix if UPLO = 'U', */
+/* >          or the number of subdiagonals if UPLO = 'L'.  KD >= 0. */
+/* >          The reduced matrix is stored in the array AB. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          On entry, the symmetric matrix A.  If UPLO = 'U', the leading */
+/* >          N-by-N upper triangular part of A contains the upper */
+/* >          triangular part of the matrix A, and the strictly lower */
+/* >          triangular part of A is not referenced.  If UPLO = 'L', the */
+/* >          leading N-by-N lower triangular part of A contains the lower */
+/* >          triangular part of the matrix A, and the strictly upper */
+/* >          triangular part of A is not referenced. */
+/* >          On exit, if UPLO = 'U', the diagonal and first superdiagonal */
+/* >          of A are overwritten by the corresponding elements of the */
+/* >          tridiagonal matrix T, and the elements above the first */
+/* >          superdiagonal, with the array TAU, represent the orthogonal */
+/* >          matrix Q as a product of elementary reflectors; if UPLO */
+/* >          = 'L', the diagonal and first subdiagonal of A are over- */
+/* >          written by the corresponding elements of the tridiagonal */
+/* >          matrix T, and the elements below the first subdiagonal, with */
+/* >          the array TAU, represent the orthogonal matrix Q as a product */
+/* >          of elementary reflectors. See Further Details. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] AB */
+/* > \verbatim */
+/* >          AB is REAL array, dimension (LDAB,N) */
+/* >          On exit, the upper or lower triangle of the symmetric band */
+/* >          matrix A, stored in the first KD+1 rows of the array.  The */
+/* >          j-th column of A is stored in the j-th column of the array AB */
+/* >          as follows: */
+/* >          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */
+/* >          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=f2cmin(n,j+kd). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDAB */
+/* > \verbatim */
+/* >          LDAB is INTEGER */
+/* >          The leading dimension of the array AB.  LDAB >= KD+1. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] TAU */
+/* > \verbatim */
+/* >          TAU is REAL array, dimension (N-KD) */
+/* >          The scalar factors of the elementary reflectors (see Further */
+/* >          Details). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (LWORK) */
+/* >          On exit, if INFO = 0, or if LWORK=-1, */
+/* >          WORK(1) returns the size of LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The dimension of the array WORK which should be calculated */
+/* >          by a workspace query. LWORK = MAX(1, LWORK_QUERY) */
+/* >          If LWORK = -1, then a workspace query is assumed; the routine */
+/* >          only calculates the optimal size of the WORK array, returns */
+/* >          this value as the first entry of the WORK array, and no error */
+/* >          message related to LWORK is issued by XERBLA. */
+/* >          LWORK_QUERY = N*KD + N*f2cmax(KD,FACTOPTNB) + 2*KD*KD */
+/* >          where FACTOPTNB is the blocking used by the QR or LQ */
+/* >          algorithm, usually FACTOPTNB=128 is a good choice otherwise */
+/* >          putting LWORK=-1 will provide the size of WORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date November 2017 */
+
+/* > \ingroup realSYcomputational */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  Implemented by Azzam Haidar. */
+/* > */
+/* >  All details are available on technical report, SC11, SC13 papers. */
+/* > */
+/* >  Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */
+/* >  Parallel reduction to condensed forms for symmetric eigenvalue problems */
+/* >  using aggregated fine-grained and memory-aware kernels. In Proceedings */
+/* >  of 2011 International Conference for High Performance Computing, */
+/* >  Networking, Storage and Analysis (SC '11), New York, NY, USA, */
+/* >  Article 8 , 11 pages. */
+/* >  http://doi.acm.org/10.1145/2063384.2063394 */
+/* > */
+/* >  A. Haidar, J. Kurzak, P. Luszczek, 2013. */
+/* >  An improved parallel singular value algorithm and its implementation */
+/* >  for multicore hardware, In Proceedings of 2013 International Conference */
+/* >  for High Performance Computing, Networking, Storage and Analysis (SC '13). */
+/* >  Denver, Colorado, USA, 2013. */
+/* >  Article 90, 12 pages. */
+/* >  http://doi.acm.org/10.1145/2503210.2503292 */
+/* > */
+/* >  A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */
+/* >  A novel hybrid CPU-GPU generalized eigensolver for electronic structure */
+/* >  calculations based on fine-grained memory aware tasks. */
+/* >  International Journal of High Performance Computing Applications. */
+/* >  Volume 28 Issue 2, Pages 196-209, May 2014. */
+/* >  http://hpc.sagepub.com/content/28/2/196 */
+/* > */
+/* > \endverbatim */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  If UPLO = 'U', the matrix Q is represented as a product of elementary */
+/* >  reflectors */
+/* > */
+/* >     Q = H(k)**T . . . H(2)**T H(1)**T, where k = n-kd. */
+/* > */
+/* >  Each H(i) has the form */
+/* > */
+/* >     H(i) = I - tau * v * v**T */
+/* > */
+/* >  where tau is a real scalar, and v is a real vector with */
+/* >  v(1:i+kd-1) = 0 and v(i+kd) = 1; conjg(v(i+kd+1:n)) is stored on exit in */
+/* >  A(i,i+kd+1:n), and tau in TAU(i). */
+/* > */
+/* >  If UPLO = 'L', the matrix Q is represented as a product of elementary */
+/* >  reflectors */
+/* > */
+/* >     Q = H(1) H(2) . . . H(k), where k = n-kd. */
+/* > */
+/* >  Each H(i) has the form */
+/* > */
+/* >     H(i) = I - tau * v * v**T */
+/* > */
+/* >  where tau is a real scalar, and v is a real vector with */
+/* >  v(kd+1:i) = 0 and v(i+kd+1) = 1; v(i+kd+2:n) is stored on exit in */
+/* >  A(i+kd+2:n,i), and tau in TAU(i). */
+/* > */
+/* >  The contents of A on exit are illustrated by the following examples */
+/* >  with n = 5: */
+/* > */
+/* >  if UPLO = 'U':                       if UPLO = 'L': */
+/* > */
+/* >    (  ab  ab/v1  v1      v1     v1    )              (  ab                            ) */
+/* >    (      ab     ab/v2   v2     v2    )              (  ab/v1  ab                     ) */
+/* >    (             ab      ab/v3  v3    )              (  v1     ab/v2  ab              ) */
+/* >    (                     ab     ab/v4 )              (  v1     v2     ab/v3  ab       ) */
+/* >    (                            ab    )              (  v1     v2     v3     ab/v4 ab ) */
+/* > */
+/* >  where d and e denote diagonal and off-diagonal elements of T, and vi */
+/* >  denotes an element of the vector defining H(i). */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int ssytrd_sy2sb_(char *uplo, integer *n, integer *kd, real 
+	*a, integer *lda, real *ab, integer *ldab, real *tau, real *work, 
+	integer *lwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, ab_dim1, ab_offset, i__1, i__2, i__3, i__4, 
+	    i__5;
+
+    /* Local variables */
+    extern integer ilaenv2stage_(integer *, char *, char *, integer *, 
+	    integer *, integer *, integer *);
+    integer tpos, wpos, s1pos, s2pos, i__, j;
+    extern logical lsame_(char *, char *);
+    integer iinfo;
+    extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, 
+	    integer *, real *, real *, integer *, real *, integer *, real *, 
+	    real *, integer *);
+    integer lwmin;
+    logical upper;
+    extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, 
+	    integer *), ssymm_(char *, char *, integer *, integer *, real *, 
+	    real *, integer *, real *, integer *, real *, real *, integer *);
+    integer lk, pk;
+    extern /* Subroutine */ int ssyr2k_(char *, char *, integer *, integer *, 
+	    real *, real *, integer *, real *, integer *, real *, real *, 
+	    integer *);
+    integer pn, lt, lw;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), sgelqf_(
+	    integer *, integer *, real *, integer *, real *, real *, integer *
+	    , integer *), sgeqrf_(integer *, integer *, real *, integer *, 
+	    real *, real *, integer *, integer *), slarft_(char *, char *, 
+	    integer *, integer *, real *, integer *, real *, real *, integer *
+	    ), slaset_(char *, integer *, integer *, real *, 
+	    real *, real *, integer *);
+    integer ls1;
+    logical lquery;
+    integer ls2, ldt, ldw, lds1, lds2;
+
+
+
+/*  -- LAPACK computational routine (version 3.8.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     November 2017 */
+
+
+/*  ===================================================================== */
+
+
+/*     Determine the minimal workspace size required */
+/*     and test the input parameters */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    ab_dim1 = *ldab;
+    ab_offset = 1 + ab_dim1 * 1;
+    ab -= ab_offset;
+    --tau;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    lquery = *lwork == -1;
+    lwmin = ilaenv2stage_(&c__4, "SSYTRD_SY2SB", "", n, kd, &c_n1, &c_n1);
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*kd < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    } else /* if(complicated condition) */ {
+/* Computing MAX */
+	i__1 = 1, i__2 = *kd + 1;
+	if (*ldab < f2cmax(i__1,i__2)) {
+	    *info = -7;
+	} else if (*lwork < lwmin && ! lquery) {
+	    *info = -10;
+	}
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYTRD_SY2SB", &i__1, (ftnlen)12);
+	return 0;
+    } else if (lquery) {
+	work[1] = (real) lwmin;
+	return 0;
+    }
+
+/*     Quick return if possible */
+/*     Copy the upper/lower portion of A into AB */
+
+    if (*n <= *kd + 1) {
+	if (upper) {
+	    i__1 = *n;
+	    for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MIN */
+		i__2 = *kd + 1;
+		lk = f2cmin(i__2,i__);
+		scopy_(&lk, &a[i__ - lk + 1 + i__ * a_dim1], &c__1, &ab[*kd + 
+			1 - lk + 1 + i__ * ab_dim1], &c__1);
+/* L100: */
+	    }
+	} else {
+	    i__1 = *n;
+	    for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MIN */
+		i__2 = *kd + 1, i__3 = *n - i__ + 1;
+		lk = f2cmin(i__2,i__3);
+		scopy_(&lk, &a[i__ + i__ * a_dim1], &c__1, &ab[i__ * ab_dim1 
+			+ 1], &c__1);
+/* L110: */
+	    }
+	}
+	work[1] = 1.f;
+	return 0;
+    }
+
+/*     Determine the pointer position for the workspace */
+
+    ldt = *kd;
+    lds1 = *kd;
+    lt = ldt * *kd;
+    lw = *n * *kd;
+    ls1 = lds1 * *kd;
+    ls2 = lwmin - lt - lw - ls1;
+/*      LS2 = N*MAX(KD,FACTOPTNB) */
+    tpos = 1;
+    wpos = tpos + lt;
+    s1pos = wpos + lw;
+    s2pos = s1pos + ls1;
+    if (upper) {
+	ldw = *kd;
+	lds2 = *kd;
+    } else {
+	ldw = *n;
+	lds2 = *n;
+    }
+
+
+/*     Set the workspace of the triangular matrix T to zero once such a */
+/*     way every time T is generated the upper/lower portion will be always zero */
+
+    slaset_("A", &ldt, kd, &c_b17, &c_b17, &work[tpos], &ldt);
+
+    if (upper) {
+	i__1 = *n - *kd;
+	i__2 = *kd;
+	for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+	    pn = *n - i__ - *kd + 1;
+/* Computing MIN */
+	    i__3 = *n - i__ - *kd + 1;
+	    pk = f2cmin(i__3,*kd);
+
+/*            Compute the LQ factorization of the current block */
+
+	    sgelqf_(kd, &pn, &a[i__ + (i__ + *kd) * a_dim1], lda, &tau[i__], &
+		    work[s2pos], &ls2, &iinfo);
+
+/*            Copy the upper portion of A into AB */
+
+	    i__3 = i__ + pk - 1;
+	    for (j = i__; j <= i__3; ++j) {
+/* Computing MIN */
+		i__4 = *kd, i__5 = *n - j;
+		lk = f2cmin(i__4,i__5) + 1;
+		i__4 = *ldab - 1;
+		scopy_(&lk, &a[j + j * a_dim1], lda, &ab[*kd + 1 + j * 
+			ab_dim1], &i__4);
+/* L20: */
+	    }
+
+	    slaset_("Lower", &pk, &pk, &c_b17, &c_b23, &a[i__ + (i__ + *kd) * 
+		    a_dim1], lda);
+
+/*            Form the matrix T */
+
+	    slarft_("Forward", "Rowwise", &pn, &pk, &a[i__ + (i__ + *kd) * 
+		    a_dim1], lda, &tau[i__], &work[tpos], &ldt);
+
+/*            Compute W: */
+
+	    sgemm_("Conjugate", "No transpose", &pk, &pn, &pk, &c_b23, &work[
+		    tpos], &ldt, &a[i__ + (i__ + *kd) * a_dim1], lda, &c_b17, 
+		    &work[s2pos], &lds2);
+
+	    ssymm_("Right", uplo, &pk, &pn, &c_b23, &a[i__ + *kd + (i__ + *kd)
+		     * a_dim1], lda, &work[s2pos], &lds2, &c_b17, &work[wpos],
+		     &ldw);
+
+	    sgemm_("No transpose", "Conjugate", &pk, &pk, &pn, &c_b23, &work[
+		    wpos], &ldw, &work[s2pos], &lds2, &c_b17, &work[s1pos], &
+		    lds1);
+
+	    sgemm_("No transpose", "No transpose", &pk, &pn, &pk, &c_b39, &
+		    work[s1pos], &lds1, &a[i__ + (i__ + *kd) * a_dim1], lda, &
+		    c_b23, &work[wpos], &ldw);
+
+
+/*            Update the unreduced submatrix A(i+kd:n,i+kd:n), using */
+/*            an update of the form:  A := A - V'*W - W'*V */
+
+	    ssyr2k_(uplo, "Conjugate", &pn, &pk, &c_b42, &a[i__ + (i__ + *kd) 
+		    * a_dim1], lda, &work[wpos], &ldw, &c_b23, &a[i__ + *kd + 
+		    (i__ + *kd) * a_dim1], lda);
+/* L10: */
+	}
+
+/*        Copy the upper band to AB which is the band storage matrix */
+
+	i__2 = *n;
+	for (j = *n - *kd + 1; j <= i__2; ++j) {
+/* Computing MIN */
+	    i__1 = *kd, i__3 = *n - j;
+	    lk = f2cmin(i__1,i__3) + 1;
+	    i__1 = *ldab - 1;
+	    scopy_(&lk, &a[j + j * a_dim1], lda, &ab[*kd + 1 + j * ab_dim1], &
+		    i__1);
+/* L30: */
+	}
+
+    } else {
+
+/*         Reduce the lower triangle of A to lower band matrix */
+
+	i__2 = *n - *kd;
+	i__1 = *kd;
+	for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
+	    pn = *n - i__ - *kd + 1;
+/* Computing MIN */
+	    i__3 = *n - i__ - *kd + 1;
+	    pk = f2cmin(i__3,*kd);
+
+/*            Compute the QR factorization of the current block */
+
+	    sgeqrf_(&pn, kd, &a[i__ + *kd + i__ * a_dim1], lda, &tau[i__], &
+		    work[s2pos], &ls2, &iinfo);
+
+/*            Copy the upper portion of A into AB */
+
+	    i__3 = i__ + pk - 1;
+	    for (j = i__; j <= i__3; ++j) {
+/* Computing MIN */
+		i__4 = *kd, i__5 = *n - j;
+		lk = f2cmin(i__4,i__5) + 1;
+		scopy_(&lk, &a[j + j * a_dim1], &c__1, &ab[j * ab_dim1 + 1], &
+			c__1);
+/* L50: */
+	    }
+
+	    slaset_("Upper", &pk, &pk, &c_b17, &c_b23, &a[i__ + *kd + i__ * 
+		    a_dim1], lda);
+
+/*            Form the matrix T */
+
+	    slarft_("Forward", "Columnwise", &pn, &pk, &a[i__ + *kd + i__ * 
+		    a_dim1], lda, &tau[i__], &work[tpos], &ldt);
+
+/*            Compute W: */
+
+	    sgemm_("No transpose", "No transpose", &pn, &pk, &pk, &c_b23, &a[
+		    i__ + *kd + i__ * a_dim1], lda, &work[tpos], &ldt, &c_b17,
+		     &work[s2pos], &lds2);
+
+	    ssymm_("Left", uplo, &pn, &pk, &c_b23, &a[i__ + *kd + (i__ + *kd) 
+		    * a_dim1], lda, &work[s2pos], &lds2, &c_b17, &work[wpos], 
+		    &ldw);
+
+	    sgemm_("Conjugate", "No transpose", &pk, &pk, &pn, &c_b23, &work[
+		    s2pos], &lds2, &work[wpos], &ldw, &c_b17, &work[s1pos], &
+		    lds1);
+
+	    sgemm_("No transpose", "No transpose", &pn, &pk, &pk, &c_b39, &a[
+		    i__ + *kd + i__ * a_dim1], lda, &work[s1pos], &lds1, &
+		    c_b23, &work[wpos], &ldw);
+
+
+/*            Update the unreduced submatrix A(i+kd:n,i+kd:n), using */
+/*            an update of the form:  A := A - V*W' - W*V' */
+
+	    ssyr2k_(uplo, "No transpose", &pn, &pk, &c_b42, &a[i__ + *kd + 
+		    i__ * a_dim1], lda, &work[wpos], &ldw, &c_b23, &a[i__ + *
+		    kd + (i__ + *kd) * a_dim1], lda);
+/*            ================================================================== */
+/*            RESTORE A FOR COMPARISON AND CHECKING TO BE REMOVED */
+/*             DO 45 J = I, I+PK-1 */
+/*                LK = MIN( KD, N-J ) + 1 */
+/*                CALL SCOPY( LK, AB( 1, J ), 1, A( J, J ), 1 ) */
+/*   45        CONTINUE */
+/*            ================================================================== */
+/* L40: */
+	}
+
+/*        Copy the lower band to AB which is the band storage matrix */
+
+	i__1 = *n;
+	for (j = *n - *kd + 1; j <= i__1; ++j) {
+/* Computing MIN */
+	    i__2 = *kd, i__3 = *n - j;
+	    lk = f2cmin(i__2,i__3) + 1;
+	    scopy_(&lk, &a[j + j * a_dim1], &c__1, &ab[j * ab_dim1 + 1], &
+		    c__1);
+/* L60: */
+	}
+    }
+
+    work[1] = (real) lwmin;
+    return 0;
+
+/*     End of SSYTRD_SY2SB */
+
+} /* ssytrd_sy2sb__ */
+

lapack-netlib/SRC/ssytrf.c

@@ -0,0 +1,778 @@
+/* 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_n1 = -1;
+static integer c__2 = 2;
+
+/* > \brief \b SSYTRF */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYTRF + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytrf.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytrf.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytrf.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDA, LWORK, N */
+/*       INTEGER            IPIV( * ) */
+/*       REAL               A( LDA, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYTRF computes the factorization of a real symmetric matrix A using */
+/* > the Bunch-Kaufman diagonal pivoting method.  The form of the */
+/* > factorization is */
+/* > */
+/* >    A = U**T*D*U  or  A = L*D*L**T */
+/* > */
+/* > where U (or L) is a product of permutation and unit upper (lower) */
+/* > triangular matrices, and D is symmetric and block diagonal with */
+/* > 1-by-1 and 2-by-2 diagonal blocks. */
+/* > */
+/* > This is the blocked version of the algorithm, calling Level 3 BLAS. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \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 symmetric matrix A.  If UPLO = 'U', the leading */
+/* >          N-by-N upper triangular part of A contains the upper */
+/* >          triangular part of the matrix A, and the strictly lower */
+/* >          triangular part of A is not referenced.  If UPLO = 'L', the */
+/* >          leading N-by-N lower triangular part of A contains the lower */
+/* >          triangular part of the matrix A, and the strictly upper */
+/* >          triangular part of A is not referenced. */
+/* > */
+/* >          On exit, the block diagonal matrix D and the multipliers used */
+/* >          to obtain the factor U or L (see below for further details). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges and the block structure of D. */
+/* >          If IPIV(k) > 0, then rows and columns k and IPIV(k) were */
+/* >          interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* >          If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */
+/* >          columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */
+/* >          is a 2-by-2 diagonal block.  If UPLO = 'L' and IPIV(k) = */
+/* >          IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */
+/* >          interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (MAX(1,LWORK)) */
+/* >          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The length of WORK.  LWORK >=1.  For best performance */
+/* >          LWORK >= N*NB, where NB is the block size returned by ILAENV. */
+/* > */
+/* >          If LWORK = -1, then a workspace query is assumed; the routine */
+/* >          only calculates the optimal size of the WORK array, returns */
+/* >          this value as the first entry of the WORK array, and no error */
+/* >          message related to LWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0:  if INFO = i, D(i,i) is exactly zero.  The factorization */
+/* >                has been completed, but the block diagonal matrix D is */
+/* >                exactly singular, and division by zero will occur if it */
+/* >                is used to solve a system of equations. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realSYcomputational */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  If UPLO = 'U', then A = U**T*D*U, where */
+/* >     U = P(n)*U(n)* ... *P(k)U(k)* ..., */
+/* >  i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
+/* >  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* >  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as */
+/* >  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
+/* >  that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+/* > */
+/* >             (   I    v    0   )   k-s */
+/* >     U(k) =  (   0    I    0   )   s */
+/* >             (   0    0    I   )   n-k */
+/* >                k-s   s   n-k */
+/* > */
+/* >  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
+/* >  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
+/* >  and A(k,k), and v overwrites A(1:k-2,k-1:k). */
+/* > */
+/* >  If UPLO = 'L', then A = L*D*L**T, where */
+/* >     L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
+/* >  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
+/* >  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* >  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as */
+/* >  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
+/* >  that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+/* > */
+/* >             (   I    0     0   )  k-1 */
+/* >     L(k) =  (   0    I     0   )  s */
+/* >             (   0    v     I   )  n-k-s+1 */
+/* >                k-1   s  n-k-s+1 */
+/* > */
+/* >  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
+/* >  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
+/* >  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
+/* > \endverbatim */
+/* > */
+/*  ===================================================================== */
+/* Subroutine */ int ssytrf_(char *uplo, integer *n, real *a, integer *lda, 
+	integer *ipiv, real *work, integer *lwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+
+    /* Local variables */
+    integer j, k;
+    extern logical lsame_(char *, char *);
+    integer nbmin, iinfo;
+    logical upper;
+    integer kb, nb;
+    extern /* Subroutine */ int ssytf2_(char *, integer *, real *, integer *, 
+	    integer *, integer *), xerbla_(char *, integer *, ftnlen);
+    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
+	    integer *, integer *, ftnlen, ftnlen);
+    extern /* Subroutine */ int slasyf_(char *, integer *, integer *, integer 
+	    *, real *, integer *, integer *, real *, integer *, integer *);
+    integer ldwork, lwkopt;
+    logical lquery;
+    integer iws;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --ipiv;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    lquery = *lwork == -1;
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -4;
+    } else if (*lwork < 1 && ! lquery) {
+	*info = -7;
+    }
+
+    if (*info == 0) {
+
+/*        Determine the block size */
+
+	nb = ilaenv_(&c__1, "SSYTRF", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
+		 (ftnlen)1);
+	lwkopt = *n * nb;
+	work[1] = (real) lwkopt;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYTRF", &i__1, (ftnlen)6);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+    nbmin = 2;
+    ldwork = *n;
+    if (nb > 1 && nb < *n) {
+	iws = ldwork * nb;
+	if (*lwork < iws) {
+/* Computing MAX */
+	    i__1 = *lwork / ldwork;
+	    nb = f2cmax(i__1,1);
+/* Computing MAX */
+	    i__1 = 2, i__2 = ilaenv_(&c__2, "SSYTRF", uplo, n, &c_n1, &c_n1, &
+		    c_n1, (ftnlen)6, (ftnlen)1);
+	    nbmin = f2cmax(i__1,i__2);
+	}
+    } else {
+	iws = 1;
+    }
+    if (nb < nbmin) {
+	nb = *n;
+    }
+
+    if (upper) {
+
+/*        Factorize A as U**T*D*U using the upper triangle of A */
+
+/*        K is the main loop index, decreasing from N to 1 in steps of */
+/*        KB, where KB is the number of columns factorized by SLASYF; */
+/*        KB is either NB or NB-1, or K for the last block */
+
+	k = *n;
+L10:
+
+/*        If K < 1, exit from loop */
+
+	if (k < 1) {
+	    goto L40;
+	}
+
+	if (k > nb) {
+
+/*           Factorize columns k-kb+1:k of A and use blocked code to */
+/*           update columns 1:k-kb */
+
+	    slasyf_(uplo, &k, &nb, &kb, &a[a_offset], lda, &ipiv[1], &work[1],
+		     &ldwork, &iinfo);
+	} else {
+
+/*           Use unblocked code to factorize columns 1:k of A */
+
+	    ssytf2_(uplo, &k, &a[a_offset], lda, &ipiv[1], &iinfo);
+	    kb = k;
+	}
+
+/*        Set INFO on the first occurrence of a zero pivot */
+
+	if (*info == 0 && iinfo > 0) {
+	    *info = iinfo;
+	}
+
+/*        Decrease K and return to the start of the main loop */
+
+	k -= kb;
+	goto L10;
+
+    } else {
+
+/*        Factorize A as L*D*L**T using the lower triangle of A */
+
+/*        K is the main loop index, increasing from 1 to N in steps of */
+/*        KB, where KB is the number of columns factorized by SLASYF; */
+/*        KB is either NB or NB-1, or N-K+1 for the last block */
+
+	k = 1;
+L20:
+
+/*        If K > N, exit from loop */
+
+	if (k > *n) {
+	    goto L40;
+	}
+
+	if (k <= *n - nb) {
+
+/*           Factorize columns k:k+kb-1 of A and use blocked code to */
+/*           update columns k+kb:n */
+
+	    i__1 = *n - k + 1;
+	    slasyf_(uplo, &i__1, &nb, &kb, &a[k + k * a_dim1], lda, &ipiv[k], 
+		    &work[1], &ldwork, &iinfo);
+	} else {
+
+/*           Use unblocked code to factorize columns k:n of A */
+
+	    i__1 = *n - k + 1;
+	    ssytf2_(uplo, &i__1, &a[k + k * a_dim1], lda, &ipiv[k], &iinfo);
+	    kb = *n - k + 1;
+	}
+
+/*        Set INFO on the first occurrence of a zero pivot */
+
+	if (*info == 0 && iinfo > 0) {
+	    *info = iinfo + k - 1;
+	}
+
+/*        Adjust IPIV */
+
+	i__1 = k + kb - 1;
+	for (j = k; j <= i__1; ++j) {
+	    if (ipiv[j] > 0) {
+		ipiv[j] = ipiv[j] + k - 1;
+	    } else {
+		ipiv[j] = ipiv[j] - k + 1;
+	    }
+/* L30: */
+	}
+
+/*        Increase K and return to the start of the main loop */
+
+	k += kb;
+	goto L20;
+
+    }
+
+L40:
+    work[1] = (real) lwkopt;
+    return 0;
+
+/*     End of SSYTRF */
+
+} /* ssytrf_ */
+

lapack-netlib/SRC/ssytrf_aa.c

@@ -0,0 +1,911 @@
+/* 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_n1 = -1;
+static real c_b18 = -1.f;
+static real c_b20 = 1.f;
+
+/* > \brief \b SSYTRF_AA */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYTRF_AA + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytrf_
+aa.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytrf_
+aa.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytrf_
+aa.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            N, LDA, LWORK, INFO */
+/*       INTEGER            IPIV( * ) */
+/*       REAL   A( LDA, * ), WORK( * ) */
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYTRF_AA computes the factorization of a real symmetric matrix A */
+/* > using the Aasen's algorithm.  The form of the factorization is */
+/* > */
+/* >    A = U**T*T*U  or  A = L*T*L**T */
+/* > */
+/* > where U (or L) is a product of permutation and unit upper (lower) */
+/* > triangular matrices, and T is a symmetric tridiagonal matrix. */
+/* > */
+/* > This is the blocked version of the algorithm, calling Level 3 BLAS. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \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 symmetric matrix A.  If UPLO = 'U', the leading */
+/* >          N-by-N upper triangular part of A contains the upper */
+/* >          triangular part of the matrix A, and the strictly lower */
+/* >          triangular part of A is not referenced.  If UPLO = 'L', the */
+/* >          leading N-by-N lower triangular part of A contains the lower */
+/* >          triangular part of the matrix A, and the strictly upper */
+/* >          triangular part of A is not referenced. */
+/* > */
+/* >          On exit, the tridiagonal matrix is stored in the diagonals */
+/* >          and the subdiagonals of A just below (or above) the diagonals, */
+/* >          and L is stored below (or above) the subdiaonals, when UPLO */
+/* >          is 'L' (or 'U'). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          On exit, it contains the details of the interchanges, i.e., */
+/* >          the row and column k of A were interchanged with the */
+/* >          row and column IPIV(k). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (MAX(1,LWORK)) */
+/* >          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The length of WORK.  LWORK >= MAX(1,2*N). For optimum performance */
+/* >          LWORK >= N*(1+NB), where NB is the optimal blocksize. */
+/* > */
+/* >          If LWORK = -1, then a workspace query is assumed; the routine */
+/* >          only calculates the optimal size of the WORK array, returns */
+/* >          this value as the first entry of the WORK array, and no error */
+/* >          message related to LWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date November 2017 */
+
+/* > \ingroup realSYcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssytrf_aa_(char *uplo, integer *n, real *a, integer *
+	lda, integer *ipiv, real *work, integer *lwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+    /* Local variables */
+    integer j;
+    real alpha;
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), 
+	    sgemm_(char *, char *, integer *, integer *, integer *, real *, 
+	    real *, integer *, real *, integer *, real *, real *, integer *), slasyf_aa_(char *, integer *, integer *, 
+	    integer *, real *, integer *, integer *, real *, integer *, real *
+	    ), sgemv_(char *, integer *, integer *, real *, real *, 
+	    integer *, real *, integer *, real *, real *, integer *);
+    logical upper;
+    integer k1, k2, j1, j2, j3;
+    extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, 
+	    integer *), sswap_(integer *, real *, integer *, real *, integer *
+	    );
+    integer jb, nb, mj, nj;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
+	    integer *, integer *, ftnlen, ftnlen);
+    integer lwkopt;
+    logical lquery;
+
+
+/*  -- LAPACK computational routine (version 3.8.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     November 2017 */
+
+
+
+/*  ===================================================================== */
+
+
+/*     Determine the block size */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --ipiv;
+    --work;
+
+    /* Function Body */
+    nb = ilaenv_(&c__1, "SSYTRF_AA", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)9, 
+	    (ftnlen)1);
+
+/*     Test the input parameters. */
+
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    lquery = *lwork == -1;
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -4;
+    } else /* if(complicated condition) */ {
+/* Computing MAX */
+	i__1 = 1, i__2 = *n << 1;
+	if (*lwork < f2cmax(i__1,i__2) && ! lquery) {
+	    *info = -7;
+	}
+    }
+
+    if (*info == 0) {
+	lwkopt = (nb + 1) * *n;
+	work[1] = (real) lwkopt;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYTRF_AA", &i__1, (ftnlen)9);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Quick return */
+
+    if (*n == 0) {
+	return 0;
+    }
+    ipiv[1] = 1;
+    if (*n == 1) {
+	return 0;
+    }
+
+/*     Adjust block size based on the workspace size */
+
+    if (*lwork < (nb + 1) * *n) {
+	nb = (*lwork - *n) / *n;
+    }
+
+    if (upper) {
+
+/*        ..................................................... */
+/*        Factorize A as U**T*D*U using the upper triangle of A */
+/*        ..................................................... */
+
+/*        Copy first row A(1, 1:N) into H(1:n) (stored in WORK(1:N)) */
+
+	scopy_(n, &a[a_dim1 + 1], lda, &work[1], &c__1);
+
+/*        J is the main loop index, increasing from 1 to N in steps of */
+/*        JB, where JB is the number of columns factorized by SLASYF; */
+/*        JB is either NB, or N-J+1 for the last block */
+
+	j = 0;
+L10:
+	if (j >= *n) {
+	    goto L20;
+	}
+
+/*        each step of the main loop */
+/*         J is the last column of the previous panel */
+/*         J1 is the first column of the current panel */
+/*         K1 identifies if the previous column of the panel has been */
+/*          explicitly stored, e.g., K1=1 for the first panel, and */
+/*          K1=0 for the rest */
+
+	j1 = j + 1;
+/* Computing MIN */
+	i__1 = *n - j1 + 1;
+	jb = f2cmin(i__1,nb);
+	k1 = f2cmax(1,j) - j;
+
+/*        Panel factorization */
+
+	i__1 = 2 - k1;
+	i__2 = *n - j;
+	slasyf_aa_(uplo, &i__1, &i__2, &jb, &a[f2cmax(1,j) + (j + 1) * a_dim1], 
+		lda, &ipiv[j + 1], &work[1], n, &work[*n * nb + 1])
+		;
+
+/*        Adjust IPIV and apply it back (J-th step picks (J+1)-th pivot) */
+
+/* Computing MIN */
+	i__2 = *n, i__3 = j + jb + 1;
+	i__1 = f2cmin(i__2,i__3);
+	for (j2 = j + 2; j2 <= i__1; ++j2) {
+	    ipiv[j2] += j;
+	    if (j2 != ipiv[j2] && j1 - k1 > 2) {
+		i__2 = j1 - k1 - 2;
+		sswap_(&i__2, &a[j2 * a_dim1 + 1], &c__1, &a[ipiv[j2] * 
+			a_dim1 + 1], &c__1);
+	    }
+	}
+	j += jb;
+
+/*        Trailing submatrix update, where */
+/*         the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and */
+/*         WORK stores the current block of the auxiriarly matrix H */
+
+	if (j < *n) {
+
+/*           If first panel and JB=1 (NB=1), then nothing to do */
+
+	    if (j1 > 1 || jb > 1) {
+
+/*              Merge rank-1 update with BLAS-3 update */
+
+		alpha = a[j + (j + 1) * a_dim1];
+		a[j + (j + 1) * a_dim1] = 1.f;
+		i__1 = *n - j;
+		scopy_(&i__1, &a[j - 1 + (j + 1) * a_dim1], lda, &work[j + 1 
+			- j1 + 1 + jb * *n], &c__1);
+		i__1 = *n - j;
+		sscal_(&i__1, &alpha, &work[j + 1 - j1 + 1 + jb * *n], &c__1);
+
+/*              K1 identifies if the previous column of the panel has been */
+/*               explicitly stored, e.g., K1=1 and K2= 0 for the first panel, */
+/*               while K1=0 and K2=1 for the rest */
+
+		if (j1 > 1) {
+
+/*                 Not first panel */
+
+		    k2 = 1;
+		} else {
+
+/*                 First panel */
+
+		    k2 = 0;
+
+/*                 First update skips the first column */
+
+		    --jb;
+		}
+
+		i__1 = *n;
+		i__2 = nb;
+		for (j2 = j + 1; i__2 < 0 ? j2 >= i__1 : j2 <= i__1; j2 += 
+			i__2) {
+/* Computing MIN */
+		    i__3 = nb, i__4 = *n - j2 + 1;
+		    nj = f2cmin(i__3,i__4);
+
+/*                 Update (J2, J2) diagonal block with SGEMV */
+
+		    j3 = j2;
+		    for (mj = nj - 1; mj >= 1; --mj) {
+			i__3 = jb + 1;
+			sgemv_("No transpose", &mj, &i__3, &c_b18, &work[j3 - 
+				j1 + 1 + k1 * *n], n, &a[j1 - k2 + j3 * 
+				a_dim1], &c__1, &c_b20, &a[j3 + j3 * a_dim1], 
+				lda);
+			++j3;
+		    }
+
+/*                 Update off-diagonal block of J2-th block row with SGEMM */
+
+		    i__3 = *n - j3 + 1;
+		    i__4 = jb + 1;
+		    sgemm_("Transpose", "Transpose", &nj, &i__3, &i__4, &
+			    c_b18, &a[j1 - k2 + j2 * a_dim1], lda, &work[j3 - 
+			    j1 + 1 + k1 * *n], n, &c_b20, &a[j2 + j3 * a_dim1]
+			    , lda);
+		}
+
+/*              Recover T( J, J+1 ) */
+
+		a[j + (j + 1) * a_dim1] = alpha;
+	    }
+
+/*           WORK(J+1, 1) stores H(J+1, 1) */
+
+	    i__2 = *n - j;
+	    scopy_(&i__2, &a[j + 1 + (j + 1) * a_dim1], lda, &work[1], &c__1);
+	}
+	goto L10;
+    } else {
+
+/*        ..................................................... */
+/*        Factorize A as L*D*L**T using the lower triangle of A */
+/*        ..................................................... */
+
+/*        copy first column A(1:N, 1) into H(1:N, 1) */
+/*         (stored in WORK(1:N)) */
+
+	scopy_(n, &a[a_dim1 + 1], &c__1, &work[1], &c__1);
+
+/*        J is the main loop index, increasing from 1 to N in steps of */
+/*        JB, where JB is the number of columns factorized by SLASYF; */
+/*        JB is either NB, or N-J+1 for the last block */
+
+	j = 0;
+L11:
+	if (j >= *n) {
+	    goto L20;
+	}
+
+/*        each step of the main loop */
+/*         J is the last column of the previous panel */
+/*         J1 is the first column of the current panel */
+/*         K1 identifies if the previous column of the panel has been */
+/*          explicitly stored, e.g., K1=1 for the first panel, and */
+/*          K1=0 for the rest */
+
+	j1 = j + 1;
+/* Computing MIN */
+	i__2 = *n - j1 + 1;
+	jb = f2cmin(i__2,nb);
+	k1 = f2cmax(1,j) - j;
+
+/*        Panel factorization */
+
+	i__2 = 2 - k1;
+	i__1 = *n - j;
+	slasyf_aa_(uplo, &i__2, &i__1, &jb, &a[j + 1 + f2cmax(1,j) * a_dim1], 
+		lda, &ipiv[j + 1], &work[1], n, &work[*n * nb + 1])
+		;
+
+/*        Adjust IPIV and apply it back (J-th step picks (J+1)-th pivot) */
+
+/* Computing MIN */
+	i__1 = *n, i__3 = j + jb + 1;
+	i__2 = f2cmin(i__1,i__3);
+	for (j2 = j + 2; j2 <= i__2; ++j2) {
+	    ipiv[j2] += j;
+	    if (j2 != ipiv[j2] && j1 - k1 > 2) {
+		i__1 = j1 - k1 - 2;
+		sswap_(&i__1, &a[j2 + a_dim1], lda, &a[ipiv[j2] + a_dim1], 
+			lda);
+	    }
+	}
+	j += jb;
+
+/*        Trailing submatrix update, where */
+/*          A(J2+1, J1-1) stores L(J2+1, J1) and */
+/*          WORK(J2+1, 1) stores H(J2+1, 1) */
+
+	if (j < *n) {
+
+/*           if first panel and JB=1 (NB=1), then nothing to do */
+
+	    if (j1 > 1 || jb > 1) {
+
+/*              Merge rank-1 update with BLAS-3 update */
+
+		alpha = a[j + 1 + j * a_dim1];
+		a[j + 1 + j * a_dim1] = 1.f;
+		i__2 = *n - j;
+		scopy_(&i__2, &a[j + 1 + (j - 1) * a_dim1], &c__1, &work[j + 
+			1 - j1 + 1 + jb * *n], &c__1);
+		i__2 = *n - j;
+		sscal_(&i__2, &alpha, &work[j + 1 - j1 + 1 + jb * *n], &c__1);
+
+/*              K1 identifies if the previous column of the panel has been */
+/*               explicitly stored, e.g., K1=1 and K2= 0 for the first panel, */
+/*               while K1=0 and K2=1 for the rest */
+
+		if (j1 > 1) {
+
+/*                 Not first panel */
+
+		    k2 = 1;
+		} else {
+
+/*                 First panel */
+
+		    k2 = 0;
+
+/*                 First update skips the first column */
+
+		    --jb;
+		}
+
+		i__2 = *n;
+		i__1 = nb;
+		for (j2 = j + 1; i__1 < 0 ? j2 >= i__2 : j2 <= i__2; j2 += 
+			i__1) {
+/* Computing MIN */
+		    i__3 = nb, i__4 = *n - j2 + 1;
+		    nj = f2cmin(i__3,i__4);
+
+/*                 Update (J2, J2) diagonal block with SGEMV */
+
+		    j3 = j2;
+		    for (mj = nj - 1; mj >= 1; --mj) {
+			i__3 = jb + 1;
+			sgemv_("No transpose", &mj, &i__3, &c_b18, &work[j3 - 
+				j1 + 1 + k1 * *n], n, &a[j3 + (j1 - k2) * 
+				a_dim1], lda, &c_b20, &a[j3 + j3 * a_dim1], &
+				c__1);
+			++j3;
+		    }
+
+/*                 Update off-diagonal block in J2-th block column with SGEMM */
+
+		    i__3 = *n - j3 + 1;
+		    i__4 = jb + 1;
+		    sgemm_("No transpose", "Transpose", &i__3, &nj, &i__4, &
+			    c_b18, &work[j3 - j1 + 1 + k1 * *n], n, &a[j2 + (
+			    j1 - k2) * a_dim1], lda, &c_b20, &a[j3 + j2 * 
+			    a_dim1], lda);
+		}
+
+/*              Recover T( J+1, J ) */
+
+		a[j + 1 + j * a_dim1] = alpha;
+	    }
+
+/*           WORK(J+1, 1) stores H(J+1, 1) */
+
+	    i__1 = *n - j;
+	    scopy_(&i__1, &a[j + 1 + (j + 1) * a_dim1], &c__1, &work[1], &
+		    c__1);
+	}
+	goto L11;
+    }
+
+L20:
+    return 0;
+
+/*     End of SSYTRF_AA */
+
+} /* ssytrf_aa__ */
+

lapack-netlib/SRC/ssytrf_rk.c

@@ -0,0 +1,919 @@
+/* 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_n1 = -1;
+static integer c__2 = 2;
+
+/* > \brief \b SSYTRF_RK computes the factorization of a real symmetric indefinite matrix using the bounded Bu
+nch-Kaufman (rook) diagonal pivoting method (BLAS3 blocked algorithm). */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYTRF_RK + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytrf_
+rk.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytrf_
+rk.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytrf_
+rk.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, */
+/*                             INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDA, LWORK, N */
+/*       INTEGER            IPIV( * ) */
+/*       REAL               A( LDA, * ), E ( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > SSYTRF_RK computes the factorization of a real symmetric matrix A */
+/* > using the bounded Bunch-Kaufman (rook) diagonal pivoting method: */
+/* > */
+/* >    A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), */
+/* > */
+/* > where U (or L) is unit upper (or lower) triangular matrix, */
+/* > U**T (or L**T) is the transpose of U (or L), P is a permutation */
+/* > matrix, P**T is the transpose of P, and D is symmetric and block */
+/* > diagonal with 1-by-1 and 2-by-2 diagonal blocks. */
+/* > */
+/* > This is the blocked version of the algorithm, calling Level 3 BLAS. */
+/* > For more information see Further Details section. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the upper or lower triangular part of the */
+/* >          symmetric matrix A is stored: */
+/* >          = 'U':  Upper triangular */
+/* >          = 'L':  Lower triangular */
+/* > \endverbatim */
+/* > */
+/* > \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 symmetric matrix A. */
+/* >            If UPLO = 'U': the leading N-by-N upper triangular part */
+/* >            of A contains the upper triangular part of the matrix A, */
+/* >            and the strictly lower triangular part of A is not */
+/* >            referenced. */
+/* > */
+/* >            If UPLO = 'L': the leading N-by-N lower triangular part */
+/* >            of A contains the lower triangular part of the matrix A, */
+/* >            and the strictly upper triangular part of A is not */
+/* >            referenced. */
+/* > */
+/* >          On exit, contains: */
+/* >            a) ONLY diagonal elements of the symmetric block diagonal */
+/* >               matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */
+/* >               (superdiagonal (or subdiagonal) elements of D */
+/* >                are stored on exit in array E), and */
+/* >            b) If UPLO = 'U': factor U in the superdiagonal part of A. */
+/* >               If UPLO = 'L': factor L in the subdiagonal part of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] E */
+/* > \verbatim */
+/* >          E is REAL array, dimension (N) */
+/* >          On exit, contains the superdiagonal (or subdiagonal) */
+/* >          elements of the symmetric block diagonal matrix D */
+/* >          with 1-by-1 or 2-by-2 diagonal blocks, where */
+/* >          If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; */
+/* >          If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. */
+/* > */
+/* >          NOTE: For 1-by-1 diagonal block D(k), where */
+/* >          1 <= k <= N, the element E(k) is set to 0 in both */
+/* >          UPLO = 'U' or UPLO = 'L' cases. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          IPIV describes the permutation matrix P in the factorization */
+/* >          of matrix A as follows. The absolute value of IPIV(k) */
+/* >          represents the index of row and column that were */
+/* >          interchanged with the k-th row and column. The value of UPLO */
+/* >          describes the order in which the interchanges were applied. */
+/* >          Also, the sign of IPIV represents the block structure of */
+/* >          the symmetric block diagonal matrix D with 1-by-1 or 2-by-2 */
+/* >          diagonal blocks which correspond to 1 or 2 interchanges */
+/* >          at each factorization step. For more info see Further */
+/* >          Details section. */
+/* > */
+/* >          If UPLO = 'U', */
+/* >          ( in factorization order, k decreases from N to 1 ): */
+/* >            a) A single positive entry IPIV(k) > 0 means: */
+/* >               D(k,k) is a 1-by-1 diagonal block. */
+/* >               If IPIV(k) != k, rows and columns k and IPIV(k) were */
+/* >               interchanged in the matrix A(1:N,1:N); */
+/* >               If IPIV(k) = k, no interchange occurred. */
+/* > */
+/* >            b) A pair of consecutive negative entries */
+/* >               IPIV(k) < 0 and IPIV(k-1) < 0 means: */
+/* >               D(k-1:k,k-1:k) is a 2-by-2 diagonal block. */
+/* >               (NOTE: negative entries in IPIV appear ONLY in pairs). */
+/* >               1) If -IPIV(k) != k, rows and columns */
+/* >                  k and -IPIV(k) were interchanged */
+/* >                  in the matrix A(1:N,1:N). */
+/* >                  If -IPIV(k) = k, no interchange occurred. */
+/* >               2) If -IPIV(k-1) != k-1, rows and columns */
+/* >                  k-1 and -IPIV(k-1) were interchanged */
+/* >                  in the matrix A(1:N,1:N). */
+/* >                  If -IPIV(k-1) = k-1, no interchange occurred. */
+/* > */
+/* >            c) In both cases a) and b), always ABS( IPIV(k) ) <= k. */
+/* > */
+/* >            d) NOTE: Any entry IPIV(k) is always NONZERO on output. */
+/* > */
+/* >          If UPLO = 'L', */
+/* >          ( in factorization order, k increases from 1 to N ): */
+/* >            a) A single positive entry IPIV(k) > 0 means: */
+/* >               D(k,k) is a 1-by-1 diagonal block. */
+/* >               If IPIV(k) != k, rows and columns k and IPIV(k) were */
+/* >               interchanged in the matrix A(1:N,1:N). */
+/* >               If IPIV(k) = k, no interchange occurred. */
+/* > */
+/* >            b) A pair of consecutive negative entries */
+/* >               IPIV(k) < 0 and IPIV(k+1) < 0 means: */
+/* >               D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+/* >               (NOTE: negative entries in IPIV appear ONLY in pairs). */
+/* >               1) If -IPIV(k) != k, rows and columns */
+/* >                  k and -IPIV(k) were interchanged */
+/* >                  in the matrix A(1:N,1:N). */
+/* >                  If -IPIV(k) = k, no interchange occurred. */
+/* >               2) If -IPIV(k+1) != k+1, rows and columns */
+/* >                  k-1 and -IPIV(k-1) were interchanged */
+/* >                  in the matrix A(1:N,1:N). */
+/* >                  If -IPIV(k+1) = k+1, no interchange occurred. */
+/* > */
+/* >            c) In both cases a) and b), always ABS( IPIV(k) ) >= k. */
+/* > */
+/* >            d) NOTE: Any entry IPIV(k) is always NONZERO on output. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension ( MAX(1,LWORK) ). */
+/* >          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The length of WORK.  LWORK >=1.  For best performance */
+/* >          LWORK >= N*NB, where NB is the block size returned */
+/* >          by ILAENV. */
+/* > */
+/* >          If LWORK = -1, then a workspace query is assumed; */
+/* >          the routine only calculates the optimal size of the WORK */
+/* >          array, returns this value as the first entry of the WORK */
+/* >          array, and no error message related to LWORK is issued */
+/* >          by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit */
+/* > */
+/* >          < 0: If INFO = -k, the k-th argument had an illegal value */
+/* > */
+/* >          > 0: If INFO = k, the matrix A is singular, because: */
+/* >                 If UPLO = 'U': column k in the upper */
+/* >                 triangular part of A contains all zeros. */
+/* >                 If UPLO = 'L': column k in the lower */
+/* >                 triangular part of A contains all zeros. */
+/* > */
+/* >               Therefore D(k,k) is exactly zero, and superdiagonal */
+/* >               elements of column k of U (or subdiagonal elements of */
+/* >               column k of L ) are all zeros. The factorization has */
+/* >               been completed, but the block diagonal matrix D is */
+/* >               exactly singular, and division by zero will occur if */
+/* >               it is used to solve a system of equations. */
+/* > */
+/* >               NOTE: INFO only stores the first occurrence of */
+/* >               a singularity, any subsequent occurrence of singularity */
+/* >               is not stored in INFO even though the factorization */
+/* >               always completes. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup singleSYcomputational */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > TODO: put correct description */
+/* > \endverbatim */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  December 2016,  Igor Kozachenko, */
+/* >                  Computer Science Division, */
+/* >                  University of California, Berkeley */
+/* > */
+/* >  September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */
+/* >                  School of Mathematics, */
+/* >                  University of Manchester */
+/* > */
+/* > \endverbatim */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssytrf_rk_(char *uplo, integer *n, real *a, integer *
+	lda, real *e, integer *ipiv, real *work, integer *lwork, integer *
+	info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+
+    /* Local variables */
+    integer i__, k;
+    extern logical lsame_(char *, char *);
+    integer nbmin, iinfo;
+    extern /* Subroutine */ int ssytf2_rk_(char *, integer *, real *, 
+	    integer *, real *, integer *, integer *);
+    logical upper;
+    extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, 
+	    integer *), slasyf_rk_(char *, integer *, integer *, integer *, 
+	    real *, integer *, real *, integer *, real *, integer *, integer *
+	    );
+    integer kb, nb, ip;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
+	    integer *, integer *, ftnlen, ftnlen);
+    integer ldwork, lwkopt;
+    logical lquery;
+    integer iws;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --e;
+    --ipiv;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    lquery = *lwork == -1;
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -4;
+    } else if (*lwork < 1 && ! lquery) {
+	*info = -8;
+    }
+
+    if (*info == 0) {
+
+/*        Determine the block size */
+
+	nb = ilaenv_(&c__1, "SSYTRF_RK", uplo, n, &c_n1, &c_n1, &c_n1, (
+		ftnlen)9, (ftnlen)1);
+	lwkopt = *n * nb;
+	work[1] = (real) lwkopt;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYTRF_RK", &i__1, (ftnlen)9);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+    nbmin = 2;
+    ldwork = *n;
+    if (nb > 1 && nb < *n) {
+	iws = ldwork * nb;
+	if (*lwork < iws) {
+/* Computing MAX */
+	    i__1 = *lwork / ldwork;
+	    nb = f2cmax(i__1,1);
+/* Computing MAX */
+	    i__1 = 2, i__2 = ilaenv_(&c__2, "SSYTRF_RK", uplo, n, &c_n1, &
+		    c_n1, &c_n1, (ftnlen)9, (ftnlen)1);
+	    nbmin = f2cmax(i__1,i__2);
+	}
+    } else {
+	iws = 1;
+    }
+    if (nb < nbmin) {
+	nb = *n;
+    }
+
+    if (upper) {
+
+/*        Factorize A as U*D*U**T using the upper triangle of A */
+
+/*        K is the main loop index, decreasing from N to 1 in steps of */
+/*        KB, where KB is the number of columns factorized by SLASYF_RK; */
+/*        KB is either NB or NB-1, or K for the last block */
+
+	k = *n;
+L10:
+
+/*        If K < 1, exit from loop */
+
+	if (k < 1) {
+	    goto L15;
+	}
+
+	if (k > nb) {
+
+/*           Factorize columns k-kb+1:k of A and use blocked code to */
+/*           update columns 1:k-kb */
+
+	    slasyf_rk_(uplo, &k, &nb, &kb, &a[a_offset], lda, &e[1], &ipiv[1]
+		    , &work[1], &ldwork, &iinfo);
+	} else {
+
+/*           Use unblocked code to factorize columns 1:k of A */
+
+	    ssytf2_rk_(uplo, &k, &a[a_offset], lda, &e[1], &ipiv[1], &iinfo);
+	    kb = k;
+	}
+
+/*        Set INFO on the first occurrence of a zero pivot */
+
+	if (*info == 0 && iinfo > 0) {
+	    *info = iinfo;
+	}
+
+/*        No need to adjust IPIV */
+
+
+/*        Apply permutations to the leading panel 1:k-1 */
+
+/*        Read IPIV from the last block factored, i.e. */
+/*        indices  k-kb+1:k and apply row permutations to the */
+/*        last k+1 colunms k+1:N after that block */
+/*        (We can do the simple loop over IPIV with decrement -1, */
+/*        since the ABS value of IPIV( I ) represents the row index */
+/*        of the interchange with row i in both 1x1 and 2x2 pivot cases) */
+
+	if (k < *n) {
+	    i__1 = k - kb + 1;
+	    for (i__ = k; i__ >= i__1; --i__) {
+		ip = (i__2 = ipiv[i__], abs(i__2));
+		if (ip != i__) {
+		    i__2 = *n - k;
+		    sswap_(&i__2, &a[i__ + (k + 1) * a_dim1], lda, &a[ip + (k 
+			    + 1) * a_dim1], lda);
+		}
+	    }
+	}
+
+/*        Decrease K and return to the start of the main loop */
+
+	k -= kb;
+	goto L10;
+
+/*        This label is the exit from main loop over K decreasing */
+/*        from N to 1 in steps of KB */
+
+L15:
+
+	;
+    } else {
+
+/*        Factorize A as L*D*L**T using the lower triangle of A */
+
+/*        K is the main loop index, increasing from 1 to N in steps of */
+/*        KB, where KB is the number of columns factorized by SLASYF_RK; */
+/*        KB is either NB or NB-1, or N-K+1 for the last block */
+
+	k = 1;
+L20:
+
+/*        If K > N, exit from loop */
+
+	if (k > *n) {
+	    goto L35;
+	}
+
+	if (k <= *n - nb) {
+
+/*           Factorize columns k:k+kb-1 of A and use blocked code to */
+/*           update columns k+kb:n */
+
+	    i__1 = *n - k + 1;
+	    slasyf_rk_(uplo, &i__1, &nb, &kb, &a[k + k * a_dim1], lda, &e[k],
+		     &ipiv[k], &work[1], &ldwork, &iinfo);
+	} else {
+
+/*           Use unblocked code to factorize columns k:n of A */
+
+	    i__1 = *n - k + 1;
+	    ssytf2_rk_(uplo, &i__1, &a[k + k * a_dim1], lda, &e[k], &ipiv[k],
+		     &iinfo);
+	    kb = *n - k + 1;
+
+	}
+
+/*        Set INFO on the first occurrence of a zero pivot */
+
+	if (*info == 0 && iinfo > 0) {
+	    *info = iinfo + k - 1;
+	}
+
+/*        Adjust IPIV */
+
+	i__1 = k + kb - 1;
+	for (i__ = k; i__ <= i__1; ++i__) {
+	    if (ipiv[i__] > 0) {
+		ipiv[i__] = ipiv[i__] + k - 1;
+	    } else {
+		ipiv[i__] = ipiv[i__] - k + 1;
+	    }
+	}
+
+/*        Apply permutations to the leading panel 1:k-1 */
+
+/*        Read IPIV from the last block factored, i.e. */
+/*        indices  k:k+kb-1 and apply row permutations to the */
+/*        first k-1 colunms 1:k-1 before that block */
+/*        (We can do the simple loop over IPIV with increment 1, */
+/*        since the ABS value of IPIV( I ) represents the row index */
+/*        of the interchange with row i in both 1x1 and 2x2 pivot cases) */
+
+	if (k > 1) {
+	    i__1 = k + kb - 1;
+	    for (i__ = k; i__ <= i__1; ++i__) {
+		ip = (i__2 = ipiv[i__], abs(i__2));
+		if (ip != i__) {
+		    i__2 = k - 1;
+		    sswap_(&i__2, &a[i__ + a_dim1], lda, &a[ip + a_dim1], lda)
+			    ;
+		}
+	    }
+	}
+
+/*        Increase K and return to the start of the main loop */
+
+	k += kb;
+	goto L20;
+
+/*        This label is the exit from main loop over K increasing */
+/*        from 1 to N in steps of KB */
+
+L35:
+
+/*     End Lower */
+
+	;
+    }
+
+    work[1] = (real) lwkopt;
+    return 0;
+
+/*     End of SSYTRF_RK */
+
+} /* ssytrf_rk__ */
+

lapack-netlib/SRC/ssytrf_rook.c

@@ -0,0 +1,810 @@
+/* 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_n1 = -1;
+static integer c__2 = 2;
+
+/* > \brief \b SSYTRF_ROOK */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYTRF_ROOK + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytrf_
+rook.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytrf_
+rook.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytrf_
+rook.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDA, LWORK, N */
+/*       INTEGER            IPIV( * ) */
+/*       REAL               A( LDA, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYTRF_ROOK computes the factorization of a real symmetric matrix A */
+/* > using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. */
+/* > The form of the factorization is */
+/* > */
+/* >    A = U*D*U**T  or  A = L*D*L**T */
+/* > */
+/* > where U (or L) is a product of permutation and unit upper (lower) */
+/* > triangular matrices, and D is symmetric and block diagonal with */
+/* > 1-by-1 and 2-by-2 diagonal blocks. */
+/* > */
+/* > This is the blocked version of the algorithm, calling Level 3 BLAS. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \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 symmetric matrix A.  If UPLO = 'U', the leading */
+/* >          N-by-N upper triangular part of A contains the upper */
+/* >          triangular part of the matrix A, and the strictly lower */
+/* >          triangular part of A is not referenced.  If UPLO = 'L', the */
+/* >          leading N-by-N lower triangular part of A contains the lower */
+/* >          triangular part of the matrix A, and the strictly upper */
+/* >          triangular part of A is not referenced. */
+/* > */
+/* >          On exit, the block diagonal matrix D and the multipliers used */
+/* >          to obtain the factor U or L (see below for further details). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges and the block structure of D. */
+/* > */
+/* >          If UPLO = 'U': */
+/* >               If IPIV(k) > 0, then rows and columns k and IPIV(k) */
+/* >               were interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* > */
+/* >               If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and */
+/* >               columns k and -IPIV(k) were interchanged and rows and */
+/* >               columns k-1 and -IPIV(k-1) were inerchaged, */
+/* >               D(k-1:k,k-1:k) is a 2-by-2 diagonal block. */
+/* > */
+/* >          If UPLO = 'L': */
+/* >               If IPIV(k) > 0, then rows and columns k and IPIV(k) */
+/* >               were interchanged and D(k,k) is a 1-by-1 diagonal block. */
+/* > */
+/* >               If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and */
+/* >               columns k and -IPIV(k) were interchanged and rows and */
+/* >               columns k+1 and -IPIV(k+1) were inerchaged, */
+/* >               D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (MAX(1,LWORK)). */
+/* >          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The length of WORK.  LWORK >=1.  For best performance */
+/* >          LWORK >= N*NB, where NB is the block size returned by ILAENV. */
+/* > */
+/* >          If LWORK = -1, then a workspace query is assumed; the routine */
+/* >          only calculates the optimal size of the WORK array, returns */
+/* >          this value as the first entry of the WORK array, and no error */
+/* >          message related to LWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0:  if INFO = i, D(i,i) is exactly zero.  The factorization */
+/* >                has been completed, but the block diagonal matrix D is */
+/* >                exactly singular, and division by zero will occur if it */
+/* >                is used to solve a system of equations. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date June 2016 */
+
+/* > \ingroup realSYcomputational */
+
+/* > \par Further Details: */
+/*  ===================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  If UPLO = 'U', then A = U*D*U**T, where */
+/* >     U = P(n)*U(n)* ... *P(k)U(k)* ..., */
+/* >  i.e., U is a product of terms P(k)*U(k), where k decreases from n to */
+/* >  1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* >  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as */
+/* >  defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */
+/* >  that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+/* > */
+/* >             (   I    v    0   )   k-s */
+/* >     U(k) =  (   0    I    0   )   s */
+/* >             (   0    0    I   )   n-k */
+/* >                k-s   s   n-k */
+/* > */
+/* >  If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */
+/* >  If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */
+/* >  and A(k,k), and v overwrites A(1:k-2,k-1:k). */
+/* > */
+/* >  If UPLO = 'L', then A = L*D*L**T, where */
+/* >     L = P(1)*L(1)* ... *P(k)*L(k)* ..., */
+/* >  i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */
+/* >  n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */
+/* >  and 2-by-2 diagonal blocks D(k).  P(k) is a permutation matrix as */
+/* >  defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */
+/* >  that if the diagonal block D(k) is of order s (s = 1 or 2), then */
+/* > */
+/* >             (   I    0     0   )  k-1 */
+/* >     L(k) =  (   0    I     0   )  s */
+/* >             (   0    v     I   )  n-k-s+1 */
+/* >                k-1   s  n-k-s+1 */
+/* > */
+/* >  If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */
+/* >  If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */
+/* >  and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */
+/* > \endverbatim */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >   June 2016, Igor Kozachenko, */
+/* >                  Computer Science Division, */
+/* >                  University of California, Berkeley */
+/* > */
+/* >  September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */
+/* >                  School of Mathematics, */
+/* >                  University of Manchester */
+/* > */
+/* > \endverbatim */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssytrf_rook_(char *uplo, integer *n, real *a, integer *
+	lda, integer *ipiv, real *work, integer *lwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+
+    /* Local variables */
+    integer j, k;
+    extern logical lsame_(char *, char *);
+    integer nbmin, iinfo;
+    logical upper;
+    integer kb, nb;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
+	    integer *, integer *, ftnlen, ftnlen);
+    integer ldwork, lwkopt;
+    logical lquery;
+    integer iws;
+    extern /* Subroutine */ int ssytf2_rook_(char *, integer *, real *, 
+	    integer *, integer *, integer *), slasyf_rook_(char *, 
+	    integer *, integer *, integer *, real *, integer *, integer *, 
+	    real *, integer *, integer *);
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     June 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --ipiv;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    lquery = *lwork == -1;
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -4;
+    } else if (*lwork < 1 && ! lquery) {
+	*info = -7;
+    }
+
+    if (*info == 0) {
+
+/*        Determine the block size */
+
+	nb = ilaenv_(&c__1, "SSYTRF_ROOK", uplo, n, &c_n1, &c_n1, &c_n1, (
+		ftnlen)11, (ftnlen)1);
+/* Computing MAX */
+	i__1 = 1, i__2 = *n * nb;
+	lwkopt = f2cmax(i__1,i__2);
+	work[1] = (real) lwkopt;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYTRF_ROOK", &i__1, (ftnlen)11);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+    nbmin = 2;
+    ldwork = *n;
+    if (nb > 1 && nb < *n) {
+	iws = ldwork * nb;
+	if (*lwork < iws) {
+/* Computing MAX */
+	    i__1 = *lwork / ldwork;
+	    nb = f2cmax(i__1,1);
+/* Computing MAX */
+	    i__1 = 2, i__2 = ilaenv_(&c__2, "SSYTRF_ROOK", uplo, n, &c_n1, &
+		    c_n1, &c_n1, (ftnlen)11, (ftnlen)1);
+	    nbmin = f2cmax(i__1,i__2);
+	}
+    } else {
+	iws = 1;
+    }
+    if (nb < nbmin) {
+	nb = *n;
+    }
+
+    if (upper) {
+
+/*        Factorize A as U*D*U**T using the upper triangle of A */
+
+/*        K is the main loop index, decreasing from N to 1 in steps of */
+/*        KB, where KB is the number of columns factorized by SLASYF_ROOK; */
+/*        KB is either NB or NB-1, or K for the last block */
+
+	k = *n;
+L10:
+
+/*        If K < 1, exit from loop */
+
+	if (k < 1) {
+	    goto L40;
+	}
+
+	if (k > nb) {
+
+/*           Factorize columns k-kb+1:k of A and use blocked code to */
+/*           update columns 1:k-kb */
+
+	    slasyf_rook_(uplo, &k, &nb, &kb, &a[a_offset], lda, &ipiv[1], &
+		    work[1], &ldwork, &iinfo);
+	} else {
+
+/*           Use unblocked code to factorize columns 1:k of A */
+
+	    ssytf2_rook_(uplo, &k, &a[a_offset], lda, &ipiv[1], &iinfo);
+	    kb = k;
+	}
+
+/*        Set INFO on the first occurrence of a zero pivot */
+
+	if (*info == 0 && iinfo > 0) {
+	    *info = iinfo;
+	}
+
+/*        No need to adjust IPIV */
+
+/*        Decrease K and return to the start of the main loop */
+
+	k -= kb;
+	goto L10;
+
+    } else {
+
+/*        Factorize A as L*D*L**T using the lower triangle of A */
+
+/*        K is the main loop index, increasing from 1 to N in steps of */
+/*        KB, where KB is the number of columns factorized by SLASYF_ROOK; */
+/*        KB is either NB or NB-1, or N-K+1 for the last block */
+
+	k = 1;
+L20:
+
+/*        If K > N, exit from loop */
+
+	if (k > *n) {
+	    goto L40;
+	}
+
+	if (k <= *n - nb) {
+
+/*           Factorize columns k:k+kb-1 of A and use blocked code to */
+/*           update columns k+kb:n */
+
+	    i__1 = *n - k + 1;
+	    slasyf_rook_(uplo, &i__1, &nb, &kb, &a[k + k * a_dim1], lda, &
+		    ipiv[k], &work[1], &ldwork, &iinfo);
+	} else {
+
+/*           Use unblocked code to factorize columns k:n of A */
+
+	    i__1 = *n - k + 1;
+	    ssytf2_rook_(uplo, &i__1, &a[k + k * a_dim1], lda, &ipiv[k], &
+		    iinfo);
+	    kb = *n - k + 1;
+	}
+
+/*        Set INFO on the first occurrence of a zero pivot */
+
+	if (*info == 0 && iinfo > 0) {
+	    *info = iinfo + k - 1;
+	}
+
+/*        Adjust IPIV */
+
+	i__1 = k + kb - 1;
+	for (j = k; j <= i__1; ++j) {
+	    if (ipiv[j] > 0) {
+		ipiv[j] = ipiv[j] + k - 1;
+	    } else {
+		ipiv[j] = ipiv[j] - k + 1;
+	    }
+/* L30: */
+	}
+
+/*        Increase K and return to the start of the main loop */
+
+	k += kb;
+	goto L20;
+
+    }
+
+L40:
+    work[1] = (real) lwkopt;
+    return 0;
+
+/*     End of SSYTRF_ROOK */
+
+} /* ssytrf_rook__ */
+

lapack-netlib/SRC/ssytri.c

@@ -0,0 +1,823 @@
+/* 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 real c_b11 = -1.f;
+static real c_b13 = 0.f;
+
+/* > \brief \b SSYTRI */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYTRI + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytri.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytri.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytri.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDA, N */
+/*       INTEGER            IPIV( * ) */
+/*       REAL               A( LDA, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYTRI computes the inverse of a real symmetric indefinite matrix */
+/* > A using the factorization A = U*D*U**T or A = L*D*L**T computed by */
+/* > SSYTRF. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the details of the factorization are stored */
+/* >          as an upper or lower triangular matrix. */
+/* >          = 'U':  Upper triangular, form is A = U*D*U**T; */
+/* >          = 'L':  Lower triangular, form is A = L*D*L**T. */
+/* > \endverbatim */
+/* > */
+/* > \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 block diagonal matrix D and the multipliers */
+/* >          used to obtain the factor U or L as computed by SSYTRF. */
+/* > */
+/* >          On exit, if INFO = 0, the (symmetric) inverse of the original */
+/* >          matrix.  If UPLO = 'U', the upper triangular part of the */
+/* >          inverse is formed and the part of A below the diagonal is not */
+/* >          referenced; if UPLO = 'L' the lower triangular part of the */
+/* >          inverse is formed and the part of A above the diagonal is */
+/* >          not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges and the block structure of D */
+/* >          as determined by SSYTRF. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit */
+/* >          < 0: if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */
+/* >               inverse could not be computed. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realSYcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssytri_(char *uplo, integer *n, real *a, integer *lda, 
+	integer *ipiv, real *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1;
+    real r__1;
+
+    /* Local variables */
+    real temp;
+    extern real sdot_(integer *, real *, integer *, real *, integer *);
+    real akkp1, d__;
+    integer k;
+    real t;
+    extern logical lsame_(char *, char *);
+    integer kstep;
+    logical upper;
+    extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, 
+	    integer *), sswap_(integer *, real *, integer *, real *, integer *
+	    ), ssymv_(char *, integer *, real *, real *, integer *, real *, 
+	    integer *, real *, real *, integer *);
+    real ak;
+    integer kp;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    real akp1;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --ipiv;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -4;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYTRI", &i__1, (ftnlen)6);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+/*     Check that the diagonal matrix D is nonsingular. */
+
+    if (upper) {
+
+/*        Upper triangular storage: examine D from bottom to top */
+
+	for (*info = *n; *info >= 1; --(*info)) {
+	    if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.f) {
+		return 0;
+	    }
+/* L10: */
+	}
+    } else {
+
+/*        Lower triangular storage: examine D from top to bottom. */
+
+	i__1 = *n;
+	for (*info = 1; *info <= i__1; ++(*info)) {
+	    if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.f) {
+		return 0;
+	    }
+/* L20: */
+	}
+    }
+    *info = 0;
+
+    if (upper) {
+
+/*        Compute inv(A) from the factorization A = U*D*U**T. */
+
+/*        K is the main loop index, increasing from 1 to N in steps of */
+/*        1 or 2, depending on the size of the diagonal blocks. */
+
+	k = 1;
+L30:
+
+/*        If K > N, exit from loop. */
+
+	if (k > *n) {
+	    goto L40;
+	}
+
+	if (ipiv[k] > 0) {
+
+/*           1 x 1 diagonal block */
+
+/*           Invert the diagonal block. */
+
+	    a[k + k * a_dim1] = 1.f / a[k + k * a_dim1];
+
+/*           Compute column K of the inverse. */
+
+	    if (k > 1) {
+		i__1 = k - 1;
+		scopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
+		i__1 = k - 1;
+		ssymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
+			c__1, &c_b13, &a[k * a_dim1 + 1], &c__1);
+		i__1 = k - 1;
+		a[k + k * a_dim1] -= sdot_(&i__1, &work[1], &c__1, &a[k * 
+			a_dim1 + 1], &c__1);
+	    }
+	    kstep = 1;
+	} else {
+
+/*           2 x 2 diagonal block */
+
+/*           Invert the diagonal block. */
+
+	    t = (r__1 = a[k + (k + 1) * a_dim1], abs(r__1));
+	    ak = a[k + k * a_dim1] / t;
+	    akp1 = a[k + 1 + (k + 1) * a_dim1] / t;
+	    akkp1 = a[k + (k + 1) * a_dim1] / t;
+	    d__ = t * (ak * akp1 - 1.f);
+	    a[k + k * a_dim1] = akp1 / d__;
+	    a[k + 1 + (k + 1) * a_dim1] = ak / d__;
+	    a[k + (k + 1) * a_dim1] = -akkp1 / d__;
+
+/*           Compute columns K and K+1 of the inverse. */
+
+	    if (k > 1) {
+		i__1 = k - 1;
+		scopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
+		i__1 = k - 1;
+		ssymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
+			c__1, &c_b13, &a[k * a_dim1 + 1], &c__1);
+		i__1 = k - 1;
+		a[k + k * a_dim1] -= sdot_(&i__1, &work[1], &c__1, &a[k * 
+			a_dim1 + 1], &c__1);
+		i__1 = k - 1;
+		a[k + (k + 1) * a_dim1] -= sdot_(&i__1, &a[k * a_dim1 + 1], &
+			c__1, &a[(k + 1) * a_dim1 + 1], &c__1);
+		i__1 = k - 1;
+		scopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], &
+			c__1);
+		i__1 = k - 1;
+		ssymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
+			c__1, &c_b13, &a[(k + 1) * a_dim1 + 1], &c__1);
+		i__1 = k - 1;
+		a[k + 1 + (k + 1) * a_dim1] -= sdot_(&i__1, &work[1], &c__1, &
+			a[(k + 1) * a_dim1 + 1], &c__1);
+	    }
+	    kstep = 2;
+	}
+
+	kp = (i__1 = ipiv[k], abs(i__1));
+	if (kp != k) {
+
+/*           Interchange rows and columns K and KP in the leading */
+/*           submatrix A(1:k+1,1:k+1) */
+
+	    i__1 = kp - 1;
+	    sswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], &
+		    c__1);
+	    i__1 = k - kp - 1;
+	    sswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1) * 
+		    a_dim1], lda);
+	    temp = a[k + k * a_dim1];
+	    a[k + k * a_dim1] = a[kp + kp * a_dim1];
+	    a[kp + kp * a_dim1] = temp;
+	    if (kstep == 2) {
+		temp = a[k + (k + 1) * a_dim1];
+		a[k + (k + 1) * a_dim1] = a[kp + (k + 1) * a_dim1];
+		a[kp + (k + 1) * a_dim1] = temp;
+	    }
+	}
+
+	k += kstep;
+	goto L30;
+L40:
+
+	;
+    } else {
+
+/*        Compute inv(A) from the factorization A = L*D*L**T. */
+
+/*        K is the main loop index, increasing from 1 to N in steps of */
+/*        1 or 2, depending on the size of the diagonal blocks. */
+
+	k = *n;
+L50:
+
+/*        If K < 1, exit from loop. */
+
+	if (k < 1) {
+	    goto L60;
+	}
+
+	if (ipiv[k] > 0) {
+
+/*           1 x 1 diagonal block */
+
+/*           Invert the diagonal block. */
+
+	    a[k + k * a_dim1] = 1.f / a[k + k * a_dim1];
+
+/*           Compute column K of the inverse. */
+
+	    if (k < *n) {
+		i__1 = *n - k;
+		scopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
+		i__1 = *n - k;
+		ssymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda,
+			 &work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], &
+			c__1);
+		i__1 = *n - k;
+		a[k + k * a_dim1] -= sdot_(&i__1, &work[1], &c__1, &a[k + 1 + 
+			k * a_dim1], &c__1);
+	    }
+	    kstep = 1;
+	} else {
+
+/*           2 x 2 diagonal block */
+
+/*           Invert the diagonal block. */
+
+	    t = (r__1 = a[k + (k - 1) * a_dim1], abs(r__1));
+	    ak = a[k - 1 + (k - 1) * a_dim1] / t;
+	    akp1 = a[k + k * a_dim1] / t;
+	    akkp1 = a[k + (k - 1) * a_dim1] / t;
+	    d__ = t * (ak * akp1 - 1.f);
+	    a[k - 1 + (k - 1) * a_dim1] = akp1 / d__;
+	    a[k + k * a_dim1] = ak / d__;
+	    a[k + (k - 1) * a_dim1] = -akkp1 / d__;
+
+/*           Compute columns K-1 and K of the inverse. */
+
+	    if (k < *n) {
+		i__1 = *n - k;
+		scopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
+		i__1 = *n - k;
+		ssymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda,
+			 &work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], &
+			c__1);
+		i__1 = *n - k;
+		a[k + k * a_dim1] -= sdot_(&i__1, &work[1], &c__1, &a[k + 1 + 
+			k * a_dim1], &c__1);
+		i__1 = *n - k;
+		a[k + (k - 1) * a_dim1] -= sdot_(&i__1, &a[k + 1 + k * a_dim1]
+			, &c__1, &a[k + 1 + (k - 1) * a_dim1], &c__1);
+		i__1 = *n - k;
+		scopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], &
+			c__1);
+		i__1 = *n - k;
+		ssymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda,
+			 &work[1], &c__1, &c_b13, &a[k + 1 + (k - 1) * a_dim1]
+			, &c__1);
+		i__1 = *n - k;
+		a[k - 1 + (k - 1) * a_dim1] -= sdot_(&i__1, &work[1], &c__1, &
+			a[k + 1 + (k - 1) * a_dim1], &c__1);
+	    }
+	    kstep = 2;
+	}
+
+	kp = (i__1 = ipiv[k], abs(i__1));
+	if (kp != k) {
+
+/*           Interchange rows and columns K and KP in the trailing */
+/*           submatrix A(k-1:n,k-1:n) */
+
+	    if (kp < *n) {
+		i__1 = *n - kp;
+		sswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + kp *
+			 a_dim1], &c__1);
+	    }
+	    i__1 = kp - k - 1;
+	    sswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) * 
+		    a_dim1], lda);
+	    temp = a[k + k * a_dim1];
+	    a[k + k * a_dim1] = a[kp + kp * a_dim1];
+	    a[kp + kp * a_dim1] = temp;
+	    if (kstep == 2) {
+		temp = a[k + (k - 1) * a_dim1];
+		a[k + (k - 1) * a_dim1] = a[kp + (k - 1) * a_dim1];
+		a[kp + (k - 1) * a_dim1] = temp;
+	    }
+	}
+
+	k -= kstep;
+	goto L50;
+L60:
+	;
+    }
+
+    return 0;
+
+/*     End of SSYTRI */
+
+} /* ssytri_ */
+

lapack-netlib/SRC/ssytri2.c

@@ -0,0 +1,607 @@
+/* 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_n1 = -1;
+
+/* > \brief \b SSYTRI2 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYTRI2 + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytri2
+.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytri2
+.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytri2
+.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDA, LWORK, N */
+/*       INTEGER            IPIV( * ) */
+/*       REAL               A( LDA, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYTRI2 computes the inverse of a REAL symmetric indefinite matrix */
+/* > A using the factorization A = U*D*U**T or A = L*D*L**T computed by */
+/* > SSYTRF. SSYTRI2 sets the LEADING DIMENSION of the workspace */
+/* > before calling SSYTRI2X that actually computes the inverse. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the details of the factorization are stored */
+/* >          as an upper or lower triangular matrix. */
+/* >          = 'U':  Upper triangular, form is A = U*D*U**T; */
+/* >          = 'L':  Lower triangular, form is A = L*D*L**T. */
+/* > \endverbatim */
+/* > */
+/* > \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 block diagonal matrix D and the multipliers */
+/* >          used to obtain the factor U or L as computed by SSYTRF. */
+/* > */
+/* >          On exit, if INFO = 0, the (symmetric) inverse of the original */
+/* >          matrix.  If UPLO = 'U', the upper triangular part of the */
+/* >          inverse is formed and the part of A below the diagonal is not */
+/* >          referenced; if UPLO = 'L' the lower triangular part of the */
+/* >          inverse is formed and the part of A above the diagonal is */
+/* >          not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges and the block structure of D */
+/* >          as determined by SSYTRF. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (N+NB+1)*(NB+3) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The dimension of the array WORK. */
+/* >          WORK is size >= (N+NB+1)*(NB+3) */
+/* >          If LWORK = -1, then a workspace query is assumed; the routine */
+/* >           calculates: */
+/* >              - the optimal size of the WORK array, returns */
+/* >          this value as the first entry of the WORK array, */
+/* >              - and no error message related to LWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit */
+/* >          < 0: if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */
+/* >               inverse could not be computed. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date November 2017 */
+
+/* > \ingroup realSYcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssytri2_(char *uplo, integer *n, real *a, integer *lda, 
+	integer *ipiv, real *work, integer *lwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1;
+
+    /* Local variables */
+    extern /* Subroutine */ int ssytri2x_(char *, integer *, real *, integer *
+	    , integer *, real *, integer *, integer *);
+    extern logical lsame_(char *, char *);
+    integer nbmax;
+    logical upper;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
+	    integer *, integer *, ftnlen, ftnlen);
+    logical lquery;
+    extern /* Subroutine */ int ssytri_(char *, integer *, real *, integer *, 
+	    integer *, real *, integer *);
+    integer minsize;
+
+
+/*  -- LAPACK computational routine (version 3.8.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     November 2017 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --ipiv;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    lquery = *lwork == -1;
+/*     Get blocksize */
+    nbmax = ilaenv_(&c__1, "SSYTRF", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, 
+	    (ftnlen)1);
+    if (nbmax >= *n) {
+	minsize = *n;
+    } else {
+	minsize = (*n + nbmax + 1) * (nbmax + 3);
+    }
+
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -4;
+    } else if (*lwork < minsize && ! lquery) {
+	*info = -7;
+    }
+
+/*     Quick return if possible */
+
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYTRI2", &i__1, (ftnlen)7);
+	return 0;
+    } else if (lquery) {
+	work[1] = (real) minsize;
+	return 0;
+    }
+    if (*n == 0) {
+	return 0;
+    }
+    if (nbmax >= *n) {
+	ssytri_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], info);
+    } else {
+	ssytri2x_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], &nbmax, 
+		info);
+    }
+    return 0;
+
+/*     End of SSYTRI2 */
+
+} /* ssytri2_ */
+

lapack-netlib/SRC/ssytri_3.c

@@ -0,0 +1,648 @@
+/* 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_n1 = -1;
+
+/* > \brief \b SSYTRI_3 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYTRI_3 + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytri_
+3.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytri_
+3.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytri_
+3.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYTRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, */
+/*                            INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDA, LWORK, N */
+/*       INTEGER            IPIV( * ) */
+/*       REAL               A( LDA, * ), E( * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > SSYTRI_3 computes the inverse of a real symmetric indefinite */
+/* > matrix A using the factorization computed by SSYTRF_RK or SSYTRF_BK: */
+/* > */
+/* >     A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), */
+/* > */
+/* > where U (or L) is unit upper (or lower) triangular matrix, */
+/* > U**T (or L**T) is the transpose of U (or L), P is a permutation */
+/* > matrix, P**T is the transpose of P, and D is symmetric and block */
+/* > diagonal with 1-by-1 and 2-by-2 diagonal blocks. */
+/* > */
+/* > SSYTRI_3 sets the leading dimension of the workspace  before calling */
+/* > SSYTRI_3X that actually computes the inverse.  This is the blocked */
+/* > version of the algorithm, calling Level 3 BLAS. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the details of the factorization are */
+/* >          stored as an upper or lower triangular matrix. */
+/* >          = 'U':  Upper triangle of A is stored; */
+/* >          = 'L':  Lower triangle of A is stored. */
+/* > \endverbatim */
+/* > */
+/* > \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, diagonal of the block diagonal matrix D and */
+/* >          factors U or L as computed by SSYTRF_RK and SSYTRF_BK: */
+/* >            a) ONLY diagonal elements of the symmetric block diagonal */
+/* >               matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */
+/* >               (superdiagonal (or subdiagonal) elements of D */
+/* >                should be provided on entry in array E), and */
+/* >            b) If UPLO = 'U': factor U in the superdiagonal part of A. */
+/* >               If UPLO = 'L': factor L in the subdiagonal part of A. */
+/* > */
+/* >          On exit, if INFO = 0, the symmetric inverse of the original */
+/* >          matrix. */
+/* >             If UPLO = 'U': the upper triangular part of the inverse */
+/* >             is formed and the part of A below the diagonal is not */
+/* >             referenced; */
+/* >             If UPLO = 'L': the lower triangular part of the inverse */
+/* >             is formed and the part of A above the diagonal is not */
+/* >             referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] E */
+/* > \verbatim */
+/* >          E is REAL array, dimension (N) */
+/* >          On entry, contains the superdiagonal (or subdiagonal) */
+/* >          elements of the symmetric block diagonal matrix D */
+/* >          with 1-by-1 or 2-by-2 diagonal blocks, where */
+/* >          If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; */
+/* >          If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. */
+/* > */
+/* >          NOTE: For 1-by-1 diagonal block D(k), where */
+/* >          1 <= k <= N, the element E(k) is not referenced in both */
+/* >          UPLO = 'U' or UPLO = 'L' cases. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges and the block structure of D */
+/* >          as determined by SSYTRF_RK or SSYTRF_BK. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (N+NB+1)*(NB+3). */
+/* >          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The length of WORK. LWORK >= (N+NB+1)*(NB+3). */
+/* > */
+/* >          If LDWORK = -1, then a workspace query is assumed; */
+/* >          the routine only calculates the optimal size of the optimal */
+/* >          size of the WORK array, returns this value as the first */
+/* >          entry of the WORK array, and no error message related to */
+/* >          LWORK is issued by XERBLA. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit */
+/* >          < 0: if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */
+/* >               inverse could not be computed. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date November 2017 */
+
+/* > \ingroup singleSYcomputational */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > \verbatim */
+/* > */
+/* >  November 2017,  Igor Kozachenko, */
+/* >                  Computer Science Division, */
+/* >                  University of California, Berkeley */
+/* > */
+/* > \endverbatim */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssytri_3_(char *uplo, integer *n, real *a, integer *lda,
+	 real *e, integer *ipiv, real *work, integer *lwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+
+    /* Local variables */
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int ssytri_3x_(char *, integer *, real *, 
+	    integer *, real *, integer *, real *, integer *, integer *);
+    logical upper;
+    integer nb;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
+	    integer *, integer *, ftnlen, ftnlen);
+    integer lwkopt;
+    logical lquery;
+
+
+/*  -- LAPACK computational routine (version 3.8.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     November 2017 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --e;
+    --ipiv;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    lquery = *lwork == -1;
+
+/*     Determine the block size */
+
+/* Computing MAX */
+    i__1 = 1, i__2 = ilaenv_(&c__1, "SSYTRI_3", uplo, n, &c_n1, &c_n1, &c_n1, 
+	    (ftnlen)8, (ftnlen)1);
+    nb = f2cmax(i__1,i__2);
+    lwkopt = (*n + nb + 1) * (nb + 3);
+
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -4;
+    } else if (*lwork < lwkopt && ! lquery) {
+	*info = -8;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYTRI_3", &i__1, (ftnlen)8);
+	return 0;
+    } else if (lquery) {
+	work[1] = (real) lwkopt;
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+    ssytri_3x_(uplo, n, &a[a_offset], lda, &e[1], &ipiv[1], &work[1], &nb, 
+	    info);
+
+    work[1] = (real) lwkopt;
+
+    return 0;
+
+/*     End of SSYTRI_3 */
+
+} /* ssytri_3__ */
+

lapack-netlib/SRC/ssytri_rook.c

@@ -0,0 +1,912 @@
+/* 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 real c_b11 = -1.f;
+static real c_b13 = 0.f;
+
+/* > \brief \b SSYTRI_ROOK */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYTRI_ROOK + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytri_
+rook.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytri_
+rook.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytri_
+rook.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDA, N */
+/*       INTEGER            IPIV( * ) */
+/*       REAL               A( LDA, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYTRI_ROOK computes the inverse of a real symmetric */
+/* > matrix A using the factorization A = U*D*U**T or A = L*D*L**T */
+/* > computed by SSYTRF_ROOK. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the details of the factorization are stored */
+/* >          as an upper or lower triangular matrix. */
+/* >          = 'U':  Upper triangular, form is A = U*D*U**T; */
+/* >          = 'L':  Lower triangular, form is A = L*D*L**T. */
+/* > \endverbatim */
+/* > */
+/* > \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 block diagonal matrix D and the multipliers */
+/* >          used to obtain the factor U or L as computed by SSYTRF_ROOK. */
+/* > */
+/* >          On exit, if INFO = 0, the (symmetric) inverse of the original */
+/* >          matrix.  If UPLO = 'U', the upper triangular part of the */
+/* >          inverse is formed and the part of A below the diagonal is not */
+/* >          referenced; if UPLO = 'L' the lower triangular part of the */
+/* >          inverse is formed and the part of A above the diagonal is */
+/* >          not referenced. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges and the block structure of D */
+/* >          as determined by SSYTRF_ROOK. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0: successful exit */
+/* >          < 0: if INFO = -i, the i-th argument had an illegal value */
+/* >          > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */
+/* >               inverse could not be computed. */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date April 2012 */
+
+/* > \ingroup realSYcomputational */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >   April 2012, Igor Kozachenko, */
+/* >                  Computer Science Division, */
+/* >                  University of California, Berkeley */
+/* > */
+/* >  September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */
+/* >                  School of Mathematics, */
+/* >                  University of Manchester */
+/* > */
+/* > \endverbatim */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssytri_rook_(char *uplo, integer *n, real *a, integer *
+	lda, integer *ipiv, real *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1;
+    real r__1;
+
+    /* Local variables */
+    real temp;
+    extern real sdot_(integer *, real *, integer *, real *, integer *);
+    real akkp1, d__;
+    integer k;
+    real t;
+    extern logical lsame_(char *, char *);
+    integer kstep;
+    logical upper;
+    extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, 
+	    integer *), sswap_(integer *, real *, integer *, real *, integer *
+	    ), ssymv_(char *, integer *, real *, real *, integer *, real *, 
+	    integer *, real *, real *, integer *);
+    real ak;
+    integer kp;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    real akp1;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     April 2012 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --ipiv;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -4;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYTRI_ROOK", &i__1, (ftnlen)11);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+/*     Check that the diagonal matrix D is nonsingular. */
+
+    if (upper) {
+
+/*        Upper triangular storage: examine D from bottom to top */
+
+	for (*info = *n; *info >= 1; --(*info)) {
+	    if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.f) {
+		return 0;
+	    }
+/* L10: */
+	}
+    } else {
+
+/*        Lower triangular storage: examine D from top to bottom. */
+
+	i__1 = *n;
+	for (*info = 1; *info <= i__1; ++(*info)) {
+	    if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.f) {
+		return 0;
+	    }
+/* L20: */
+	}
+    }
+    *info = 0;
+
+    if (upper) {
+
+/*        Compute inv(A) from the factorization A = U*D*U**T. */
+
+/*        K is the main loop index, increasing from 1 to N in steps of */
+/*        1 or 2, depending on the size of the diagonal blocks. */
+
+	k = 1;
+L30:
+
+/*        If K > N, exit from loop. */
+
+	if (k > *n) {
+	    goto L40;
+	}
+
+	if (ipiv[k] > 0) {
+
+/*           1 x 1 diagonal block */
+
+/*           Invert the diagonal block. */
+
+	    a[k + k * a_dim1] = 1.f / a[k + k * a_dim1];
+
+/*           Compute column K of the inverse. */
+
+	    if (k > 1) {
+		i__1 = k - 1;
+		scopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
+		i__1 = k - 1;
+		ssymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
+			c__1, &c_b13, &a[k * a_dim1 + 1], &c__1);
+		i__1 = k - 1;
+		a[k + k * a_dim1] -= sdot_(&i__1, &work[1], &c__1, &a[k * 
+			a_dim1 + 1], &c__1);
+	    }
+	    kstep = 1;
+	} else {
+
+/*           2 x 2 diagonal block */
+
+/*           Invert the diagonal block. */
+
+	    t = (r__1 = a[k + (k + 1) * a_dim1], abs(r__1));
+	    ak = a[k + k * a_dim1] / t;
+	    akp1 = a[k + 1 + (k + 1) * a_dim1] / t;
+	    akkp1 = a[k + (k + 1) * a_dim1] / t;
+	    d__ = t * (ak * akp1 - 1.f);
+	    a[k + k * a_dim1] = akp1 / d__;
+	    a[k + 1 + (k + 1) * a_dim1] = ak / d__;
+	    a[k + (k + 1) * a_dim1] = -akkp1 / d__;
+
+/*           Compute columns K and K+1 of the inverse. */
+
+	    if (k > 1) {
+		i__1 = k - 1;
+		scopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1);
+		i__1 = k - 1;
+		ssymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
+			c__1, &c_b13, &a[k * a_dim1 + 1], &c__1);
+		i__1 = k - 1;
+		a[k + k * a_dim1] -= sdot_(&i__1, &work[1], &c__1, &a[k * 
+			a_dim1 + 1], &c__1);
+		i__1 = k - 1;
+		a[k + (k + 1) * a_dim1] -= sdot_(&i__1, &a[k * a_dim1 + 1], &
+			c__1, &a[(k + 1) * a_dim1 + 1], &c__1);
+		i__1 = k - 1;
+		scopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], &
+			c__1);
+		i__1 = k - 1;
+		ssymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], &
+			c__1, &c_b13, &a[(k + 1) * a_dim1 + 1], &c__1);
+		i__1 = k - 1;
+		a[k + 1 + (k + 1) * a_dim1] -= sdot_(&i__1, &work[1], &c__1, &
+			a[(k + 1) * a_dim1 + 1], &c__1);
+	    }
+	    kstep = 2;
+	}
+
+	if (kstep == 1) {
+
+/*           Interchange rows and columns K and IPIV(K) in the leading */
+/*           submatrix A(1:k+1,1:k+1) */
+
+	    kp = ipiv[k];
+	    if (kp != k) {
+		if (kp > 1) {
+		    i__1 = kp - 1;
+		    sswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 
+			    1], &c__1);
+		}
+		i__1 = k - kp - 1;
+		sswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1)
+			 * a_dim1], lda);
+		temp = a[k + k * a_dim1];
+		a[k + k * a_dim1] = a[kp + kp * a_dim1];
+		a[kp + kp * a_dim1] = temp;
+	    }
+	} else {
+
+/*           Interchange rows and columns K and K+1 with -IPIV(K) and */
+/*           -IPIV(K+1)in the leading submatrix A(1:k+1,1:k+1) */
+
+	    kp = -ipiv[k];
+	    if (kp != k) {
+		if (kp > 1) {
+		    i__1 = kp - 1;
+		    sswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 
+			    1], &c__1);
+		}
+		i__1 = k - kp - 1;
+		sswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1)
+			 * a_dim1], lda);
+
+		temp = a[k + k * a_dim1];
+		a[k + k * a_dim1] = a[kp + kp * a_dim1];
+		a[kp + kp * a_dim1] = temp;
+		temp = a[k + (k + 1) * a_dim1];
+		a[k + (k + 1) * a_dim1] = a[kp + (k + 1) * a_dim1];
+		a[kp + (k + 1) * a_dim1] = temp;
+	    }
+
+	    ++k;
+	    kp = -ipiv[k];
+	    if (kp != k) {
+		if (kp > 1) {
+		    i__1 = kp - 1;
+		    sswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 
+			    1], &c__1);
+		}
+		i__1 = k - kp - 1;
+		sswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1)
+			 * a_dim1], lda);
+		temp = a[k + k * a_dim1];
+		a[k + k * a_dim1] = a[kp + kp * a_dim1];
+		a[kp + kp * a_dim1] = temp;
+	    }
+	}
+
+	++k;
+	goto L30;
+L40:
+
+	;
+    } else {
+
+/*        Compute inv(A) from the factorization A = L*D*L**T. */
+
+/*        K is the main loop index, increasing from 1 to N in steps of */
+/*        1 or 2, depending on the size of the diagonal blocks. */
+
+	k = *n;
+L50:
+
+/*        If K < 1, exit from loop. */
+
+	if (k < 1) {
+	    goto L60;
+	}
+
+	if (ipiv[k] > 0) {
+
+/*           1 x 1 diagonal block */
+
+/*           Invert the diagonal block. */
+
+	    a[k + k * a_dim1] = 1.f / a[k + k * a_dim1];
+
+/*           Compute column K of the inverse. */
+
+	    if (k < *n) {
+		i__1 = *n - k;
+		scopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
+		i__1 = *n - k;
+		ssymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda,
+			 &work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], &
+			c__1);
+		i__1 = *n - k;
+		a[k + k * a_dim1] -= sdot_(&i__1, &work[1], &c__1, &a[k + 1 + 
+			k * a_dim1], &c__1);
+	    }
+	    kstep = 1;
+	} else {
+
+/*           2 x 2 diagonal block */
+
+/*           Invert the diagonal block. */
+
+	    t = (r__1 = a[k + (k - 1) * a_dim1], abs(r__1));
+	    ak = a[k - 1 + (k - 1) * a_dim1] / t;
+	    akp1 = a[k + k * a_dim1] / t;
+	    akkp1 = a[k + (k - 1) * a_dim1] / t;
+	    d__ = t * (ak * akp1 - 1.f);
+	    a[k - 1 + (k - 1) * a_dim1] = akp1 / d__;
+	    a[k + k * a_dim1] = ak / d__;
+	    a[k + (k - 1) * a_dim1] = -akkp1 / d__;
+
+/*           Compute columns K-1 and K of the inverse. */
+
+	    if (k < *n) {
+		i__1 = *n - k;
+		scopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1);
+		i__1 = *n - k;
+		ssymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda,
+			 &work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], &
+			c__1);
+		i__1 = *n - k;
+		a[k + k * a_dim1] -= sdot_(&i__1, &work[1], &c__1, &a[k + 1 + 
+			k * a_dim1], &c__1);
+		i__1 = *n - k;
+		a[k + (k - 1) * a_dim1] -= sdot_(&i__1, &a[k + 1 + k * a_dim1]
+			, &c__1, &a[k + 1 + (k - 1) * a_dim1], &c__1);
+		i__1 = *n - k;
+		scopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], &
+			c__1);
+		i__1 = *n - k;
+		ssymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda,
+			 &work[1], &c__1, &c_b13, &a[k + 1 + (k - 1) * a_dim1]
+			, &c__1);
+		i__1 = *n - k;
+		a[k - 1 + (k - 1) * a_dim1] -= sdot_(&i__1, &work[1], &c__1, &
+			a[k + 1 + (k - 1) * a_dim1], &c__1);
+	    }
+	    kstep = 2;
+	}
+
+	if (kstep == 1) {
+
+/*           Interchange rows and columns K and IPIV(K) in the trailing */
+/*           submatrix A(k-1:n,k-1:n) */
+
+	    kp = ipiv[k];
+	    if (kp != k) {
+		if (kp < *n) {
+		    i__1 = *n - kp;
+		    sswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + 
+			    kp * a_dim1], &c__1);
+		}
+		i__1 = kp - k - 1;
+		sswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) *
+			 a_dim1], lda);
+		temp = a[k + k * a_dim1];
+		a[k + k * a_dim1] = a[kp + kp * a_dim1];
+		a[kp + kp * a_dim1] = temp;
+	    }
+	} else {
+
+/*           Interchange rows and columns K and K-1 with -IPIV(K) and */
+/*           -IPIV(K-1) in the trailing submatrix A(k-1:n,k-1:n) */
+
+	    kp = -ipiv[k];
+	    if (kp != k) {
+		if (kp < *n) {
+		    i__1 = *n - kp;
+		    sswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + 
+			    kp * a_dim1], &c__1);
+		}
+		i__1 = kp - k - 1;
+		sswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) *
+			 a_dim1], lda);
+
+		temp = a[k + k * a_dim1];
+		a[k + k * a_dim1] = a[kp + kp * a_dim1];
+		a[kp + kp * a_dim1] = temp;
+		temp = a[k + (k - 1) * a_dim1];
+		a[k + (k - 1) * a_dim1] = a[kp + (k - 1) * a_dim1];
+		a[kp + (k - 1) * a_dim1] = temp;
+	    }
+
+	    --k;
+	    kp = -ipiv[k];
+	    if (kp != k) {
+		if (kp < *n) {
+		    i__1 = *n - kp;
+		    sswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + 
+			    kp * a_dim1], &c__1);
+		}
+		i__1 = kp - k - 1;
+		sswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) *
+			 a_dim1], lda);
+		temp = a[k + k * a_dim1];
+		a[k + k * a_dim1] = a[kp + kp * a_dim1];
+		a[kp + kp * a_dim1] = temp;
+	    }
+	}
+
+	--k;
+	goto L50;
+L60:
+	;
+    }
+
+    return 0;
+
+/*     End of SSYTRI_ROOK */
+
+} /* ssytri_rook__ */
+

lapack-netlib/SRC/ssytrs.c

@@ -0,0 +1,884 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+#include <math.h>
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <complex.h>
+#ifdef complex
+#undef complex
+#endif
+#ifdef I
+#undef I
+#endif
+
+typedef int integer;
+typedef unsigned int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
+static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
+static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
+#define pCf(z) (*_pCf(z))
+#define pCd(z) (*_pCd(z))
+typedef int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+typedef int flag;
+typedef int ftnlen;
+typedef int ftnint;
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (fabs(x))
+#define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
+#define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (f2cmin(a,b))
+#define dmax(a,b) (f2cmax(a,b))
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+#define abort_() { sig_die("Fortran abort routine called", 1); }
+#define c_abs(z) (cabsf(Cf(z)))
+#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
+#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
+#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
+#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
+#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
+#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
+//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
+#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
+#define d_abs(x) (fabs(*(x)))
+#define d_acos(x) (acos(*(x)))
+#define d_asin(x) (asin(*(x)))
+#define d_atan(x) (atan(*(x)))
+#define d_atn2(x, y) (atan2(*(x),*(y)))
+#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
+#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); }
+#define d_cos(x) (cos(*(x)))
+#define d_cosh(x) (cosh(*(x)))
+#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
+#define d_exp(x) (exp(*(x)))
+#define d_imag(z) (cimag(Cd(z)))
+#define r_imag(z) (cimag(Cf(z)))
+#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
+#define 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_b7 = -1.f;
+static integer c__1 = 1;
+static real c_b19 = 1.f;
+
+/* > \brief \b SSYTRS */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYTRS + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytrs.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytrs.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytrs.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDA, LDB, N, NRHS */
+/*       INTEGER            IPIV( * ) */
+/*       REAL               A( LDA, * ), B( LDB, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYTRS solves a system of linear equations A*X = B with a real */
+/* > symmetric matrix A using the factorization A = U*D*U**T or */
+/* > A = L*D*L**T computed by SSYTRF. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the details of the factorization are stored */
+/* >          as an upper or lower triangular matrix. */
+/* >          = 'U':  Upper triangular, form is A = U*D*U**T; */
+/* >          = 'L':  Lower triangular, form is A = L*D*L**T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The number of right hand sides, i.e., the number of columns */
+/* >          of the matrix B.  NRHS >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          The block diagonal matrix D and the multipliers used to */
+/* >          obtain the factor U or L as computed by SSYTRF. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges and the block structure of D */
+/* >          as determined by SSYTRF. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB,NRHS) */
+/* >          On entry, the right hand side matrix B. */
+/* >          On exit, the solution matrix X. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realSYcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssytrs_(char *uplo, integer *n, integer *nrhs, real *a, 
+	integer *lda, integer *ipiv, real *b, integer *ldb, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+    real r__1;
+
+    /* Local variables */
+    extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, 
+	    integer *, real *, integer *, real *, integer *);
+    real akm1k;
+    integer j, k;
+    extern logical lsame_(char *, char *);
+    real denom;
+    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), 
+	    sgemv_(char *, integer *, integer *, real *, real *, integer *, 
+	    real *, integer *, real *, real *, integer *);
+    logical upper;
+    extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, 
+	    integer *);
+    real ak, bk;
+    integer kp;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    real akm1, bkm1;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --ipiv;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*nrhs < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -8;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYTRS", &i__1, (ftnlen)6);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0 || *nrhs == 0) {
+	return 0;
+    }
+
+    if (upper) {
+
+/*        Solve A*X = B, where A = U*D*U**T. */
+
+/*        First solve U*D*X = B, overwriting B with X. */
+
+/*        K is the main loop index, decreasing from N to 1 in steps of */
+/*        1 or 2, depending on the size of the diagonal blocks. */
+
+	k = *n;
+L10:
+
+/*        If K < 1, exit from loop. */
+
+	if (k < 1) {
+	    goto L30;
+	}
+
+	if (ipiv[k] > 0) {
+
+/*           1 x 1 diagonal block */
+
+/*           Interchange rows K and IPIV(K). */
+
+	    kp = ipiv[k];
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+
+/*           Multiply by inv(U(K)), where U(K) is the transformation */
+/*           stored in column K of A. */
+
+	    i__1 = k - 1;
+	    sger_(&i__1, nrhs, &c_b7, &a[k * a_dim1 + 1], &c__1, &b[k + 
+		    b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/*           Multiply by the inverse of the diagonal block. */
+
+	    r__1 = 1.f / a[k + k * a_dim1];
+	    sscal_(nrhs, &r__1, &b[k + b_dim1], ldb);
+	    --k;
+	} else {
+
+/*           2 x 2 diagonal block */
+
+/*           Interchange rows K-1 and -IPIV(K). */
+
+	    kp = -ipiv[k];
+	    if (kp != k - 1) {
+		sswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+
+/*           Multiply by inv(U(K)), where U(K) is the transformation */
+/*           stored in columns K-1 and K of A. */
+
+	    i__1 = k - 2;
+	    sger_(&i__1, nrhs, &c_b7, &a[k * a_dim1 + 1], &c__1, &b[k + 
+		    b_dim1], ldb, &b[b_dim1 + 1], ldb);
+	    i__1 = k - 2;
+	    sger_(&i__1, nrhs, &c_b7, &a[(k - 1) * a_dim1 + 1], &c__1, &b[k - 
+		    1 + b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/*           Multiply by the inverse of the diagonal block. */
+
+	    akm1k = a[k - 1 + k * a_dim1];
+	    akm1 = a[k - 1 + (k - 1) * a_dim1] / akm1k;
+	    ak = a[k + k * a_dim1] / akm1k;
+	    denom = akm1 * ak - 1.f;
+	    i__1 = *nrhs;
+	    for (j = 1; j <= i__1; ++j) {
+		bkm1 = b[k - 1 + j * b_dim1] / akm1k;
+		bk = b[k + j * b_dim1] / akm1k;
+		b[k - 1 + j * b_dim1] = (ak * bkm1 - bk) / denom;
+		b[k + j * b_dim1] = (akm1 * bk - bkm1) / denom;
+/* L20: */
+	    }
+	    k += -2;
+	}
+
+	goto L10;
+L30:
+
+/*        Next solve U**T *X = B, overwriting B with X. */
+
+/*        K is the main loop index, increasing from 1 to N in steps of */
+/*        1 or 2, depending on the size of the diagonal blocks. */
+
+	k = 1;
+L40:
+
+/*        If K > N, exit from loop. */
+
+	if (k > *n) {
+	    goto L50;
+	}
+
+	if (ipiv[k] > 0) {
+
+/*           1 x 1 diagonal block */
+
+/*           Multiply by inv(U**T(K)), where U(K) is the transformation */
+/*           stored in column K of A. */
+
+	    i__1 = k - 1;
+	    sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[k * 
+		    a_dim1 + 1], &c__1, &c_b19, &b[k + b_dim1], ldb);
+
+/*           Interchange rows K and IPIV(K). */
+
+	    kp = ipiv[k];
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+	    ++k;
+	} else {
+
+/*           2 x 2 diagonal block */
+
+/*           Multiply by inv(U**T(K+1)), where U(K+1) is the transformation */
+/*           stored in columns K and K+1 of A. */
+
+	    i__1 = k - 1;
+	    sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[k * 
+		    a_dim1 + 1], &c__1, &c_b19, &b[k + b_dim1], ldb);
+	    i__1 = k - 1;
+	    sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[(k 
+		    + 1) * a_dim1 + 1], &c__1, &c_b19, &b[k + 1 + b_dim1], 
+		    ldb);
+
+/*           Interchange rows K and -IPIV(K). */
+
+	    kp = -ipiv[k];
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+	    k += 2;
+	}
+
+	goto L40;
+L50:
+
+	;
+    } else {
+
+/*        Solve A*X = B, where A = L*D*L**T. */
+
+/*        First solve L*D*X = B, overwriting B with X. */
+
+/*        K is the main loop index, increasing from 1 to N in steps of */
+/*        1 or 2, depending on the size of the diagonal blocks. */
+
+	k = 1;
+L60:
+
+/*        If K > N, exit from loop. */
+
+	if (k > *n) {
+	    goto L80;
+	}
+
+	if (ipiv[k] > 0) {
+
+/*           1 x 1 diagonal block */
+
+/*           Interchange rows K and IPIV(K). */
+
+	    kp = ipiv[k];
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+
+/*           Multiply by inv(L(K)), where L(K) is the transformation */
+/*           stored in column K of A. */
+
+	    if (k < *n) {
+		i__1 = *n - k;
+		sger_(&i__1, nrhs, &c_b7, &a[k + 1 + k * a_dim1], &c__1, &b[k 
+			+ b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+	    }
+
+/*           Multiply by the inverse of the diagonal block. */
+
+	    r__1 = 1.f / a[k + k * a_dim1];
+	    sscal_(nrhs, &r__1, &b[k + b_dim1], ldb);
+	    ++k;
+	} else {
+
+/*           2 x 2 diagonal block */
+
+/*           Interchange rows K+1 and -IPIV(K). */
+
+	    kp = -ipiv[k];
+	    if (kp != k + 1) {
+		sswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+
+/*           Multiply by inv(L(K)), where L(K) is the transformation */
+/*           stored in columns K and K+1 of A. */
+
+	    if (k < *n - 1) {
+		i__1 = *n - k - 1;
+		sger_(&i__1, nrhs, &c_b7, &a[k + 2 + k * a_dim1], &c__1, &b[k 
+			+ b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
+		i__1 = *n - k - 1;
+		sger_(&i__1, nrhs, &c_b7, &a[k + 2 + (k + 1) * a_dim1], &c__1,
+			 &b[k + 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
+	    }
+
+/*           Multiply by the inverse of the diagonal block. */
+
+	    akm1k = a[k + 1 + k * a_dim1];
+	    akm1 = a[k + k * a_dim1] / akm1k;
+	    ak = a[k + 1 + (k + 1) * a_dim1] / akm1k;
+	    denom = akm1 * ak - 1.f;
+	    i__1 = *nrhs;
+	    for (j = 1; j <= i__1; ++j) {
+		bkm1 = b[k + j * b_dim1] / akm1k;
+		bk = b[k + 1 + j * b_dim1] / akm1k;
+		b[k + j * b_dim1] = (ak * bkm1 - bk) / denom;
+		b[k + 1 + j * b_dim1] = (akm1 * bk - bkm1) / denom;
+/* L70: */
+	    }
+	    k += 2;
+	}
+
+	goto L60;
+L80:
+
+/*        Next solve L**T *X = B, overwriting B with X. */
+
+/*        K is the main loop index, decreasing from N to 1 in steps of */
+/*        1 or 2, depending on the size of the diagonal blocks. */
+
+	k = *n;
+L90:
+
+/*        If K < 1, exit from loop. */
+
+	if (k < 1) {
+	    goto L100;
+	}
+
+	if (ipiv[k] > 0) {
+
+/*           1 x 1 diagonal block */
+
+/*           Multiply by inv(L**T(K)), where L(K) is the transformation */
+/*           stored in column K of A. */
+
+	    if (k < *n) {
+		i__1 = *n - k;
+		sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], 
+			ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b19, &b[k + 
+			b_dim1], ldb);
+	    }
+
+/*           Interchange rows K and IPIV(K). */
+
+	    kp = ipiv[k];
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+	    --k;
+	} else {
+
+/*           2 x 2 diagonal block */
+
+/*           Multiply by inv(L**T(K-1)), where L(K-1) is the transformation */
+/*           stored in columns K-1 and K of A. */
+
+	    if (k < *n) {
+		i__1 = *n - k;
+		sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], 
+			ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b19, &b[k + 
+			b_dim1], ldb);
+		i__1 = *n - k;
+		sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], 
+			ldb, &a[k + 1 + (k - 1) * a_dim1], &c__1, &c_b19, &b[
+			k - 1 + b_dim1], ldb);
+	    }
+
+/*           Interchange rows K and -IPIV(K). */
+
+	    kp = -ipiv[k];
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+	    k += -2;
+	}
+
+	goto L90;
+L100:
+	;
+    }
+
+    return 0;
+
+/*     End of SSYTRS */
+
+} /* ssytrs_ */
+

lapack-netlib/SRC/ssytrs2.c

@@ -0,0 +1,782 @@
+/* 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_b10 = 1.f;
+
+/* > \brief \b SSYTRS2 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYTRS2 + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytrs2
+.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytrs2
+.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytrs2
+.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, */
+/*                           WORK, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDA, LDB, N, NRHS */
+/*       INTEGER            IPIV( * ) */
+/*       REAL               A( LDA, * ), B( LDB, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYTRS2 solves a system of linear equations A*X = B with a real */
+/* > symmetric matrix A using the factorization A = U*D*U**T or */
+/* > A = L*D*L**T computed by SSYTRF and converted by SSYCONV. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the details of the factorization are stored */
+/* >          as an upper or lower triangular matrix. */
+/* >          = 'U':  Upper triangular, form is A = U*D*U**T; */
+/* >          = 'L':  Lower triangular, form is A = L*D*L**T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The number of right hand sides, i.e., the number of columns */
+/* >          of the matrix B.  NRHS >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          The block diagonal matrix D and the multipliers used to */
+/* >          obtain the factor U or L as computed by SSYTRF. */
+/* >          Note that A is input / output. This might be counter-intuitive, */
+/* >          and one may think that A is input only. A is input / output. This */
+/* >          is because, at the start of the subroutine, we permute A in a */
+/* >          "better" form and then we permute A back to its original form at */
+/* >          the end. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges and the block structure of D */
+/* >          as determined by SSYTRF. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB,NRHS) */
+/* >          On entry, the right hand side matrix B. */
+/* >          On exit, the solution matrix X. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realSYcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssytrs2_(char *uplo, integer *n, integer *nrhs, real *a, 
+	integer *lda, integer *ipiv, real *b, integer *ldb, real *work, 
+	integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+    real r__1;
+
+    /* Local variables */
+    real akm1k;
+    integer i__, j, k;
+    extern logical lsame_(char *, char *);
+    real denom;
+    integer iinfo;
+    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+    logical upper;
+    extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, 
+	    integer *), strsm_(char *, char *, char *, char *, integer *, 
+	    integer *, real *, real *, integer *, real *, integer *);
+    real ak, bk;
+    integer kp;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    real akm1, bkm1;
+    extern /* Subroutine */ int ssyconv_(char *, char *, integer *, real *, 
+	    integer *, integer *, real *, integer *);
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --ipiv;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*nrhs < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -8;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYTRS2", &i__1, (ftnlen)7);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0 || *nrhs == 0) {
+	return 0;
+    }
+
+/*     Convert A */
+
+    ssyconv_(uplo, "C", n, &a[a_offset], lda, &ipiv[1], &work[1], &iinfo);
+
+    if (upper) {
+
+/*        Solve A*X = B, where A = U*D*U**T. */
+
+/*       P**T * B */
+	k = *n;
+	while(k >= 1) {
+	    if (ipiv[k] > 0) {
+/*           1 x 1 diagonal block */
+/*           Interchange rows K and IPIV(K). */
+		kp = ipiv[k];
+		if (kp != k) {
+		    sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+		}
+		--k;
+	    } else {
+/*           2 x 2 diagonal block */
+/*           Interchange rows K-1 and -IPIV(K). */
+		kp = -ipiv[k];
+		if (kp == -ipiv[k - 1]) {
+		    sswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], 
+			    ldb);
+		}
+		k += -2;
+	    }
+	}
+
+/*  Compute (U \P**T * B) -> B    [ (U \P**T * B) ] */
+
+	strsm_("L", "U", "N", "U", n, nrhs, &c_b10, &a[a_offset], lda, &b[
+		b_offset], ldb);
+
+/*  Compute D \ B -> B   [ D \ (U \P**T * B) ] */
+
+	i__ = *n;
+	while(i__ >= 1) {
+	    if (ipiv[i__] > 0) {
+		r__1 = 1.f / a[i__ + i__ * a_dim1];
+		sscal_(nrhs, &r__1, &b[i__ + b_dim1], ldb);
+	    } else if (i__ > 1) {
+		if (ipiv[i__ - 1] == ipiv[i__]) {
+		    akm1k = work[i__];
+		    akm1 = a[i__ - 1 + (i__ - 1) * a_dim1] / akm1k;
+		    ak = a[i__ + i__ * a_dim1] / akm1k;
+		    denom = akm1 * ak - 1.f;
+		    i__1 = *nrhs;
+		    for (j = 1; j <= i__1; ++j) {
+			bkm1 = b[i__ - 1 + j * b_dim1] / akm1k;
+			bk = b[i__ + j * b_dim1] / akm1k;
+			b[i__ - 1 + j * b_dim1] = (ak * bkm1 - bk) / denom;
+			b[i__ + j * b_dim1] = (akm1 * bk - bkm1) / denom;
+/* L15: */
+		    }
+		    --i__;
+		}
+	    }
+	    --i__;
+	}
+
+/*      Compute (U**T \ B) -> B   [ U**T \ (D \ (U \P**T * B) ) ] */
+
+	strsm_("L", "U", "T", "U", n, nrhs, &c_b10, &a[a_offset], lda, &b[
+		b_offset], ldb);
+
+/*       P * B  [ P * (U**T \ (D \ (U \P**T * B) )) ] */
+
+	k = 1;
+	while(k <= *n) {
+	    if (ipiv[k] > 0) {
+/*           1 x 1 diagonal block */
+/*           Interchange rows K and IPIV(K). */
+		kp = ipiv[k];
+		if (kp != k) {
+		    sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+		}
+		++k;
+	    } else {
+/*           2 x 2 diagonal block */
+/*           Interchange rows K-1 and -IPIV(K). */
+		kp = -ipiv[k];
+		if (k < *n && kp == -ipiv[k + 1]) {
+		    sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+		}
+		k += 2;
+	    }
+	}
+
+    } else {
+
+/*        Solve A*X = B, where A = L*D*L**T. */
+
+/*       P**T * B */
+	k = 1;
+	while(k <= *n) {
+	    if (ipiv[k] > 0) {
+/*           1 x 1 diagonal block */
+/*           Interchange rows K and IPIV(K). */
+		kp = ipiv[k];
+		if (kp != k) {
+		    sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+		}
+		++k;
+	    } else {
+/*           2 x 2 diagonal block */
+/*           Interchange rows K and -IPIV(K+1). */
+		kp = -ipiv[k + 1];
+		if (kp == -ipiv[k]) {
+		    sswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], 
+			    ldb);
+		}
+		k += 2;
+	    }
+	}
+
+/*  Compute (L \P**T * B) -> B    [ (L \P**T * B) ] */
+
+	strsm_("L", "L", "N", "U", n, nrhs, &c_b10, &a[a_offset], lda, &b[
+		b_offset], ldb);
+
+/*  Compute D \ B -> B   [ D \ (L \P**T * B) ] */
+
+	i__ = 1;
+	while(i__ <= *n) {
+	    if (ipiv[i__] > 0) {
+		r__1 = 1.f / a[i__ + i__ * a_dim1];
+		sscal_(nrhs, &r__1, &b[i__ + b_dim1], ldb);
+	    } else {
+		akm1k = work[i__];
+		akm1 = a[i__ + i__ * a_dim1] / akm1k;
+		ak = a[i__ + 1 + (i__ + 1) * a_dim1] / akm1k;
+		denom = akm1 * ak - 1.f;
+		i__1 = *nrhs;
+		for (j = 1; j <= i__1; ++j) {
+		    bkm1 = b[i__ + j * b_dim1] / akm1k;
+		    bk = b[i__ + 1 + j * b_dim1] / akm1k;
+		    b[i__ + j * b_dim1] = (ak * bkm1 - bk) / denom;
+		    b[i__ + 1 + j * b_dim1] = (akm1 * bk - bkm1) / denom;
+/* L25: */
+		}
+		++i__;
+	    }
+	    ++i__;
+	}
+
+/*  Compute (L**T \ B) -> B   [ L**T \ (D \ (L \P**T * B) ) ] */
+
+	strsm_("L", "L", "T", "U", n, nrhs, &c_b10, &a[a_offset], lda, &b[
+		b_offset], ldb);
+
+/*       P * B  [ P * (L**T \ (D \ (L \P**T * B) )) ] */
+
+	k = *n;
+	while(k >= 1) {
+	    if (ipiv[k] > 0) {
+/*           1 x 1 diagonal block */
+/*           Interchange rows K and IPIV(K). */
+		kp = ipiv[k];
+		if (kp != k) {
+		    sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+		}
+		--k;
+	    } else {
+/*           2 x 2 diagonal block */
+/*           Interchange rows K-1 and -IPIV(K). */
+		kp = -ipiv[k];
+		if (k > 1 && kp == -ipiv[k - 1]) {
+		    sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+		}
+		k += -2;
+	    }
+	}
+
+    }
+
+/*     Revert A */
+
+    ssyconv_(uplo, "R", n, &a[a_offset], lda, &ipiv[1], &work[1], &iinfo);
+
+    return 0;
+
+/*     End of SSYTRS2 */
+
+} /* ssytrs2_ */
+

lapack-netlib/SRC/ssytrs_3.c

@@ -0,0 +1,779 @@
+/* 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 = 1.f;
+
+/* > \brief \b SSYTRS_3 */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYTRS_3 + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytrs_
+3.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytrs_
+3.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytrs_
+3.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, */
+/*                            INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDA, LDB, N, NRHS */
+/*       INTEGER            IPIV( * ) */
+/*       REAL               A( LDA, * ), B( LDB, * ), E( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > SSYTRS_3 solves a system of linear equations A * X = B with a real */
+/* > symmetric matrix A using the factorization computed */
+/* > by SSYTRF_RK or SSYTRF_BK: */
+/* > */
+/* >    A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), */
+/* > */
+/* > where U (or L) is unit upper (or lower) triangular matrix, */
+/* > U**T (or L**T) is the transpose of U (or L), P is a permutation */
+/* > matrix, P**T is the transpose of P, and D is symmetric and block */
+/* > diagonal with 1-by-1 and 2-by-2 diagonal blocks. */
+/* > */
+/* > This algorithm is using Level 3 BLAS. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the details of the factorization are */
+/* >          stored as an upper or lower triangular matrix: */
+/* >          = 'U':  Upper triangular, form is A = P*U*D*(U**T)*(P**T); */
+/* >          = 'L':  Lower triangular, form is A = P*L*D*(L**T)*(P**T). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The number of right hand sides, i.e., the number of columns */
+/* >          of the matrix B.  NRHS >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          Diagonal of the block diagonal matrix D and factors U or L */
+/* >          as computed by SSYTRF_RK and SSYTRF_BK: */
+/* >            a) ONLY diagonal elements of the symmetric block diagonal */
+/* >               matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */
+/* >               (superdiagonal (or subdiagonal) elements of D */
+/* >                should be provided on entry in array E), and */
+/* >            b) If UPLO = 'U': factor U in the superdiagonal part of A. */
+/* >               If UPLO = 'L': factor L in the subdiagonal part of A. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] E */
+/* > \verbatim */
+/* >          E is REAL array, dimension (N) */
+/* >          On entry, contains the superdiagonal (or subdiagonal) */
+/* >          elements of the symmetric block diagonal matrix D */
+/* >          with 1-by-1 or 2-by-2 diagonal blocks, where */
+/* >          If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; */
+/* >          If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. */
+/* > */
+/* >          NOTE: For 1-by-1 diagonal block D(k), where */
+/* >          1 <= k <= N, the element E(k) is not referenced in both */
+/* >          UPLO = 'U' or UPLO = 'L' cases. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges and the block structure of D */
+/* >          as determined by SSYTRF_RK or SSYTRF_BK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB,NRHS) */
+/* >          On entry, the right hand side matrix B. */
+/* >          On exit, the solution matrix X. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date June 2017 */
+
+/* > \ingroup singleSYcomputational */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >  June 2017,  Igor Kozachenko, */
+/* >                  Computer Science Division, */
+/* >                  University of California, Berkeley */
+/* > */
+/* >  September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */
+/* >                  School of Mathematics, */
+/* >                  University of Manchester */
+/* > */
+/* > \endverbatim */
+
+/*  ==================================================================== */
+/* Subroutine */ int ssytrs_3_(char *uplo, integer *n, integer *nrhs, real *
+	a, integer *lda, real *e, integer *ipiv, real *b, integer *ldb, 
+	integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+    real r__1;
+
+    /* Local variables */
+    real akm1k;
+    integer i__, j, k;
+    extern logical lsame_(char *, char *);
+    real denom;
+    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
+    logical upper;
+    extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, 
+	    integer *), strsm_(char *, char *, char *, char *, integer *, 
+	    integer *, real *, real *, integer *, real *, integer *);
+    real ak, bk;
+    integer kp;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    real akm1, bkm1;
+
+
+/*  -- LAPACK computational routine (version 3.7.1) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     June 2017 */
+
+
+/*  ===================================================================== */
+
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --e;
+    --ipiv;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*nrhs < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -9;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYTRS_3", &i__1, (ftnlen)8);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0 || *nrhs == 0) {
+	return 0;
+    }
+
+    if (upper) {
+
+/*        Begin Upper */
+
+/*        Solve A*X = B, where A = U*D*U**T. */
+
+/*        P**T * B */
+
+/*        Interchange rows K and IPIV(K) of matrix B in the same order */
+/*        that the formation order of IPIV(I) vector for Upper case. */
+
+/*        (We can do the simple loop over IPIV with decrement -1, */
+/*        since the ABS value of IPIV(I) represents the row index */
+/*        of the interchange with row i in both 1x1 and 2x2 pivot cases) */
+
+	for (k = *n; k >= 1; --k) {
+	    kp = (i__1 = ipiv[k], abs(i__1));
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+	}
+
+/*        Compute (U \P**T * B) -> B    [ (U \P**T * B) ] */
+
+	strsm_("L", "U", "N", "U", n, nrhs, &c_b9, &a[a_offset], lda, &b[
+		b_offset], ldb);
+
+/*        Compute D \ B -> B   [ D \ (U \P**T * B) ] */
+
+	i__ = *n;
+	while(i__ >= 1) {
+	    if (ipiv[i__] > 0) {
+		r__1 = 1.f / a[i__ + i__ * a_dim1];
+		sscal_(nrhs, &r__1, &b[i__ + b_dim1], ldb);
+	    } else if (i__ > 1) {
+		akm1k = e[i__];
+		akm1 = a[i__ - 1 + (i__ - 1) * a_dim1] / akm1k;
+		ak = a[i__ + i__ * a_dim1] / akm1k;
+		denom = akm1 * ak - 1.f;
+		i__1 = *nrhs;
+		for (j = 1; j <= i__1; ++j) {
+		    bkm1 = b[i__ - 1 + j * b_dim1] / akm1k;
+		    bk = b[i__ + j * b_dim1] / akm1k;
+		    b[i__ - 1 + j * b_dim1] = (ak * bkm1 - bk) / denom;
+		    b[i__ + j * b_dim1] = (akm1 * bk - bkm1) / denom;
+		}
+		--i__;
+	    }
+	    --i__;
+	}
+
+/*        Compute (U**T \ B) -> B   [ U**T \ (D \ (U \P**T * B) ) ] */
+
+	strsm_("L", "U", "T", "U", n, nrhs, &c_b9, &a[a_offset], lda, &b[
+		b_offset], ldb);
+
+/*        P * B  [ P * (U**T \ (D \ (U \P**T * B) )) ] */
+
+/*        Interchange rows K and IPIV(K) of matrix B in reverse order */
+/*        from the formation order of IPIV(I) vector for Upper case. */
+
+/*        (We can do the simple loop over IPIV with increment 1, */
+/*        since the ABS value of IPIV(I) represents the row index */
+/*        of the interchange with row i in both 1x1 and 2x2 pivot cases) */
+
+	i__1 = *n;
+	for (k = 1; k <= i__1; ++k) {
+	    kp = (i__2 = ipiv[k], abs(i__2));
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+	}
+
+    } else {
+
+/*        Begin Lower */
+
+/*        Solve A*X = B, where A = L*D*L**T. */
+
+/*        P**T * B */
+/*        Interchange rows K and IPIV(K) of matrix B in the same order */
+/*        that the formation order of IPIV(I) vector for Lower case. */
+
+/*        (We can do the simple loop over IPIV with increment 1, */
+/*        since the ABS value of IPIV(I) represents the row index */
+/*        of the interchange with row i in both 1x1 and 2x2 pivot cases) */
+
+	i__1 = *n;
+	for (k = 1; k <= i__1; ++k) {
+	    kp = (i__2 = ipiv[k], abs(i__2));
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+	}
+
+/*        Compute (L \P**T * B) -> B    [ (L \P**T * B) ] */
+
+	strsm_("L", "L", "N", "U", n, nrhs, &c_b9, &a[a_offset], lda, &b[
+		b_offset], ldb);
+
+/*        Compute D \ B -> B   [ D \ (L \P**T * B) ] */
+
+	i__ = 1;
+	while(i__ <= *n) {
+	    if (ipiv[i__] > 0) {
+		r__1 = 1.f / a[i__ + i__ * a_dim1];
+		sscal_(nrhs, &r__1, &b[i__ + b_dim1], ldb);
+	    } else if (i__ < *n) {
+		akm1k = e[i__];
+		akm1 = a[i__ + i__ * a_dim1] / akm1k;
+		ak = a[i__ + 1 + (i__ + 1) * a_dim1] / akm1k;
+		denom = akm1 * ak - 1.f;
+		i__1 = *nrhs;
+		for (j = 1; j <= i__1; ++j) {
+		    bkm1 = b[i__ + j * b_dim1] / akm1k;
+		    bk = b[i__ + 1 + j * b_dim1] / akm1k;
+		    b[i__ + j * b_dim1] = (ak * bkm1 - bk) / denom;
+		    b[i__ + 1 + j * b_dim1] = (akm1 * bk - bkm1) / denom;
+		}
+		++i__;
+	    }
+	    ++i__;
+	}
+
+/*        Compute (L**T \ B) -> B   [ L**T \ (D \ (L \P**T * B) ) ] */
+
+	strsm_("L", "L", "T", "U", n, nrhs, &c_b9, &a[a_offset], lda, &b[
+		b_offset], ldb);
+
+/*        P * B  [ P * (L**T \ (D \ (L \P**T * B) )) ] */
+
+/*        Interchange rows K and IPIV(K) of matrix B in reverse order */
+/*        from the formation order of IPIV(I) vector for Lower case. */
+
+/*        (We can do the simple loop over IPIV with decrement -1, */
+/*        since the ABS value of IPIV(I) represents the row index */
+/*        of the interchange with row i in both 1x1 and 2x2 pivot cases) */
+
+	for (k = *n; k >= 1; --k) {
+	    kp = (i__1 = ipiv[k], abs(i__1));
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+	}
+
+/*        END Lower */
+
+    }
+
+    return 0;
+
+/*     End of SSYTRS_3 */
+
+} /* ssytrs_3__ */
+

lapack-netlib/SRC/ssytrs_aa.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 real c_b9 = 1.f;
+static integer c__1 = 1;
+
+/* > \brief \b SSYTRS_AA */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYTRS_AA + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytrs_
+aa.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytrs_
+aa.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytrs_
+aa.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYTRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, */
+/*                             WORK, LWORK, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            N, NRHS, LDA, LDB, LWORK, INFO */
+/*       INTEGER            IPIV( * ) */
+/*       REAL   A( LDA, * ), B( LDB, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYTRS_AA solves a system of linear equations A*X = B with a real */
+/* > symmetric matrix A using the factorization A = U**T*T*U or */
+/* > A = L*T*L**T computed by SSYTRF_AA. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the details of the factorization are stored */
+/* >          as an upper or lower triangular matrix. */
+/* >          = 'U':  Upper triangular, form is A = U**T*T*U; */
+/* >          = 'L':  Lower triangular, form is A = L*T*L**T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The number of right hand sides, i.e., the number of columns */
+/* >          of the matrix B.  NRHS >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          Details of factors computed by SSYTRF_AA. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges as computed by SSYTRF_AA. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB,NRHS) */
+/* >          On entry, the right hand side matrix B. */
+/* >          On exit, the solution matrix X. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (MAX(1,LWORK)) */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LWORK */
+/* > \verbatim */
+/* >          LWORK is INTEGER */
+/* >          The dimension of the array WORK. LWORK >= f2cmax(1,3*N-2). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date November 2017 */
+
+/* > \ingroup realSYcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssytrs_aa_(char *uplo, integer *n, integer *nrhs, real *
+	a, integer *lda, integer *ipiv, real *b, integer *ldb, real *work, 
+	integer *lwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+
+    /* Local variables */
+    integer k;
+    extern logical lsame_(char *, char *);
+    logical upper;
+    extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, 
+	    integer *), sgtsv_(integer *, integer *, real *, real *, real *, 
+	    real *, integer *, integer *), strsm_(char *, char *, char *, 
+	    char *, integer *, integer *, real *, real *, integer *, real *, 
+	    integer *);
+    integer kp;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slacpy_(
+	    char *, integer *, integer *, real *, integer *, real *, integer *
+	    );
+    integer lwkopt;
+    logical lquery;
+
+
+/*  -- LAPACK computational routine (version 3.8.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     November 2017 */
+
+
+
+/*  ===================================================================== */
+
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --ipiv;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    lquery = *lwork == -1;
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*nrhs < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -8;
+    } else /* if(complicated condition) */ {
+/* Computing MAX */
+	i__1 = 1, i__2 = *n * 3 - 2;
+	if (*lwork < f2cmax(i__1,i__2) && ! lquery) {
+	    *info = -10;
+	}
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYTRS_AA", &i__1, (ftnlen)9);
+	return 0;
+    } else if (lquery) {
+	lwkopt = *n * 3 - 2;
+	work[1] = (real) lwkopt;
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0 || *nrhs == 0) {
+	return 0;
+    }
+
+    if (upper) {
+
+/*        Solve A*X = B, where A = U**T*T*U. */
+
+/*        1) Forward substitution with U**T */
+
+	if (*n > 1) {
+
+/*           Pivot, P**T * B -> B */
+
+	    k = 1;
+	    while(k <= *n) {
+		kp = ipiv[k];
+		if (kp != k) {
+		    sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+		}
+		++k;
+	    }
+
+/*           Compute U**T \ B -> B    [ (U**T \P**T * B) ] */
+
+	    i__1 = *n - 1;
+	    strsm_("L", "U", "T", "U", &i__1, nrhs, &c_b9, &a[(a_dim1 << 1) + 
+		    1], lda, &b[b_dim1 + 2], ldb);
+	}
+
+/*        2) Solve with triangular matrix T */
+
+/*        Compute T \ B -> B   [ T \ (U**T \P**T * B) ] */
+
+	i__1 = *lda + 1;
+	slacpy_("F", &c__1, n, &a[a_dim1 + 1], &i__1, &work[*n], &c__1);
+	if (*n > 1) {
+	    i__1 = *n - 1;
+	    i__2 = *lda + 1;
+	    slacpy_("F", &c__1, &i__1, &a[(a_dim1 << 1) + 1], &i__2, &work[1],
+		     &c__1);
+	    i__1 = *n - 1;
+	    i__2 = *lda + 1;
+	    slacpy_("F", &c__1, &i__1, &a[(a_dim1 << 1) + 1], &i__2, &work[*n 
+		    * 2], &c__1);
+	}
+	sgtsv_(n, nrhs, &work[1], &work[*n], &work[*n * 2], &b[b_offset], ldb,
+		 info);
+
+/*        3) Backward substitution with U */
+
+	if (*n > 1) {
+
+
+/*           Compute U \ B -> B   [ U \ (T \ (U**T \P**T * B) ) ] */
+
+	    i__1 = *n - 1;
+	    strsm_("L", "U", "N", "U", &i__1, nrhs, &c_b9, &a[(a_dim1 << 1) + 
+		    1], lda, &b[b_dim1 + 2], ldb);
+
+/*           Pivot, P * B -> B  [ P * (U \ (T \ (U**T \P**T * B) )) ] */
+
+	    k = *n;
+	    while(k >= 1) {
+		kp = ipiv[k];
+		if (kp != k) {
+		    sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+		}
+		--k;
+	    }
+	}
+
+    } else {
+
+/*        Solve A*X = B, where A = L*T*L**T. */
+
+/*        1) Forward substitution with L */
+
+	if (*n > 1) {
+
+/*           Pivot, P**T * B -> B */
+
+	    k = 1;
+	    while(k <= *n) {
+		kp = ipiv[k];
+		if (kp != k) {
+		    sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+		}
+		++k;
+	    }
+
+/*           Compute L \ B -> B    [ (L \P**T * B) ] */
+
+	    i__1 = *n - 1;
+	    strsm_("L", "L", "N", "U", &i__1, nrhs, &c_b9, &a[a_dim1 + 2], 
+		    lda, &b[b_dim1 + 2], ldb);
+	}
+
+/*        2) Solve with triangular matrix T */
+
+/*        Compute T \ B -> B   [ T \ (L \P**T * B) ] */
+
+	i__1 = *lda + 1;
+	slacpy_("F", &c__1, n, &a[a_dim1 + 1], &i__1, &work[*n], &c__1);
+	if (*n > 1) {
+	    i__1 = *n - 1;
+	    i__2 = *lda + 1;
+	    slacpy_("F", &c__1, &i__1, &a[a_dim1 + 2], &i__2, &work[1], &c__1);
+	    i__1 = *n - 1;
+	    i__2 = *lda + 1;
+	    slacpy_("F", &c__1, &i__1, &a[a_dim1 + 2], &i__2, &work[*n * 2], &
+		    c__1);
+	}
+	sgtsv_(n, nrhs, &work[1], &work[*n], &work[*n * 2], &b[b_offset], ldb,
+		 info);
+
+/*        3) Backward substitution with L**T */
+
+	if (*n > 1) {
+
+/*           Compute L**T \ B -> B   [ L**T \ (T \ (L \P**T * B) ) ] */
+
+	    i__1 = *n - 1;
+	    strsm_("L", "L", "T", "U", &i__1, nrhs, &c_b9, &a[a_dim1 + 2], 
+		    lda, &b[b_dim1 + 2], ldb);
+
+/*           Pivot, P * B -> B  [ P * (L**T \ (T \ (L \P**T * B) )) ] */
+
+	    k = *n;
+	    while(k >= 1) {
+		kp = ipiv[k];
+		if (kp != k) {
+		    sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+		}
+		--k;
+	    }
+	}
+
+    }
+
+    return 0;
+
+/*     End of SSYTRS_AA */
+
+} /* ssytrs_aa__ */
+

lapack-netlib/SRC/ssytrs_aa_2stage.c

@@ -0,0 +1,690 @@
+/* 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 real c_b10 = 1.f;
+static integer c_n1 = -1;
+
+/* > \brief \b SSYTRS_AA_2STAGE */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYTRS_AA_2STAGE + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytrs_
+aa_2stage.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytrs_
+aa_2stage.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytrs_
+aa_2stage.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*      SUBROUTINE SSYTRS_AA_2STAGE( UPLO, N, NRHS, A, LDA, TB, LTB, IPIV, */
+/*                                   IPIV2, B, LDB, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            N, NRHS, LDA, LTB, LDB, INFO */
+/*       INTEGER            IPIV( * ), IPIV2( * ) */
+/*       REAL               A( LDA, * ), TB( * ), B( LDB, * ) */
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYTRS_AA_2STAGE solves a system of linear equations A*X = B with a real */
+/* > symmetric matrix A using the factorization A = U**T*T*U or */
+/* > A = L*T*L**T computed by SSYTRF_AA_2STAGE. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the details of the factorization are stored */
+/* >          as an upper or lower triangular matrix. */
+/* >          = 'U':  Upper triangular, form is A = U**T*T*U; */
+/* >          = 'L':  Lower triangular, form is A = L*T*L**T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The number of right hand sides, i.e., the number of columns */
+/* >          of the matrix B.  NRHS >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          Details of factors computed by SSYTRF_AA_2STAGE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] TB */
+/* > \verbatim */
+/* >          TB is REAL array, dimension (LTB) */
+/* >          Details of factors computed by SSYTRF_AA_2STAGE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LTB */
+/* > \verbatim */
+/* >          LTB is INTEGER */
+/* >          The size of the array TB. LTB >= 4*N. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges as computed by */
+/* >          SSYTRF_AA_2STAGE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPIV2 */
+/* > \verbatim */
+/* >          IPIV2 is INTEGER array, dimension (N) */
+/* >          Details of the interchanges as computed by */
+/* >          SSYTRF_AA_2STAGE. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB,NRHS) */
+/* >          On entry, the right hand side matrix B. */
+/* >          On exit, the solution matrix X. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date November 2017 */
+
+/* > \ingroup realSYcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssytrs_aa_2stage_(char *uplo, integer *n, integer *nrhs,
+	 real *a, integer *lda, real *tb, integer *ltb, integer *ipiv, 
+	integer *ipiv2, real *b, integer *ldb, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+    /* Local variables */
+    integer ldtb;
+    extern logical lsame_(char *, char *);
+    logical upper;
+    extern /* Subroutine */ int strsm_(char *, char *, char *, char *, 
+	    integer *, integer *, real *, real *, integer *, real *, integer *
+	    );
+    integer nb;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), sgbtrs_(
+	    char *, integer *, integer *, integer *, integer *, real *, 
+	    integer *, integer *, real *, integer *, integer *), 
+	    slaswp_(integer *, real *, integer *, integer *, integer *, 
+	    integer *, integer *);
+
+
+/*  -- LAPACK computational routine (version 3.8.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     November 2017 */
+
+
+
+/*  ===================================================================== */
+
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --tb;
+    --ipiv;
+    --ipiv2;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*nrhs < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    } else if (*ltb < *n << 2) {
+	*info = -7;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -11;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYTRS_AA_2STAGE", &i__1, (ftnlen)16);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0 || *nrhs == 0) {
+	return 0;
+    }
+
+/*     Read NB and compute LDTB */
+
+    nb = (integer) tb[1];
+    ldtb = *ltb / *n;
+
+    if (upper) {
+
+/*        Solve A*X = B, where A = U**T*T*U. */
+
+	if (*n > nb) {
+
+/*           Pivot, P**T * B -> B */
+
+	    i__1 = nb + 1;
+	    slaswp_(nrhs, &b[b_offset], ldb, &i__1, n, &ipiv[1], &c__1);
+
+/*           Compute (U**T \ B) -> B    [ (U**T \P**T * B) ] */
+
+	    i__1 = *n - nb;
+	    strsm_("L", "U", "T", "U", &i__1, nrhs, &c_b10, &a[(nb + 1) * 
+		    a_dim1 + 1], lda, &b[nb + 1 + b_dim1], ldb);
+
+	}
+
+/*        Compute T \ B -> B   [ T \ (U**T \P**T * B) ] */
+
+	sgbtrs_("N", n, &nb, &nb, nrhs, &tb[1], &ldtb, &ipiv2[1], &b[b_offset]
+		, ldb, info);
+	if (*n > nb) {
+
+/*           Compute (U \ B) -> B   [ U \ (T \ (U**T \P**T * B) ) ] */
+
+	    i__1 = *n - nb;
+	    strsm_("L", "U", "N", "U", &i__1, nrhs, &c_b10, &a[(nb + 1) * 
+		    a_dim1 + 1], lda, &b[nb + 1 + b_dim1], ldb);
+
+/*           Pivot, P * B -> B  [ P * (U \ (T \ (U**T \P**T * B) )) ] */
+
+	    i__1 = nb + 1;
+	    slaswp_(nrhs, &b[b_offset], ldb, &i__1, n, &ipiv[1], &c_n1);
+
+	}
+
+    } else {
+
+/*        Solve A*X = B, where A = L*T*L**T. */
+
+	if (*n > nb) {
+
+/*           Pivot, P**T * B -> B */
+
+	    i__1 = nb + 1;
+	    slaswp_(nrhs, &b[b_offset], ldb, &i__1, n, &ipiv[1], &c__1);
+
+/*           Compute (L \ B) -> B    [ (L \P**T * B) ] */
+
+	    i__1 = *n - nb;
+	    strsm_("L", "L", "N", "U", &i__1, nrhs, &c_b10, &a[nb + 1 + 
+		    a_dim1], lda, &b[nb + 1 + b_dim1], ldb);
+
+	}
+
+/*        Compute T \ B -> B   [ T \ (L \P**T * B) ] */
+
+	sgbtrs_("N", n, &nb, &nb, nrhs, &tb[1], &ldtb, &ipiv2[1], &b[b_offset]
+		, ldb, info);
+	if (*n > nb) {
+
+/*           Compute (L**T \ B) -> B   [ L**T \ (T \ (L \P**T * B) ) ] */
+
+	    i__1 = *n - nb;
+	    strsm_("L", "L", "T", "U", &i__1, nrhs, &c_b10, &a[nb + 1 + 
+		    a_dim1], lda, &b[nb + 1 + b_dim1], ldb);
+
+/*           Pivot, P * B -> B  [ P * (L**T \ (T \ (L \P**T * B) )) ] */
+
+	    i__1 = nb + 1;
+	    slaswp_(nrhs, &b[b_offset], ldb, &i__1, n, &ipiv[1], &c_n1);
+
+	}
+    }
+
+    return 0;
+
+/*     End of SSYTRS_AA_2STAGE */
+
+} /* ssytrs_aa_2stage__ */
+

lapack-netlib/SRC/ssytrs_rook.c

@@ -0,0 +1,928 @@
+/* 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_b7 = -1.f;
+static integer c__1 = 1;
+static real c_b19 = 1.f;
+
+/* > \brief \b SSYTRS_ROOK */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download SSYTRS_ROOK + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/ssytrs_
+rook.f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/ssytrs_
+rook.f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/ssytrs_
+rook.f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE SSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) */
+
+/*       CHARACTER          UPLO */
+/*       INTEGER            INFO, LDA, LDB, N, NRHS */
+/*       INTEGER            IPIV( * ) */
+/*       REAL               A( LDA, * ), B( LDB, * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > SSYTRS_ROOK solves a system of linear equations A*X = B with */
+/* > a real symmetric matrix A using the factorization A = U*D*U**T or */
+/* > A = L*D*L**T computed by SSYTRF_ROOK. */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          Specifies whether the details of the factorization are stored */
+/* >          as an upper or lower triangular matrix. */
+/* >          = 'U':  Upper triangular, form is A = U*D*U**T; */
+/* >          = 'L':  Lower triangular, form is A = L*D*L**T. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] NRHS */
+/* > \verbatim */
+/* >          NRHS is INTEGER */
+/* >          The number of right hand sides, i.e., the number of columns */
+/* >          of the matrix B.  NRHS >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] A */
+/* > \verbatim */
+/* >          A is REAL array, dimension (LDA,N) */
+/* >          The block diagonal matrix D and the multipliers used to */
+/* >          obtain the factor U or L as computed by SSYTRF_ROOK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDA */
+/* > \verbatim */
+/* >          LDA is INTEGER */
+/* >          The leading dimension of the array A.  LDA >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[in] IPIV */
+/* > \verbatim */
+/* >          IPIV is INTEGER array, dimension (N) */
+/* >          Details of the interchanges and the block structure of D */
+/* >          as determined by SSYTRF_ROOK. */
+/* > \endverbatim */
+/* > */
+/* > \param[in,out] B */
+/* > \verbatim */
+/* >          B is REAL array, dimension (LDB,NRHS) */
+/* >          On entry, the right hand side matrix B. */
+/* >          On exit, the solution matrix X. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDB */
+/* > \verbatim */
+/* >          LDB is INTEGER */
+/* >          The leading dimension of the array B.  LDB >= f2cmax(1,N). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date April 2012 */
+
+/* > \ingroup realSYcomputational */
+
+/* > \par Contributors: */
+/*  ================== */
+/* > */
+/* > \verbatim */
+/* > */
+/* >   April 2012, Igor Kozachenko, */
+/* >                  Computer Science Division, */
+/* >                  University of California, Berkeley */
+/* > */
+/* >  September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */
+/* >                  School of Mathematics, */
+/* >                  University of Manchester */
+/* > */
+/* > \endverbatim */
+
+/*  ===================================================================== */
+/* Subroutine */ int ssytrs_rook_(char *uplo, integer *n, integer *nrhs, 
+	real *a, integer *lda, integer *ipiv, real *b, integer *ldb, integer *
+	info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+    real r__1;
+
+    /* Local variables */
+    extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, 
+	    integer *, real *, integer *, real *, integer *);
+    real akm1k;
+    integer j, k;
+    extern logical lsame_(char *, char *);
+    real denom;
+    extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), 
+	    sgemv_(char *, integer *, integer *, real *, real *, integer *, 
+	    real *, integer *, real *, real *, integer *);
+    logical upper;
+    extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, 
+	    integer *);
+    real ak, bk;
+    integer kp;
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    real akm1, bkm1;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     April 2012 */
+
+
+/*  ===================================================================== */
+
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1 * 1;
+    a -= a_offset;
+    --ipiv;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1 * 1;
+    b -= b_offset;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    if (! upper && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*nrhs < 0) {
+	*info = -3;
+    } else if (*lda < f2cmax(1,*n)) {
+	*info = -5;
+    } else if (*ldb < f2cmax(1,*n)) {
+	*info = -8;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("SSYTRS_ROOK", &i__1, (ftnlen)11);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0 || *nrhs == 0) {
+	return 0;
+    }
+
+    if (upper) {
+
+/*        Solve A*X = B, where A = U*D*U**T. */
+
+/*        First solve U*D*X = B, overwriting B with X. */
+
+/*        K is the main loop index, decreasing from N to 1 in steps of */
+/*        1 or 2, depending on the size of the diagonal blocks. */
+
+	k = *n;
+L10:
+
+/*        If K < 1, exit from loop. */
+
+	if (k < 1) {
+	    goto L30;
+	}
+
+	if (ipiv[k] > 0) {
+
+/*           1 x 1 diagonal block */
+
+/*           Interchange rows K and IPIV(K). */
+
+	    kp = ipiv[k];
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+
+/*           Multiply by inv(U(K)), where U(K) is the transformation */
+/*           stored in column K of A. */
+
+	    i__1 = k - 1;
+	    sger_(&i__1, nrhs, &c_b7, &a[k * a_dim1 + 1], &c__1, &b[k + 
+		    b_dim1], ldb, &b[b_dim1 + 1], ldb);
+
+/*           Multiply by the inverse of the diagonal block. */
+
+	    r__1 = 1.f / a[k + k * a_dim1];
+	    sscal_(nrhs, &r__1, &b[k + b_dim1], ldb);
+	    --k;
+	} else {
+
+/*           2 x 2 diagonal block */
+
+/*           Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1) */
+
+	    kp = -ipiv[k];
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+
+	    kp = -ipiv[k - 1];
+	    if (kp != k - 1) {
+		sswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+
+/*           Multiply by inv(U(K)), where U(K) is the transformation */
+/*           stored in columns K-1 and K of A. */
+
+	    if (k > 2) {
+		i__1 = k - 2;
+		sger_(&i__1, nrhs, &c_b7, &a[k * a_dim1 + 1], &c__1, &b[k + 
+			b_dim1], ldb, &b[b_dim1 + 1], ldb);
+		i__1 = k - 2;
+		sger_(&i__1, nrhs, &c_b7, &a[(k - 1) * a_dim1 + 1], &c__1, &b[
+			k - 1 + b_dim1], ldb, &b[b_dim1 + 1], ldb);
+	    }
+
+/*           Multiply by the inverse of the diagonal block. */
+
+	    akm1k = a[k - 1 + k * a_dim1];
+	    akm1 = a[k - 1 + (k - 1) * a_dim1] / akm1k;
+	    ak = a[k + k * a_dim1] / akm1k;
+	    denom = akm1 * ak - 1.f;
+	    i__1 = *nrhs;
+	    for (j = 1; j <= i__1; ++j) {
+		bkm1 = b[k - 1 + j * b_dim1] / akm1k;
+		bk = b[k + j * b_dim1] / akm1k;
+		b[k - 1 + j * b_dim1] = (ak * bkm1 - bk) / denom;
+		b[k + j * b_dim1] = (akm1 * bk - bkm1) / denom;
+/* L20: */
+	    }
+	    k += -2;
+	}
+
+	goto L10;
+L30:
+
+/*        Next solve U**T *X = B, overwriting B with X. */
+
+/*        K is the main loop index, increasing from 1 to N in steps of */
+/*        1 or 2, depending on the size of the diagonal blocks. */
+
+	k = 1;
+L40:
+
+/*        If K > N, exit from loop. */
+
+	if (k > *n) {
+	    goto L50;
+	}
+
+	if (ipiv[k] > 0) {
+
+/*           1 x 1 diagonal block */
+
+/*           Multiply by inv(U**T(K)), where U(K) is the transformation */
+/*           stored in column K of A. */
+
+	    if (k > 1) {
+		i__1 = k - 1;
+		sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[
+			k * a_dim1 + 1], &c__1, &c_b19, &b[k + b_dim1], ldb);
+	    }
+
+/*           Interchange rows K and IPIV(K). */
+
+	    kp = ipiv[k];
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+	    ++k;
+	} else {
+
+/*           2 x 2 diagonal block */
+
+/*           Multiply by inv(U**T(K+1)), where U(K+1) is the transformation */
+/*           stored in columns K and K+1 of A. */
+
+	    if (k > 1) {
+		i__1 = k - 1;
+		sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[
+			k * a_dim1 + 1], &c__1, &c_b19, &b[k + b_dim1], ldb);
+		i__1 = k - 1;
+		sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[
+			(k + 1) * a_dim1 + 1], &c__1, &c_b19, &b[k + 1 + 
+			b_dim1], ldb);
+	    }
+
+/*           Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1). */
+
+	    kp = -ipiv[k];
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+
+	    kp = -ipiv[k + 1];
+	    if (kp != k + 1) {
+		sswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+
+	    k += 2;
+	}
+
+	goto L40;
+L50:
+
+	;
+    } else {
+
+/*        Solve A*X = B, where A = L*D*L**T. */
+
+/*        First solve L*D*X = B, overwriting B with X. */
+
+/*        K is the main loop index, increasing from 1 to N in steps of */
+/*        1 or 2, depending on the size of the diagonal blocks. */
+
+	k = 1;
+L60:
+
+/*        If K > N, exit from loop. */
+
+	if (k > *n) {
+	    goto L80;
+	}
+
+	if (ipiv[k] > 0) {
+
+/*           1 x 1 diagonal block */
+
+/*           Interchange rows K and IPIV(K). */
+
+	    kp = ipiv[k];
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+
+/*           Multiply by inv(L(K)), where L(K) is the transformation */
+/*           stored in column K of A. */
+
+	    if (k < *n) {
+		i__1 = *n - k;
+		sger_(&i__1, nrhs, &c_b7, &a[k + 1 + k * a_dim1], &c__1, &b[k 
+			+ b_dim1], ldb, &b[k + 1 + b_dim1], ldb);
+	    }
+
+/*           Multiply by the inverse of the diagonal block. */
+
+	    r__1 = 1.f / a[k + k * a_dim1];
+	    sscal_(nrhs, &r__1, &b[k + b_dim1], ldb);
+	    ++k;
+	} else {
+
+/*           2 x 2 diagonal block */
+
+/*           Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1) */
+
+	    kp = -ipiv[k];
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+
+	    kp = -ipiv[k + 1];
+	    if (kp != k + 1) {
+		sswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+
+/*           Multiply by inv(L(K)), where L(K) is the transformation */
+/*           stored in columns K and K+1 of A. */
+
+	    if (k < *n - 1) {
+		i__1 = *n - k - 1;
+		sger_(&i__1, nrhs, &c_b7, &a[k + 2 + k * a_dim1], &c__1, &b[k 
+			+ b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
+		i__1 = *n - k - 1;
+		sger_(&i__1, nrhs, &c_b7, &a[k + 2 + (k + 1) * a_dim1], &c__1,
+			 &b[k + 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb);
+	    }
+
+/*           Multiply by the inverse of the diagonal block. */
+
+	    akm1k = a[k + 1 + k * a_dim1];
+	    akm1 = a[k + k * a_dim1] / akm1k;
+	    ak = a[k + 1 + (k + 1) * a_dim1] / akm1k;
+	    denom = akm1 * ak - 1.f;
+	    i__1 = *nrhs;
+	    for (j = 1; j <= i__1; ++j) {
+		bkm1 = b[k + j * b_dim1] / akm1k;
+		bk = b[k + 1 + j * b_dim1] / akm1k;
+		b[k + j * b_dim1] = (ak * bkm1 - bk) / denom;
+		b[k + 1 + j * b_dim1] = (akm1 * bk - bkm1) / denom;
+/* L70: */
+	    }
+	    k += 2;
+	}
+
+	goto L60;
+L80:
+
+/*        Next solve L**T *X = B, overwriting B with X. */
+
+/*        K is the main loop index, decreasing from N to 1 in steps of */
+/*        1 or 2, depending on the size of the diagonal blocks. */
+
+	k = *n;
+L90:
+
+/*        If K < 1, exit from loop. */
+
+	if (k < 1) {
+	    goto L100;
+	}
+
+	if (ipiv[k] > 0) {
+
+/*           1 x 1 diagonal block */
+
+/*           Multiply by inv(L**T(K)), where L(K) is the transformation */
+/*           stored in column K of A. */
+
+	    if (k < *n) {
+		i__1 = *n - k;
+		sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], 
+			ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b19, &b[k + 
+			b_dim1], ldb);
+	    }
+
+/*           Interchange rows K and IPIV(K). */
+
+	    kp = ipiv[k];
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+	    --k;
+	} else {
+
+/*           2 x 2 diagonal block */
+
+/*           Multiply by inv(L**T(K-1)), where L(K-1) is the transformation */
+/*           stored in columns K-1 and K of A. */
+
+	    if (k < *n) {
+		i__1 = *n - k;
+		sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], 
+			ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b19, &b[k + 
+			b_dim1], ldb);
+		i__1 = *n - k;
+		sgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], 
+			ldb, &a[k + 1 + (k - 1) * a_dim1], &c__1, &c_b19, &b[
+			k - 1 + b_dim1], ldb);
+	    }
+
+/*           Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1) */
+
+	    kp = -ipiv[k];
+	    if (kp != k) {
+		sswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+
+	    kp = -ipiv[k - 1];
+	    if (kp != k - 1) {
+		sswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb);
+	    }
+
+	    k += -2;
+	}
+
+	goto L90;
+L100:
+	;
+    }
+
+    return 0;
+
+/*     End of SSYTRS_ROOK */
+
+} /* ssytrs_rook__ */
+

lapack-netlib/SRC/stbcon.c

@@ -0,0 +1,686 @@
+/* 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;
+
+/* > \brief \b STBCON */
+
+/*  =========== DOCUMENTATION =========== */
+
+/* Online html documentation available at */
+/*            http://www.netlib.org/lapack/explore-html/ */
+
+/* > \htmlonly */
+/* > Download STBCON + dependencies */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/stbcon.
+f"> */
+/* > [TGZ]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/stbcon.
+f"> */
+/* > [ZIP]</a> */
+/* > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/stbcon.
+f"> */
+/* > [TXT]</a> */
+/* > \endhtmlonly */
+
+/*  Definition: */
+/*  =========== */
+
+/*       SUBROUTINE STBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, */
+/*                          IWORK, INFO ) */
+
+/*       CHARACTER          DIAG, NORM, UPLO */
+/*       INTEGER            INFO, KD, LDAB, N */
+/*       REAL               RCOND */
+/*       INTEGER            IWORK( * ) */
+/*       REAL               AB( LDAB, * ), WORK( * ) */
+
+
+/* > \par Purpose: */
+/*  ============= */
+/* > */
+/* > \verbatim */
+/* > */
+/* > STBCON estimates the reciprocal of the condition number of a */
+/* > triangular band matrix A, in either the 1-norm or the infinity-norm. */
+/* > */
+/* > The norm of A is computed and an estimate is obtained for */
+/* > norm(inv(A)), then the reciprocal of the condition number is */
+/* > computed as */
+/* >    RCOND = 1 / ( norm(A) * norm(inv(A)) ). */
+/* > \endverbatim */
+
+/*  Arguments: */
+/*  ========== */
+
+/* > \param[in] NORM */
+/* > \verbatim */
+/* >          NORM is CHARACTER*1 */
+/* >          Specifies whether the 1-norm condition number or the */
+/* >          infinity-norm condition number is required: */
+/* >          = '1' or 'O':  1-norm; */
+/* >          = 'I':         Infinity-norm. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] UPLO */
+/* > \verbatim */
+/* >          UPLO is CHARACTER*1 */
+/* >          = 'U':  A is upper triangular; */
+/* >          = 'L':  A is lower triangular. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] DIAG */
+/* > \verbatim */
+/* >          DIAG is CHARACTER*1 */
+/* >          = 'N':  A is non-unit triangular; */
+/* >          = 'U':  A is unit triangular. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] N */
+/* > \verbatim */
+/* >          N is INTEGER */
+/* >          The order of the matrix A.  N >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] KD */
+/* > \verbatim */
+/* >          KD is INTEGER */
+/* >          The number of superdiagonals or subdiagonals of the */
+/* >          triangular band matrix A.  KD >= 0. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] AB */
+/* > \verbatim */
+/* >          AB is REAL array, dimension (LDAB,N) */
+/* >          The upper or lower triangular band matrix A, stored in the */
+/* >          first kd+1 rows of the array. The j-th column of A is stored */
+/* >          in the j-th column of the array AB as follows: */
+/* >          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */
+/* >          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=f2cmin(n,j+kd). */
+/* >          If DIAG = 'U', the diagonal elements of A are not referenced */
+/* >          and are assumed to be 1. */
+/* > \endverbatim */
+/* > */
+/* > \param[in] LDAB */
+/* > \verbatim */
+/* >          LDAB is INTEGER */
+/* >          The leading dimension of the array AB.  LDAB >= KD+1. */
+/* > \endverbatim */
+/* > */
+/* > \param[out] RCOND */
+/* > \verbatim */
+/* >          RCOND is REAL */
+/* >          The reciprocal of the condition number of the matrix A, */
+/* >          computed as RCOND = 1/(norm(A) * norm(inv(A))). */
+/* > \endverbatim */
+/* > */
+/* > \param[out] WORK */
+/* > \verbatim */
+/* >          WORK is REAL array, dimension (3*N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] IWORK */
+/* > \verbatim */
+/* >          IWORK is INTEGER array, dimension (N) */
+/* > \endverbatim */
+/* > */
+/* > \param[out] INFO */
+/* > \verbatim */
+/* >          INFO is INTEGER */
+/* >          = 0:  successful exit */
+/* >          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/* > \endverbatim */
+
+/*  Authors: */
+/*  ======== */
+
+/* > \author Univ. of Tennessee */
+/* > \author Univ. of California Berkeley */
+/* > \author Univ. of Colorado Denver */
+/* > \author NAG Ltd. */
+
+/* > \date December 2016 */
+
+/* > \ingroup realOTHERcomputational */
+
+/*  ===================================================================== */
+/* Subroutine */ int stbcon_(char *norm, char *uplo, char *diag, integer *n, 
+	integer *kd, real *ab, integer *ldab, real *rcond, real *work, 
+	integer *iwork, integer *info)
+{
+    /* System generated locals */
+    integer ab_dim1, ab_offset, i__1;
+    real r__1;
+
+    /* Local variables */
+    integer kase, kase1;
+    real scale;
+    extern logical lsame_(char *, char *);
+    integer isave[3];
+    real anorm;
+    extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *);
+    logical upper;
+    real xnorm;
+    extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *, 
+	    real *, integer *, integer *);
+    integer ix;
+    extern real slamch_(char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
+    extern integer isamax_(integer *, real *, integer *);
+    extern real slantb_(char *, char *, char *, integer *, integer *, real *, 
+	    integer *, real *);
+    real ainvnm;
+    extern /* Subroutine */ int slatbs_(char *, char *, char *, char *, 
+	    integer *, integer *, real *, integer *, real *, real *, real *, 
+	    integer *);
+    logical onenrm;
+    char normin[1];
+    real smlnum;
+    logical nounit;
+
+
+/*  -- LAPACK computational routine (version 3.7.0) -- */
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+/*     December 2016 */
+
+
+/*  ===================================================================== */
+
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    ab_dim1 = *ldab;
+    ab_offset = 1 + ab_dim1 * 1;
+    ab -= ab_offset;
+    --work;
+    --iwork;
+
+    /* Function Body */
+    *info = 0;
+    upper = lsame_(uplo, "U");
+    onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O");
+    nounit = lsame_(diag, "N");
+
+    if (! onenrm && ! lsame_(norm, "I")) {
+	*info = -1;
+    } else if (! upper && ! lsame_(uplo, "L")) {
+	*info = -2;
+    } else if (! nounit && ! lsame_(diag, "U")) {
+	*info = -3;
+    } else if (*n < 0) {
+	*info = -4;
+    } else if (*kd < 0) {
+	*info = -5;
+    } else if (*ldab < *kd + 1) {
+	*info = -7;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("STBCON", &i__1, (ftnlen)6);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	*rcond = 1.f;
+	return 0;
+    }
+
+    *rcond = 0.f;
+    smlnum = slamch_("Safe minimum") * (real) f2cmax(1,*n);
+
+/*     Compute the norm of the triangular matrix A. */
+
+    anorm = slantb_(norm, uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1]);
+
+/*     Continue only if ANORM > 0. */
+
+    if (anorm > 0.f) {
+
+/*        Estimate the norm of the inverse of A. */
+
+	ainvnm = 0.f;
+	*(unsigned char *)normin = 'N';
+	if (onenrm) {
+	    kase1 = 1;
+	} else {
+	    kase1 = 2;
+	}
+	kase = 0;
+L10:
+	slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave);
+	if (kase != 0) {
+	    if (kase == kase1) {
+
+/*              Multiply by inv(A). */
+
+		slatbs_(uplo, "No transpose", diag, normin, n, kd, &ab[
+			ab_offset], ldab, &work[1], &scale, &work[(*n << 1) + 
+			1], info)
+			;
+	    } else {
+
+/*              Multiply by inv(A**T). */
+
+		slatbs_(uplo, "Transpose", diag, normin, n, kd, &ab[ab_offset]
+			, ldab, &work[1], &scale, &work[(*n << 1) + 1], info);
+	    }
+	    *(unsigned char *)normin = 'Y';
+
+/*           Multiply by 1/SCALE if doing so will not cause overflow. */
+
+	    if (scale != 1.f) {
+		ix = isamax_(n, &work[1], &c__1);
+		xnorm = (r__1 = work[ix], abs(r__1));
+		if (scale < xnorm * smlnum || scale == 0.f) {
+		    goto L20;
+		}
+		srscl_(n, &scale, &work[1], &c__1);
+	    }
+	    goto L10;
+	}
+
+/*        Compute the estimate of the reciprocal condition number. */
+
+	if (ainvnm != 0.f) {
+	    *rcond = 1.f / anorm / ainvnm;
+	}
+    }
+
+L20:
+    return 0;
+
+/*     End of STBCON */
+
+} /* stbcon_ */
+