diff --git a/lapack-netlib/SRC/zlacn2.c b/lapack-netlib/SRC/zlacn2.c new file mode 100644 index 000000000..a68843cfe --- /dev/null +++ b/lapack-netlib/SRC/zlacn2.c @@ -0,0 +1,717 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matr +ix-vector products. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLACN2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLACN2( N, V, X, EST, KASE, ISAVE ) */ + +/* INTEGER KASE, N */ +/* DOUBLE PRECISION EST */ +/* INTEGER ISAVE( 3 ) */ +/* COMPLEX*16 V( * ), X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLACN2 estimates the 1-norm of a square, complex matrix A. */ +/* > Reverse communication is used for evaluating matrix-vector products. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is COMPLEX*16 array, dimension (N) */ +/* > On the final return, V = A*W, where EST = norm(V)/norm(W) */ +/* > (W is not returned). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (N) */ +/* > On an intermediate return, X should be overwritten by */ +/* > A * X, if KASE=1, */ +/* > A**H * X, if KASE=2, */ +/* > where A**H is the conjugate transpose of A, and ZLACN2 must be */ +/* > re-called with all the other parameters unchanged. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] EST */ +/* > \verbatim */ +/* > EST is DOUBLE PRECISION */ +/* > On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be */ +/* > unchanged from the previous call to ZLACN2. */ +/* > On exit, EST is an estimate (a lower bound) for norm(A). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] KASE */ +/* > \verbatim */ +/* > KASE is INTEGER */ +/* > On the initial call to ZLACN2, KASE should be 0. */ +/* > On an intermediate return, KASE will be 1 or 2, indicating */ +/* > whether X should be overwritten by A * X or A**H * X. */ +/* > On the final return from ZLACN2, KASE will again be 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISAVE */ +/* > \verbatim */ +/* > ISAVE is INTEGER array, dimension (3) */ +/* > ISAVE is used to save variables between calls to ZLACN2 */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Originally named CONEST, dated March 16, 1988. */ +/* > */ +/* > Last modified: April, 1999 */ +/* > */ +/* > This is a thread safe version of ZLACON, which uses the array ISAVE */ +/* > in place of a SAVE statement, as follows: */ +/* > */ +/* > ZLACON ZLACN2 */ +/* > JUMP ISAVE(1) */ +/* > J ISAVE(2) */ +/* > ITER ISAVE(3) */ +/* > \endverbatim */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Nick Higham, University of Manchester */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > N.J. Higham, "FORTRAN codes for estimating the one-norm of */ +/* > a real or complex matrix, with applications to condition estimation", */ +/* > ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlacn2_(integer *n, doublecomplex *v, doublecomplex *x, + doublereal *est, integer *kase, integer *isave) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + doublereal d__1, d__2; + doublecomplex z__1; + + /* Local variables */ + doublereal temp; + integer i__; + doublereal absxi; + integer jlast; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + extern integer izmax1_(integer *, doublecomplex *, integer *); + extern doublereal dzsum1_(integer *, doublecomplex *, integer *), dlamch_( + char *); + doublereal safmin, altsgn, estold; + + +/* -- 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 */ + --isave; + --x; + --v; + + /* Function Body */ + safmin = dlamch_("Safe minimum"); + if (*kase == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + d__1 = 1. / (doublereal) (*n); + z__1.r = d__1, z__1.i = 0.; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; +/* L10: */ + } + *kase = 1; + isave[1] = 1; + return 0; + } + + switch (isave[1]) { + case 1: goto L20; + case 2: goto L40; + case 3: goto L70; + case 4: goto L90; + case 5: goto L120; + } + +/* ................ ENTRY (ISAVE( 1 ) = 1) */ +/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */ + +L20: + if (*n == 1) { + v[1].r = x[1].r, v[1].i = x[1].i; + *est = z_abs(&v[1]); +/* ... QUIT */ + goto L130; + } + *est = dzsum1_(n, &x[1], &c__1); + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + absxi = z_abs(&x[i__]); + if (absxi > safmin) { + i__2 = i__; + i__3 = i__; + d__1 = x[i__3].r / absxi; + d__2 = d_imag(&x[i__]) / absxi; + z__1.r = d__1, z__1.i = d__2; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } else { + i__2 = i__; + x[i__2].r = 1., x[i__2].i = 0.; + } +/* L30: */ + } + *kase = 2; + isave[1] = 2; + return 0; + +/* ................ ENTRY (ISAVE( 1 ) = 2) */ +/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. */ + +L40: + isave[2] = izmax1_(n, &x[1], &c__1); + isave[3] = 2; + +/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */ + +L50: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + x[i__2].r = 0., x[i__2].i = 0.; +/* L60: */ + } + i__1 = isave[2]; + x[i__1].r = 1., x[i__1].i = 0.; + *kase = 1; + isave[1] = 3; + return 0; + +/* ................ ENTRY (ISAVE( 1 ) = 3) */ +/* X HAS BEEN OVERWRITTEN BY A*X. */ + +L70: + zcopy_(n, &x[1], &c__1, &v[1], &c__1); + estold = *est; + *est = dzsum1_(n, &v[1], &c__1); + +/* TEST FOR CYCLING. */ + if (*est <= estold) { + goto L100; + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + absxi = z_abs(&x[i__]); + if (absxi > safmin) { + i__2 = i__; + i__3 = i__; + d__1 = x[i__3].r / absxi; + d__2 = d_imag(&x[i__]) / absxi; + z__1.r = d__1, z__1.i = d__2; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } else { + i__2 = i__; + x[i__2].r = 1., x[i__2].i = 0.; + } +/* L80: */ + } + *kase = 2; + isave[1] = 4; + return 0; + +/* ................ ENTRY (ISAVE( 1 ) = 4) */ +/* X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. */ + +L90: + jlast = isave[2]; + isave[2] = izmax1_(n, &x[1], &c__1); + if (z_abs(&x[jlast]) != z_abs(&x[isave[2]]) && isave[3] < 5) { + ++isave[3]; + goto L50; + } + +/* ITERATION COMPLETE. FINAL STAGE. */ + +L100: + altsgn = 1.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + d__1 = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) + 1.); + z__1.r = d__1, z__1.i = 0.; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + altsgn = -altsgn; +/* L110: */ + } + *kase = 1; + isave[1] = 5; + return 0; + +/* ................ ENTRY (ISAVE( 1 ) = 5) */ +/* X HAS BEEN OVERWRITTEN BY A*X. */ + +L120: + temp = dzsum1_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.; + if (temp > *est) { + zcopy_(n, &x[1], &c__1, &v[1], &c__1); + *est = temp; + } + +L130: + *kase = 0; + return 0; + +/* End of ZLACN2 */ + +} /* zlacn2_ */ + diff --git a/lapack-netlib/SRC/zlacon.c b/lapack-netlib/SRC/zlacon.c new file mode 100644 index 000000000..a7cda9be0 --- /dev/null +++ b/lapack-netlib/SRC/zlacon.c @@ -0,0 +1,698 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLACON estimates the 1-norm of a square matrix, using reverse communication for evaluating matr +ix-vector products. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLACON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLACON( N, V, X, EST, KASE ) */ + +/* INTEGER KASE, N */ +/* DOUBLE PRECISION EST */ +/* COMPLEX*16 V( N ), X( N ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLACON estimates the 1-norm of a square, complex matrix A. */ +/* > Reverse communication is used for evaluating matrix-vector products. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is COMPLEX*16 array, dimension (N) */ +/* > On the final return, V = A*W, where EST = norm(V)/norm(W) */ +/* > (W is not returned). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (N) */ +/* > On an intermediate return, X should be overwritten by */ +/* > A * X, if KASE=1, */ +/* > A**H * X, if KASE=2, */ +/* > where A**H is the conjugate transpose of A, and ZLACON must be */ +/* > re-called with all the other parameters unchanged. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] EST */ +/* > \verbatim */ +/* > EST is DOUBLE PRECISION */ +/* > On entry with KASE = 1 or 2 and JUMP = 3, EST should be */ +/* > unchanged from the previous call to ZLACON. */ +/* > On exit, EST is an estimate (a lower bound) for norm(A). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] KASE */ +/* > \verbatim */ +/* > KASE is INTEGER */ +/* > On the initial call to ZLACON, KASE should be 0. */ +/* > On an intermediate return, KASE will be 1 or 2, indicating */ +/* > whether X should be overwritten by A * X or A**H * X. */ +/* > On the final return from ZLACON, KASE will again be 0. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > Originally named CONEST, dated March 16, 1988. \n */ +/* > Last modified: April, 1999 */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Nick Higham, University of Manchester */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > N.J. Higham, "FORTRAN codes for estimating the one-norm of */ +/* > a real or complex matrix, with applications to condition estimation", */ +/* > ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlacon_(integer *n, doublecomplex *v, doublecomplex *x, + doublereal *est, integer *kase) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + doublereal d__1, d__2; + doublecomplex z__1; + + /* Local variables */ + static integer iter; + static doublereal temp; + static integer jump, i__, j; + static doublereal absxi; + static integer jlast; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + extern integer izmax1_(integer *, doublecomplex *, integer *); + extern doublereal dzsum1_(integer *, doublecomplex *, integer *), dlamch_( + char *); + static doublereal safmin, altsgn, estold; + + +/* -- 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 */ + --x; + --v; + + /* Function Body */ + safmin = dlamch_("Safe minimum"); + if (*kase == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + d__1 = 1. / (doublereal) (*n); + z__1.r = d__1, z__1.i = 0.; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; +/* L10: */ + } + *kase = 1; + jump = 1; + return 0; + } + + switch (jump) { + case 1: goto L20; + case 2: goto L40; + case 3: goto L70; + case 4: goto L90; + case 5: goto L120; + } + +/* ................ ENTRY (JUMP = 1) */ +/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X. */ + +L20: + if (*n == 1) { + v[1].r = x[1].r, v[1].i = x[1].i; + *est = z_abs(&v[1]); +/* ... QUIT */ + goto L130; + } + *est = dzsum1_(n, &x[1], &c__1); + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + absxi = z_abs(&x[i__]); + if (absxi > safmin) { + i__2 = i__; + i__3 = i__; + d__1 = x[i__3].r / absxi; + d__2 = d_imag(&x[i__]) / absxi; + z__1.r = d__1, z__1.i = d__2; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } else { + i__2 = i__; + x[i__2].r = 1., x[i__2].i = 0.; + } +/* L30: */ + } + *kase = 2; + jump = 2; + return 0; + +/* ................ ENTRY (JUMP = 2) */ +/* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. */ + +L40: + j = izmax1_(n, &x[1], &c__1); + iter = 2; + +/* MAIN LOOP - ITERATIONS 2,3,...,ITMAX. */ + +L50: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + x[i__2].r = 0., x[i__2].i = 0.; +/* L60: */ + } + i__1 = j; + x[i__1].r = 1., x[i__1].i = 0.; + *kase = 1; + jump = 3; + return 0; + +/* ................ ENTRY (JUMP = 3) */ +/* X HAS BEEN OVERWRITTEN BY A*X. */ + +L70: + zcopy_(n, &x[1], &c__1, &v[1], &c__1); + estold = *est; + *est = dzsum1_(n, &v[1], &c__1); + +/* TEST FOR CYCLING. */ + if (*est <= estold) { + goto L100; + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + absxi = z_abs(&x[i__]); + if (absxi > safmin) { + i__2 = i__; + i__3 = i__; + d__1 = x[i__3].r / absxi; + d__2 = d_imag(&x[i__]) / absxi; + z__1.r = d__1, z__1.i = d__2; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + } else { + i__2 = i__; + x[i__2].r = 1., x[i__2].i = 0.; + } +/* L80: */ + } + *kase = 2; + jump = 4; + return 0; + +/* ................ ENTRY (JUMP = 4) */ +/* X HAS BEEN OVERWRITTEN BY CTRANS(A)*X. */ + +L90: + jlast = j; + j = izmax1_(n, &x[1], &c__1); + if (z_abs(&x[jlast]) != z_abs(&x[j]) && iter < 5) { + ++iter; + goto L50; + } + +/* ITERATION COMPLETE. FINAL STAGE. */ + +L100: + altsgn = 1.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + d__1 = altsgn * ((doublereal) (i__ - 1) / (doublereal) (*n - 1) + 1.); + z__1.r = d__1, z__1.i = 0.; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + altsgn = -altsgn; +/* L110: */ + } + *kase = 1; + jump = 5; + return 0; + +/* ................ ENTRY (JUMP = 5) */ +/* X HAS BEEN OVERWRITTEN BY A*X. */ + +L120: + temp = dzsum1_(n, &x[1], &c__1) / (doublereal) (*n * 3) * 2.; + if (temp > *est) { + zcopy_(n, &x[1], &c__1, &v[1], &c__1); + *est = temp; + } + +L130: + *kase = 0; + return 0; + +/* End of ZLACON */ + +} /* zlacon_ */ + diff --git a/lapack-netlib/SRC/zlacp2.c b/lapack-netlib/SRC/zlacp2.c new file mode 100644 index 000000000..a7c94f72a --- /dev/null +++ b/lapack-netlib/SRC/zlacp2.c @@ -0,0 +1,566 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLACP2 copies all or part of a real two-dimensional array to a complex array. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLACP2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLACP2( UPLO, M, N, A, LDA, B, LDB ) */ + +/* CHARACTER UPLO */ +/* INTEGER LDA, LDB, M, N */ +/* DOUBLE PRECISION A( LDA, * ) */ +/* COMPLEX*16 B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLACP2 copies all or part of a real two-dimensional matrix A to a */ +/* > complex matrix B. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies the part of the matrix A to be copied to B. */ +/* > = 'U': Upper triangular part */ +/* > = 'L': Lower triangular part */ +/* > Otherwise: All of the matrix A */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > The m by n matrix A. If UPLO = 'U', only the upper trapezium */ +/* > is accessed; if UPLO = 'L', only the lower trapezium is */ +/* > accessed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,N) */ +/* > On exit, B = A in the locations specified by UPLO. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlacp2_(char *uplo, integer *m, integer *n, doublereal * + a, integer *lda, doublecomplex *b, integer *ldb) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + + +/* -- 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; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = f2cmin(j,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * a_dim1; + b[i__3].r = a[i__4], b[i__3].i = 0.; +/* L10: */ + } +/* L20: */ + } + + } else if (lsame_(uplo, "L")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * a_dim1; + b[i__3].r = a[i__4], b[i__3].i = 0.; +/* L30: */ + } +/* L40: */ + } + + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * a_dim1; + b[i__3].r = a[i__4], b[i__3].i = 0.; +/* L50: */ + } +/* L60: */ + } + } + + return 0; + +/* End of ZLACP2 */ + +} /* zlacp2_ */ + diff --git a/lapack-netlib/SRC/zlacpy.c b/lapack-netlib/SRC/zlacpy.c new file mode 100644 index 000000000..2af22ac3c --- /dev/null +++ b/lapack-netlib/SRC/zlacpy.c @@ -0,0 +1,565 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLACPY copies all or part of one two-dimensional array to another. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLACPY + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLACPY( UPLO, M, N, A, LDA, B, LDB ) */ + +/* CHARACTER UPLO */ +/* INTEGER LDA, LDB, M, N */ +/* COMPLEX*16 A( LDA, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLACPY copies all or part of a two-dimensional matrix A to another */ +/* > matrix B. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies the part of the matrix A to be copied to B. */ +/* > = 'U': Upper triangular part */ +/* > = 'L': Lower triangular part */ +/* > Otherwise: All of the matrix A */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > The m by n matrix A. If UPLO = 'U', only the upper trapezium */ +/* > is accessed; if UPLO = 'L', only the lower trapezium is */ +/* > accessed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,N) */ +/* > On exit, B = A in the locations specified by UPLO. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlacpy_(char *uplo, integer *m, integer *n, + doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + + +/* -- 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; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = f2cmin(j,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * a_dim1; + b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i; +/* L10: */ + } +/* L20: */ + } + + } else if (lsame_(uplo, "L")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * a_dim1; + b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i; +/* L30: */ + } +/* L40: */ + } + + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * a_dim1; + b[i__3].r = a[i__4].r, b[i__3].i = a[i__4].i; +/* L50: */ + } +/* L60: */ + } + } + + return 0; + +/* End of ZLACPY */ + +} /* zlacpy_ */ + diff --git a/lapack-netlib/SRC/zlacrm.c b/lapack-netlib/SRC/zlacrm.c new file mode 100644 index 000000000..9d5a1de11 --- /dev/null +++ b/lapack-netlib/SRC/zlacrm.c @@ -0,0 +1,609 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLACRM multiplies a complex matrix by a square real matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLACRM + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLACRM( M, N, A, LDA, B, LDB, C, LDC, RWORK ) */ + +/* INTEGER LDA, LDB, LDC, M, N */ +/* DOUBLE PRECISION B( LDB, * ), RWORK( * ) */ +/* COMPLEX*16 A( LDA, * ), C( LDC, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLACRM performs a very simple matrix-matrix multiplication: */ +/* > C := A * B, */ +/* > where A is M by N and complex; B is N by N and real; */ +/* > C is M by N and complex. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A and of the matrix C. */ +/* > M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns and rows of the matrix B and */ +/* > the number of columns of the matrix C. */ +/* > N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA, N) */ +/* > On entry, A contains the M by N matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >=f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB, N) */ +/* > On entry, B contains the N by N matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >=f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] C */ +/* > \verbatim */ +/* > C is COMPLEX*16 array, dimension (LDC, N) */ +/* > On exit, C contains the M by N matrix C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >=f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (2*M*N) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlacrm_(integer *m, integer *n, doublecomplex *a, + integer *lda, doublereal *b, integer *ldb, doublecomplex *c__, + integer *ldc, doublereal *rwork) +{ + /* System generated locals */ + integer b_dim1, b_offset, a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5; + doublereal d__1; + doublecomplex z__1; + + /* Local variables */ + integer i__, j, l; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --rwork; + + /* Function Body */ + if (*m == 0 || *n == 0) { + return 0; + } + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + rwork[(j - 1) * *m + i__] = a[i__3].r; +/* L10: */ + } +/* L20: */ + } + + l = *m * *n + 1; + dgemm_("N", "N", m, n, n, &c_b6, &rwork[1], m, &b[b_offset], ldb, &c_b7, & + rwork[l], m); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = l + (j - 1) * *m + i__ - 1; + c__[i__3].r = rwork[i__4], c__[i__3].i = 0.; +/* L30: */ + } +/* L40: */ + } + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + rwork[(j - 1) * *m + i__] = d_imag(&a[i__ + j * a_dim1]); +/* L50: */ + } +/* L60: */ + } + dgemm_("N", "N", m, n, n, &c_b6, &rwork[1], m, &b[b_offset], ldb, &c_b7, & + rwork[l], m); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + d__1 = c__[i__4].r; + i__5 = l + (j - 1) * *m + i__ - 1; + z__1.r = d__1, z__1.i = rwork[i__5]; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L70: */ + } +/* L80: */ + } + + return 0; + +/* End of ZLACRM */ + +} /* zlacrm_ */ + diff --git a/lapack-netlib/SRC/zlacrt.c b/lapack-netlib/SRC/zlacrt.c new file mode 100644 index 000000000..96b4c86f9 --- /dev/null +++ b/lapack-netlib/SRC/zlacrt.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 +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLACRT performs a linear transformation of a pair of complex vectors. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLACRT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLACRT( N, CX, INCX, CY, INCY, C, S ) */ + +/* INTEGER INCX, INCY, N */ +/* COMPLEX*16 C, S */ +/* COMPLEX*16 CX( * ), CY( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLACRT performs the operation */ +/* > */ +/* > ( c s )( x ) ==> ( x ) */ +/* > ( -s c )( y ) ( y ) */ +/* > */ +/* > where c and s are complex and the vectors x and y are complex. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of elements in the vectors CX and CY. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] CX */ +/* > \verbatim */ +/* > CX is COMPLEX*16 array, dimension (N) */ +/* > On input, the vector x. */ +/* > On output, CX is overwritten with c*x + s*y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The increment between successive values of CX. INCX <> 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] CY */ +/* > \verbatim */ +/* > CY is COMPLEX*16 array, dimension (N) */ +/* > On input, the vector y. */ +/* > On output, CY is overwritten with -s*x + c*y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCY */ +/* > \verbatim */ +/* > INCY is INTEGER */ +/* > The increment between successive values of CY. INCY <> 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is COMPLEX*16 */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is COMPLEX*16 */ +/* > C and S define the matrix */ +/* > [ C S ]. */ +/* > [ -S C ] */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlacrt_(integer *n, doublecomplex *cx, integer *incx, + doublecomplex *cy, integer *incy, doublecomplex *c__, doublecomplex * + s) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + integer i__; + doublecomplex ctemp; + integer ix, iy; + + +/* -- 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 */ + --cy; + --cx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + if (*incx == 1 && *incy == 1) { + goto L20; + } + +/* Code for unequal increments or equal increments not equal to 1 */ + + ix = 1; + iy = 1; + if (*incx < 0) { + ix = (-(*n) + 1) * *incx + 1; + } + if (*incy < 0) { + iy = (-(*n) + 1) * *incy + 1; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ix; + z__2.r = c__->r * cx[i__2].r - c__->i * cx[i__2].i, z__2.i = c__->r * + cx[i__2].i + c__->i * cx[i__2].r; + i__3 = iy; + z__3.r = s->r * cy[i__3].r - s->i * cy[i__3].i, z__3.i = s->r * cy[ + i__3].i + s->i * cy[i__3].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__2 = iy; + i__3 = iy; + z__2.r = c__->r * cy[i__3].r - c__->i * cy[i__3].i, z__2.i = c__->r * + cy[i__3].i + c__->i * cy[i__3].r; + i__4 = ix; + z__3.r = s->r * cx[i__4].r - s->i * cx[i__4].i, z__3.i = s->r * cx[ + i__4].i + s->i * cx[i__4].r; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + cy[i__2].r = z__1.r, cy[i__2].i = z__1.i; + i__2 = ix; + cx[i__2].r = ctemp.r, cx[i__2].i = ctemp.i; + ix += *incx; + iy += *incy; +/* L10: */ + } + return 0; + +/* Code for both increments equal to 1 */ + +L20: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + z__2.r = c__->r * cx[i__2].r - c__->i * cx[i__2].i, z__2.i = c__->r * + cx[i__2].i + c__->i * cx[i__2].r; + i__3 = i__; + z__3.r = s->r * cy[i__3].r - s->i * cy[i__3].i, z__3.i = s->r * cy[ + i__3].i + s->i * cy[i__3].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__2 = i__; + i__3 = i__; + z__2.r = c__->r * cy[i__3].r - c__->i * cy[i__3].i, z__2.i = c__->r * + cy[i__3].i + c__->i * cy[i__3].r; + i__4 = i__; + z__3.r = s->r * cx[i__4].r - s->i * cx[i__4].i, z__3.i = s->r * cx[ + i__4].i + s->i * cx[i__4].r; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + cy[i__2].r = z__1.r, cy[i__2].i = z__1.i; + i__2 = i__; + cx[i__2].r = ctemp.r, cx[i__2].i = ctemp.i; +/* L30: */ + } + return 0; +} /* zlacrt_ */ + diff --git a/lapack-netlib/SRC/zladiv.c b/lapack-netlib/SRC/zladiv.c new file mode 100644 index 000000000..f5eb8c6c0 --- /dev/null +++ b/lapack-netlib/SRC/zladiv.c @@ -0,0 +1,490 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLADIV performs complex division in real arithmetic, avoiding unnecessary overflow. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLADIV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* COMPLEX*16 FUNCTION ZLADIV( X, Y ) */ + +/* COMPLEX*16 X, Y */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLADIV := X / Y, where X and Y are complex. The computation of X / Y */ +/* > will not overflow on an intermediary step unless the results */ +/* > overflows. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Y */ +/* > \verbatim */ +/* > Y is COMPLEX*16 */ +/* > The complex scalars X and Y. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Double Complex */ VOID zladiv_(doublecomplex * ret_val, doublecomplex *x, + doublecomplex *y) +{ + /* System generated locals */ + doublereal d__1, d__2, d__3, d__4; + doublecomplex z__1; + + /* Local variables */ + doublereal zi; + extern /* Subroutine */ int dladiv_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *); + doublereal zr; + + +/* -- 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 */ + + +/* ===================================================================== */ + + + d__1 = x->r; + d__2 = d_imag(x); + d__3 = y->r; + d__4 = d_imag(y); + dladiv_(&d__1, &d__2, &d__3, &d__4, &zr, &zi); + z__1.r = zr, z__1.i = zi; + ret_val->r = z__1.r, ret_val->i = z__1.i; + + return ; + +/* End of ZLADIV */ + +} /* zladiv_ */ + diff --git a/lapack-netlib/SRC/zlaed0.c b/lapack-netlib/SRC/zlaed0.c new file mode 100644 index 000000000..c8270830a --- /dev/null +++ b/lapack-netlib/SRC/zlaed0.c @@ -0,0 +1,804 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAED0 used by sstedc. Computes all eigenvalues and corresponding eigenvectors of an unreduced +symmetric tridiagonal matrix using the divide and conquer method. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAED0 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAED0( QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS, RWORK, */ +/* IWORK, INFO ) */ + +/* INTEGER INFO, LDQ, LDQS, N, QSIZ */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION D( * ), E( * ), RWORK( * ) */ +/* COMPLEX*16 Q( LDQ, * ), QSTORE( LDQS, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Using the divide and conquer method, ZLAED0 computes all eigenvalues */ +/* > of a symmetric tridiagonal matrix which is one diagonal block of */ +/* > those from reducing a dense or band Hermitian matrix and */ +/* > corresponding eigenvectors of the dense or band matrix. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] QSIZ */ +/* > \verbatim */ +/* > QSIZ is INTEGER */ +/* > The dimension of the unitary matrix used to reduce */ +/* > the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1. */ +/* > \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 DOUBLE PRECISION array, dimension (N) */ +/* > On entry, the diagonal elements of the tridiagonal matrix. */ +/* > On exit, the eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > On entry, the off-diagonal elements of the tridiagonal matrix. */ +/* > On exit, E has been destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is COMPLEX*16 array, dimension (LDQ,N) */ +/* > On entry, Q must contain an QSIZ x N matrix whose columns */ +/* > unitarily orthonormal. It is a part of the unitary matrix */ +/* > that reduces the full dense Hermitian matrix to a */ +/* > (reducible) symmetric tridiagonal matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, */ +/* > the dimension of IWORK must be at least */ +/* > 6 + 6*N + 5*N*lg N */ +/* > ( lg( N ) = smallest integer k */ +/* > such that 2^k >= N ) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, */ +/* > dimension (1 + 3*N + 2*N*lg N + 3*N**2) */ +/* > ( lg( N ) = smallest integer k */ +/* > such that 2^k >= N ) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] QSTORE */ +/* > \verbatim */ +/* > QSTORE is COMPLEX*16 array, dimension (LDQS, N) */ +/* > Used to store parts of */ +/* > the eigenvector matrix when the updating matrix multiplies */ +/* > take place. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQS */ +/* > \verbatim */ +/* > LDQS is INTEGER */ +/* > The leading dimension of the array QSTORE. */ +/* > LDQS >= 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: 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 complex16OTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zlaed0_(integer *qsiz, integer *n, doublereal *d__, + doublereal *e, doublecomplex *q, integer *ldq, doublecomplex *qstore, + integer *ldqs, doublereal *rwork, integer *iwork, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, qstore_dim1, qstore_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + doublereal temp; + integer curr, i__, j, k, iperm; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + integer indxq, iwrem, iqptr, tlvls; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zlaed7_(integer *, integer *, + integer *, integer *, integer *, integer *, doublereal *, + doublecomplex *, integer *, doublereal *, integer *, doublereal *, + integer *, integer *, integer *, integer *, integer *, + doublereal *, doublecomplex *, doublereal *, integer *, integer *) + ; + integer ll, iq, igivcl; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int zlacrm_(integer *, integer *, doublecomplex *, + integer *, doublereal *, integer *, doublecomplex *, integer *, + doublereal *); + integer igivnm, submat, curprb, subpbs, igivpt; + extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *); + integer curlvl, matsiz, iprmpt, smlsiz, lgn, msd2, smm1, spm1, spm2; + + +/* -- 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 */ + + +/* ===================================================================== */ + +/* Warning: N could be as big as QSIZ! */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + qstore_dim1 = *ldqs; + qstore_offset = 1 + qstore_dim1 * 1; + qstore -= qstore_offset; + --rwork; + --iwork; + + /* Function Body */ + *info = 0; + +/* IF( ICOMPQ .LT. 0 .OR. ICOMPQ .GT. 2 ) THEN */ +/* INFO = -1 */ +/* ELSE IF( ( ICOMPQ .EQ. 1 ) .AND. ( QSIZ .LT. MAX( 0, N ) ) ) */ +/* $ THEN */ + if (*qsiz < f2cmax(0,*n)) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldq < f2cmax(1,*n)) { + *info = -6; + } else if (*ldqs < f2cmax(1,*n)) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLAED0", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + smlsiz = ilaenv_(&c__9, "ZLAED0", " ", &c__0, &c__0, &c__0, &c__0, ( + ftnlen)6, (ftnlen)1); + +/* Determine the size and placement of the submatrices, and save in */ +/* the leading elements of IWORK. */ + + iwork[1] = *n; + subpbs = 1; + tlvls = 0; +L10: + if (iwork[subpbs] > smlsiz) { + for (j = subpbs; j >= 1; --j) { + iwork[j * 2] = (iwork[j] + 1) / 2; + iwork[(j << 1) - 1] = iwork[j] / 2; +/* L20: */ + } + ++tlvls; + subpbs <<= 1; + goto L10; + } + i__1 = subpbs; + for (j = 2; j <= i__1; ++j) { + iwork[j] += iwork[j - 1]; +/* L30: */ + } + +/* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1 */ +/* using rank-1 modifications (cuts). */ + + spm1 = subpbs - 1; + i__1 = spm1; + for (i__ = 1; i__ <= i__1; ++i__) { + submat = iwork[i__] + 1; + smm1 = submat - 1; + d__[smm1] -= (d__1 = e[smm1], abs(d__1)); + d__[submat] -= (d__1 = e[smm1], abs(d__1)); +/* L40: */ + } + + indxq = (*n << 2) + 3; + +/* Set up workspaces for eigenvalues only/accumulate new vectors */ +/* routine */ + + temp = log((doublereal) (*n)) / log(2.); + lgn = (integer) temp; + if (pow_ii(&c__2, &lgn) < *n) { + ++lgn; + } + if (pow_ii(&c__2, &lgn) < *n) { + ++lgn; + } + iprmpt = indxq + *n + 1; + iperm = iprmpt + *n * lgn; + iqptr = iperm + *n * lgn; + igivpt = iqptr + *n + 2; + igivcl = igivpt + *n * lgn; + + igivnm = 1; + iq = igivnm + (*n << 1) * lgn; +/* Computing 2nd power */ + i__1 = *n; + iwrem = iq + i__1 * i__1 + 1; +/* Initialize pointers */ + i__1 = subpbs; + for (i__ = 0; i__ <= i__1; ++i__) { + iwork[iprmpt + i__] = 1; + iwork[igivpt + i__] = 1; +/* L50: */ + } + iwork[iqptr] = 1; + +/* Solve each submatrix eigenproblem at the bottom of the divide and */ +/* conquer tree. */ + + curr = 0; + i__1 = spm1; + for (i__ = 0; i__ <= i__1; ++i__) { + if (i__ == 0) { + submat = 1; + matsiz = iwork[1]; + } else { + submat = iwork[i__] + 1; + matsiz = iwork[i__ + 1] - iwork[i__]; + } + ll = iq - 1 + iwork[iqptr + curr]; + dsteqr_("I", &matsiz, &d__[submat], &e[submat], &rwork[ll], &matsiz, & + rwork[1], info); + zlacrm_(qsiz, &matsiz, &q[submat * q_dim1 + 1], ldq, &rwork[ll], & + matsiz, &qstore[submat * qstore_dim1 + 1], ldqs, &rwork[iwrem] + ); +/* Computing 2nd power */ + i__2 = matsiz; + iwork[iqptr + curr + 1] = iwork[iqptr + curr] + i__2 * i__2; + ++curr; + if (*info > 0) { + *info = submat * (*n + 1) + submat + matsiz - 1; + return 0; + } + k = 1; + i__2 = iwork[i__ + 1]; + for (j = submat; j <= i__2; ++j) { + iwork[indxq + j] = k; + ++k; +/* L60: */ + } +/* L70: */ + } + +/* Successively merge eigensystems of adjacent submatrices */ +/* into eigensystem for the corresponding larger matrix. */ + +/* while ( SUBPBS > 1 ) */ + + curlvl = 1; +L80: + if (subpbs > 1) { + spm2 = subpbs - 2; + i__1 = spm2; + for (i__ = 0; i__ <= i__1; i__ += 2) { + if (i__ == 0) { + submat = 1; + matsiz = iwork[2]; + msd2 = iwork[1]; + curprb = 0; + } else { + submat = iwork[i__] + 1; + matsiz = iwork[i__ + 2] - iwork[i__]; + msd2 = matsiz / 2; + ++curprb; + } + +/* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2) */ +/* into an eigensystem of size MATSIZ. ZLAED7 handles the case */ +/* when the eigenvectors of a full or band Hermitian matrix (which */ +/* was reduced to tridiagonal form) are desired. */ + +/* I am free to use Q as a valuable working space until Loop 150. */ + + zlaed7_(&matsiz, &msd2, qsiz, &tlvls, &curlvl, &curprb, &d__[ + submat], &qstore[submat * qstore_dim1 + 1], ldqs, &e[ + submat + msd2 - 1], &iwork[indxq + submat], &rwork[iq], & + iwork[iqptr], &iwork[iprmpt], &iwork[iperm], &iwork[ + igivpt], &iwork[igivcl], &rwork[igivnm], &q[submat * + q_dim1 + 1], &rwork[iwrem], &iwork[subpbs + 1], info); + if (*info > 0) { + *info = submat * (*n + 1) + submat + matsiz - 1; + return 0; + } + iwork[i__ / 2 + 1] = iwork[i__ + 2]; +/* L90: */ + } + subpbs /= 2; + ++curlvl; + goto L80; + } + +/* end while */ + +/* Re-merge the eigenvalues/vectors which were deflated at the final */ +/* merge step. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + j = iwork[indxq + i__]; + rwork[i__] = d__[j]; + zcopy_(qsiz, &qstore[j * qstore_dim1 + 1], &c__1, &q[i__ * q_dim1 + 1] + , &c__1); +/* L100: */ + } + dcopy_(n, &rwork[1], &c__1, &d__[1], &c__1); + + return 0; + +/* End of ZLAED0 */ + +} /* zlaed0_ */ + diff --git a/lapack-netlib/SRC/zlaed7.c b/lapack-netlib/SRC/zlaed7.c new file mode 100644 index 000000000..8d99249e8 --- /dev/null +++ b/lapack-netlib/SRC/zlaed7.c @@ -0,0 +1,808 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAED7 used by sstedc. Computes the updated eigensystem of a diagonal matrix after modification + by a rank-one symmetric matrix. Used when the original matrix is dense. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAED7 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAED7( N, CUTPNT, QSIZ, TLVLS, CURLVL, CURPBM, D, Q, */ +/* LDQ, RHO, INDXQ, QSTORE, QPTR, PRMPTR, PERM, */ +/* GIVPTR, GIVCOL, GIVNUM, WORK, RWORK, IWORK, */ +/* INFO ) */ + +/* INTEGER CURLVL, CURPBM, CUTPNT, INFO, LDQ, N, QSIZ, */ +/* $ TLVLS */ +/* DOUBLE PRECISION RHO */ +/* INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ), */ +/* $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * ) */ +/* DOUBLE PRECISION D( * ), GIVNUM( 2, * ), QSTORE( * ), RWORK( * ) */ +/* COMPLEX*16 Q( LDQ, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAED7 computes the updated eigensystem of a diagonal */ +/* > matrix after modification by a rank-one symmetric matrix. This */ +/* > routine is used only for the eigenproblem which requires all */ +/* > eigenvalues and optionally eigenvectors of a dense or banded */ +/* > Hermitian matrix that has been reduced to tridiagonal form. */ +/* > */ +/* > T = Q(in) ( D(in) + RHO * Z*Z**H ) Q**H(in) = Q(out) * D(out) * Q**H(out) */ +/* > */ +/* > where Z = Q**Hu, u is a vector of length N with ones in the */ +/* > CUTPNT and CUTPNT + 1 th elements and zeros elsewhere. */ +/* > */ +/* > The eigenvectors of the original matrix are stored in Q, and the */ +/* > eigenvalues are in D. The algorithm consists of three stages: */ +/* > */ +/* > The first stage consists of deflating the size of the problem */ +/* > when there are multiple eigenvalues or if there is a zero in */ +/* > the Z vector. For each such occurrence the dimension of the */ +/* > secular equation problem is reduced by one. This stage is */ +/* > performed by the routine DLAED2. */ +/* > */ +/* > The second stage consists of calculating the updated */ +/* > eigenvalues. This is done by finding the roots of the secular */ +/* > equation via the routine DLAED4 (as called by SLAED3). */ +/* > This routine also calculates the eigenvectors of the current */ +/* > problem. */ +/* > */ +/* > The final stage consists of computing the updated eigenvectors */ +/* > directly using the updated eigenvalues. The eigenvectors for */ +/* > the current problem are multiplied with the eigenvectors from */ +/* > the overall problem. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The dimension of the symmetric tridiagonal matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CUTPNT */ +/* > \verbatim */ +/* > CUTPNT is INTEGER */ +/* > Contains the location of the last eigenvalue in the leading */ +/* > sub-matrix. f2cmin(1,N) <= CUTPNT <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] QSIZ */ +/* > \verbatim */ +/* > QSIZ is INTEGER */ +/* > The dimension of the unitary matrix used to reduce */ +/* > the full matrix to tridiagonal form. QSIZ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TLVLS */ +/* > \verbatim */ +/* > TLVLS is INTEGER */ +/* > The total number of merging levels in the overall divide and */ +/* > conquer tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CURLVL */ +/* > \verbatim */ +/* > CURLVL is INTEGER */ +/* > The current level in the overall merge routine, */ +/* > 0 <= curlvl <= tlvls. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CURPBM */ +/* > \verbatim */ +/* > CURPBM is INTEGER */ +/* > The current problem in the current level in the overall */ +/* > merge routine (counting from upper left to lower right). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, the eigenvalues of the rank-1-perturbed matrix. */ +/* > On exit, the eigenvalues of the repaired matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is COMPLEX*16 array, dimension (LDQ,N) */ +/* > On entry, the eigenvectors of the rank-1-perturbed matrix. */ +/* > On exit, the eigenvectors of the repaired tridiagonal matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RHO */ +/* > \verbatim */ +/* > RHO is DOUBLE PRECISION */ +/* > Contains the subdiagonal element used to create the rank-1 */ +/* > modification. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INDXQ */ +/* > \verbatim */ +/* > INDXQ is INTEGER array, dimension (N) */ +/* > This contains the permutation which will reintegrate the */ +/* > subproblem just solved back into sorted order, */ +/* > ie. D( INDXQ( I = 1, N ) ) will be in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (4*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, */ +/* > dimension (3*N+2*QSIZ*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (QSIZ*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] QSTORE */ +/* > \verbatim */ +/* > QSTORE is DOUBLE PRECISION array, dimension (N**2+1) */ +/* > Stores eigenvectors of submatrices encountered during */ +/* > divide and conquer, packed together. QPTR points to */ +/* > beginning of the submatrices. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] QPTR */ +/* > \verbatim */ +/* > QPTR is INTEGER array, dimension (N+2) */ +/* > List of indices pointing to beginning of submatrices stored */ +/* > in QSTORE. The submatrices are numbered starting at the */ +/* > bottom left of the divide and conquer tree, from left to */ +/* > right and bottom to top. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PRMPTR */ +/* > \verbatim */ +/* > PRMPTR is INTEGER array, dimension (N lg N) */ +/* > Contains a list of pointers which indicate where in PERM a */ +/* > level's permutation is stored. PRMPTR(i+1) - PRMPTR(i) */ +/* > indicates the size of the permutation and also the size of */ +/* > the full, non-deflated problem. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PERM */ +/* > \verbatim */ +/* > PERM is INTEGER array, dimension (N lg N) */ +/* > Contains the permutations (from deflation and sorting) to be */ +/* > applied to each eigenblock. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GIVPTR */ +/* > \verbatim */ +/* > GIVPTR is INTEGER array, dimension (N lg N) */ +/* > Contains a list of pointers which indicate where in GIVCOL a */ +/* > level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i) */ +/* > indicates the number of Givens rotations. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GIVCOL */ +/* > \verbatim */ +/* > GIVCOL is INTEGER array, dimension (2, N lg N) */ +/* > Each pair of numbers indicates a pair of columns to take place */ +/* > in a Givens rotation. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GIVNUM */ +/* > \verbatim */ +/* > GIVNUM is DOUBLE PRECISION array, dimension (2, N lg N) */ +/* > Each number indicates the S value to be used in the */ +/* > corresponding Givens rotation. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: if INFO = 1, an eigenvalue did not converge */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16OTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zlaed7_(integer *n, integer *cutpnt, integer *qsiz, + integer *tlvls, integer *curlvl, integer *curpbm, doublereal *d__, + doublecomplex *q, integer *ldq, doublereal *rho, integer *indxq, + doublereal *qstore, integer *qptr, integer *prmptr, integer *perm, + integer *givptr, integer *givcol, doublereal *givnum, doublecomplex * + work, doublereal *rwork, integer *iwork, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, i__1, i__2; + + /* Local variables */ + integer indx, curr, i__, k, indxc, indxp, n1, n2; + extern /* Subroutine */ int dlaed9_(integer *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *, integer *), + zlaed8_(integer *, integer *, integer *, doublecomplex *, integer + *, doublereal *, doublereal *, integer *, doublereal *, + doublereal *, doublecomplex *, integer *, doublereal *, integer *, + integer *, integer *, integer *, integer *, integer *, + doublereal *, integer *), dlaeda_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + integer *); + integer idlmda, iq, iw, iz; + extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, + integer *, integer *, integer *), xerbla_(char *, integer *, ftnlen), zlacrm_(integer *, integer *, doublecomplex *, integer *, + doublereal *, integer *, doublecomplex *, integer *, doublereal * + ); + integer coltyp, ptr; + + +/* -- 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 */ + --d__; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --indxq; + --qstore; + --qptr; + --prmptr; + --perm; + --givptr; + givcol -= 3; + givnum -= 3; + --work; + --rwork; + --iwork; + + /* Function Body */ + *info = 0; + +/* IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN */ +/* INFO = -1 */ +/* ELSE IF( N.LT.0 ) THEN */ + if (*n < 0) { + *info = -1; + } else if (f2cmin(1,*n) > *cutpnt || *n < *cutpnt) { + *info = -2; + } else if (*qsiz < *n) { + *info = -3; + } else if (*ldq < f2cmax(1,*n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLAED7", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* The following values are for bookkeeping purposes only. They are */ +/* integer pointers which indicate the portion of the workspace */ +/* used by a particular array in DLAED2 and SLAED3. */ + + iz = 1; + idlmda = iz + *n; + iw = idlmda + *n; + iq = iw + *n; + + indx = 1; + indxc = indx + *n; + coltyp = indxc + *n; + indxp = coltyp + *n; + +/* Form the z-vector which consists of the last row of Q_1 and the */ +/* first row of Q_2. */ + + ptr = pow_ii(&c__2, tlvls) + 1; + i__1 = *curlvl - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *tlvls - i__; + ptr += pow_ii(&c__2, &i__2); +/* L10: */ + } + curr = ptr + *curpbm; + dlaeda_(n, tlvls, curlvl, curpbm, &prmptr[1], &perm[1], &givptr[1], & + givcol[3], &givnum[3], &qstore[1], &qptr[1], &rwork[iz], &rwork[ + iz + *n], info); + +/* When solving the final problem, we no longer need the stored data, */ +/* so we will overwrite the data from this level onto the previously */ +/* used storage space. */ + + if (*curlvl == *tlvls) { + qptr[curr] = 1; + prmptr[curr] = 1; + givptr[curr] = 1; + } + +/* Sort and Deflate eigenvalues. */ + + zlaed8_(&k, n, qsiz, &q[q_offset], ldq, &d__[1], rho, cutpnt, &rwork[iz], + &rwork[idlmda], &work[1], qsiz, &rwork[iw], &iwork[indxp], &iwork[ + indx], &indxq[1], &perm[prmptr[curr]], &givptr[curr + 1], &givcol[ + (givptr[curr] << 1) + 1], &givnum[(givptr[curr] << 1) + 1], info); + prmptr[curr + 1] = prmptr[curr] + *n; + givptr[curr + 1] += givptr[curr]; + +/* Solve Secular Equation. */ + + if (k != 0) { + dlaed9_(&k, &c__1, &k, n, &d__[1], &rwork[iq], &k, rho, &rwork[idlmda] + , &rwork[iw], &qstore[qptr[curr]], &k, info); + zlacrm_(qsiz, &k, &work[1], qsiz, &qstore[qptr[curr]], &k, &q[ + q_offset], ldq, &rwork[iq]); +/* Computing 2nd power */ + i__1 = k; + qptr[curr + 1] = qptr[curr] + i__1 * i__1; + if (*info != 0) { + return 0; + } + +/* Prepare the INDXQ sorting premutation. */ + + n1 = k; + n2 = *n - k; + dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]); + } else { + qptr[curr + 1] = qptr[curr]; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + indxq[i__] = i__; +/* L20: */ + } + } + + return 0; + +/* End of ZLAED7 */ + +} /* zlaed7_ */ + diff --git a/lapack-netlib/SRC/zlaed8.c b/lapack-netlib/SRC/zlaed8.c new file mode 100644 index 000000000..eb2e32e04 --- /dev/null +++ b/lapack-netlib/SRC/zlaed8.c @@ -0,0 +1,918 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAED8 used by sstedc. Merges eigenvalues and deflates secular equation. Used when the original + matrix is dense. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAED8 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAED8( K, N, QSIZ, Q, LDQ, D, RHO, CUTPNT, Z, DLAMDA, */ +/* Q2, LDQ2, W, INDXP, INDX, INDXQ, PERM, GIVPTR, */ +/* GIVCOL, GIVNUM, INFO ) */ + +/* INTEGER CUTPNT, GIVPTR, INFO, K, LDQ, LDQ2, N, QSIZ */ +/* DOUBLE PRECISION RHO */ +/* INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ), */ +/* $ INDXQ( * ), PERM( * ) */ +/* DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ), W( * ), */ +/* $ Z( * ) */ +/* COMPLEX*16 Q( LDQ, * ), Q2( LDQ2, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAED8 merges the two sets of eigenvalues together into a single */ +/* > sorted set. Then it tries to deflate the size of the problem. */ +/* > There are two ways in which deflation can occur: when two or more */ +/* > eigenvalues are close together or if there is a tiny element in the */ +/* > Z vector. For each such occurrence the order of the related secular */ +/* > equation problem is reduced by one. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[out] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > Contains the number of non-deflated eigenvalues. */ +/* > This is the order of the related secular equation. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The dimension of the symmetric tridiagonal matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] QSIZ */ +/* > \verbatim */ +/* > QSIZ is INTEGER */ +/* > The dimension of the unitary matrix used to reduce */ +/* > the dense or band matrix to tridiagonal form. */ +/* > QSIZ >= N if ICOMPQ = 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is COMPLEX*16 array, dimension (LDQ,N) */ +/* > On entry, Q contains the eigenvectors of the partially solved */ +/* > system which has been previously updated in matrix */ +/* > multiplies with other partially solved eigensystems. */ +/* > On exit, Q contains the trailing (N-K) updated eigenvectors */ +/* > (those which were deflated) in its last N-K columns. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax( 1, N ). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, D contains the eigenvalues of the two submatrices to */ +/* > be combined. On exit, D contains the trailing (N-K) updated */ +/* > eigenvalues (those which were deflated) sorted into increasing */ +/* > order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] RHO */ +/* > \verbatim */ +/* > RHO is DOUBLE PRECISION */ +/* > Contains the off diagonal element associated with the rank-1 */ +/* > cut which originally split the two submatrices which are now */ +/* > being recombined. RHO is modified during the computation to */ +/* > the value required by DLAED3. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CUTPNT */ +/* > \verbatim */ +/* > CUTPNT is INTEGER */ +/* > Contains the location of the last eigenvalue in the leading */ +/* > sub-matrix. MIN(1,N) <= CUTPNT <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION array, dimension (N) */ +/* > On input this vector contains the updating vector (the last */ +/* > row of the first sub-eigenvector matrix and the first row of */ +/* > the second sub-eigenvector matrix). The contents of Z are */ +/* > destroyed during the updating process. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DLAMDA */ +/* > \verbatim */ +/* > DLAMDA is DOUBLE PRECISION array, dimension (N) */ +/* > Contains a copy of the first K eigenvalues which will be used */ +/* > by DLAED3 to form the secular equation. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q2 */ +/* > \verbatim */ +/* > Q2 is COMPLEX*16 array, dimension (LDQ2,N) */ +/* > If ICOMPQ = 0, Q2 is not referenced. Otherwise, */ +/* > Contains a copy of the first K eigenvectors which will be used */ +/* > by DLAED7 in a matrix multiply (DGEMM) to update the new */ +/* > eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ2 */ +/* > \verbatim */ +/* > LDQ2 is INTEGER */ +/* > The leading dimension of the array Q2. LDQ2 >= f2cmax( 1, N ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is DOUBLE PRECISION array, dimension (N) */ +/* > This will hold the first k values of the final */ +/* > deflation-altered z-vector and will be passed to DLAED3. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INDXP */ +/* > \verbatim */ +/* > INDXP is INTEGER array, dimension (N) */ +/* > This will contain the permutation used to place deflated */ +/* > values of D at the end of the array. On output INDXP(1:K) */ +/* > points to the nondeflated D-values and INDXP(K+1:N) */ +/* > points to the deflated eigenvalues. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INDX */ +/* > \verbatim */ +/* > INDX is INTEGER array, dimension (N) */ +/* > This will contain the permutation used to sort the contents of */ +/* > D into ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INDXQ */ +/* > \verbatim */ +/* > INDXQ is INTEGER array, dimension (N) */ +/* > This contains the permutation which separately sorts the two */ +/* > sub-problems in D into ascending order. Note that elements in */ +/* > the second half of this permutation must first have CUTPNT */ +/* > added to their values in order to be accurate. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PERM */ +/* > \verbatim */ +/* > PERM is INTEGER array, dimension (N) */ +/* > Contains the permutations (from deflation and sorting) to be */ +/* > applied to each eigenblock. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] GIVPTR */ +/* > \verbatim */ +/* > GIVPTR is INTEGER */ +/* > Contains the number of Givens rotations which took place in */ +/* > this subproblem. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] GIVCOL */ +/* > \verbatim */ +/* > GIVCOL is INTEGER array, dimension (2, N) */ +/* > Each pair of numbers indicates a pair of columns to take place */ +/* > in a Givens rotation. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] GIVNUM */ +/* > \verbatim */ +/* > GIVNUM is DOUBLE PRECISION array, dimension (2, N) */ +/* > Each number indicates the S value to be used in the */ +/* > corresponding Givens rotation. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zlaed8_(integer *k, integer *n, integer *qsiz, + doublecomplex *q, integer *ldq, doublereal *d__, doublereal *rho, + integer *cutpnt, doublereal *z__, doublereal *dlamda, doublecomplex * + q2, integer *ldq2, doublereal *w, integer *indxp, integer *indx, + integer *indxq, integer *perm, integer *givptr, integer *givcol, + doublereal *givnum, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, q2_dim1, q2_offset, i__1; + doublereal d__1; + + /* Local variables */ + integer jlam, imax, jmax; + doublereal c__; + integer i__, j; + doublereal s, t; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dcopy_(integer *, doublereal *, integer *, doublereal + *, integer *); + integer k2, n1, n2; + extern /* Subroutine */ int zdrot_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublereal *, doublereal *), zcopy_( + integer *, doublecomplex *, integer *, doublecomplex *, integer *) + ; + extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *); + integer jp; + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ int dlamrg_(integer *, integer *, doublereal *, + integer *, integer *, integer *), xerbla_(char *, integer *, ftnlen), zlacpy_(char *, integer *, integer *, doublecomplex *, + integer *, doublecomplex *, integer *); + integer n1p1; + doublereal eps, tau, tol; + + +/* -- 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 */ + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --d__; + --z__; + --dlamda; + q2_dim1 = *ldq2; + q2_offset = 1 + q2_dim1 * 1; + q2 -= q2_offset; + --w; + --indxp; + --indx; + --indxq; + --perm; + givcol -= 3; + givnum -= 3; + + /* Function Body */ + *info = 0; + + if (*n < 0) { + *info = -2; + } else if (*qsiz < *n) { + *info = -3; + } else if (*ldq < f2cmax(1,*n)) { + *info = -5; + } else if (*cutpnt < f2cmin(1,*n) || *cutpnt > *n) { + *info = -8; + } else if (*ldq2 < f2cmax(1,*n)) { + *info = -12; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLAED8", &i__1, (ftnlen)6); + return 0; + } + +/* Need to initialize GIVPTR to O here in case of quick exit */ +/* to prevent an unspecified code behavior (usually sigfault) */ +/* when IWORK array on entry to *stedc is not zeroed */ +/* (or at least some IWORK entries which used in *laed7 for GIVPTR). */ + + *givptr = 0; + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + n1 = *cutpnt; + n2 = *n - n1; + n1p1 = n1 + 1; + + if (*rho < 0.) { + dscal_(&n2, &c_b3, &z__[n1p1], &c__1); + } + +/* Normalize z so that norm(z) = 1 */ + + t = 1. / sqrt(2.); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + indx[j] = j; +/* L10: */ + } + dscal_(n, &t, &z__[1], &c__1); + *rho = (d__1 = *rho * 2., abs(d__1)); + +/* Sort the eigenvalues into increasing order */ + + i__1 = *n; + for (i__ = *cutpnt + 1; i__ <= i__1; ++i__) { + indxq[i__] += *cutpnt; +/* L20: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dlamda[i__] = d__[indxq[i__]]; + w[i__] = z__[indxq[i__]]; +/* L30: */ + } + i__ = 1; + j = *cutpnt + 1; + dlamrg_(&n1, &n2, &dlamda[1], &c__1, &c__1, &indx[1]); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = dlamda[indx[i__]]; + z__[i__] = w[indx[i__]]; +/* L40: */ + } + +/* Calculate the allowable deflation tolerance */ + + imax = idamax_(n, &z__[1], &c__1); + jmax = idamax_(n, &d__[1], &c__1); + eps = dlamch_("Epsilon"); + tol = eps * 8. * (d__1 = d__[jmax], abs(d__1)); + +/* If the rank-1 modifier is small enough, no more needs to be done */ +/* -- except to reorganize Q so that its columns correspond with the */ +/* elements in D. */ + + if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) { + *k = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + perm[j] = indxq[indx[j]]; + zcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1] + , &c__1); +/* L50: */ + } + zlacpy_("A", qsiz, n, &q2[q2_dim1 + 1], ldq2, &q[q_dim1 + 1], ldq); + return 0; + } + +/* If there are multiple eigenvalues then the problem deflates. Here */ +/* the number of equal eigenvalues are found. As each equal */ +/* eigenvalue is found, an elementary reflector is computed to rotate */ +/* the corresponding eigensubspace so that the corresponding */ +/* components of Z are zero in this new basis. */ + + *k = 0; + k2 = *n + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) { + +/* Deflate due to small z component. */ + + --k2; + indxp[k2] = j; + if (j == *n) { + goto L100; + } + } else { + jlam = j; + goto L70; + } +/* L60: */ + } +L70: + ++j; + if (j > *n) { + goto L90; + } + if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) { + +/* Deflate due to small z component. */ + + --k2; + indxp[k2] = j; + } else { + +/* Check if eigenvalues are close enough to allow deflation. */ + + s = z__[jlam]; + c__ = z__[j]; + +/* Find sqrt(a**2+b**2) without overflow or */ +/* destructive underflow. */ + + tau = dlapy2_(&c__, &s); + t = d__[j] - d__[jlam]; + c__ /= tau; + s = -s / tau; + if ((d__1 = t * c__ * s, abs(d__1)) <= tol) { + +/* Deflation is possible. */ + + z__[j] = tau; + z__[jlam] = 0.; + +/* Record the appropriate Givens rotation */ + + ++(*givptr); + givcol[(*givptr << 1) + 1] = indxq[indx[jlam]]; + givcol[(*givptr << 1) + 2] = indxq[indx[j]]; + givnum[(*givptr << 1) + 1] = c__; + givnum[(*givptr << 1) + 2] = s; + zdrot_(qsiz, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[indxq[ + indx[j]] * q_dim1 + 1], &c__1, &c__, &s); + t = d__[jlam] * c__ * c__ + d__[j] * s * s; + d__[j] = d__[jlam] * s * s + d__[j] * c__ * c__; + d__[jlam] = t; + --k2; + i__ = 1; +L80: + if (k2 + i__ <= *n) { + if (d__[jlam] < d__[indxp[k2 + i__]]) { + indxp[k2 + i__ - 1] = indxp[k2 + i__]; + indxp[k2 + i__] = jlam; + ++i__; + goto L80; + } else { + indxp[k2 + i__ - 1] = jlam; + } + } else { + indxp[k2 + i__ - 1] = jlam; + } + jlam = j; + } else { + ++(*k); + w[*k] = z__[jlam]; + dlamda[*k] = d__[jlam]; + indxp[*k] = jlam; + jlam = j; + } + } + goto L70; +L90: + +/* Record the last eigenvalue. */ + + ++(*k); + w[*k] = z__[jlam]; + dlamda[*k] = d__[jlam]; + indxp[*k] = jlam; + +L100: + +/* Sort the eigenvalues and corresponding eigenvectors into DLAMDA */ +/* and Q2 respectively. The eigenvalues/vectors which were not */ +/* deflated go into the first K slots of DLAMDA and Q2 respectively, */ +/* while those which were deflated go into the last N - K slots. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jp = indxp[j]; + dlamda[j] = d__[jp]; + perm[j] = indxq[indx[jp]]; + zcopy_(qsiz, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1], & + c__1); +/* L110: */ + } + +/* The deflated eigenvalues and their corresponding vectors go back */ +/* into the last N - K slots of D and Q respectively. */ + + if (*k < *n) { + i__1 = *n - *k; + dcopy_(&i__1, &dlamda[*k + 1], &c__1, &d__[*k + 1], &c__1); + i__1 = *n - *k; + zlacpy_("A", qsiz, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(*k + + 1) * q_dim1 + 1], ldq); + } + + return 0; + +/* End of ZLAED8 */ + +} /* zlaed8_ */ + diff --git a/lapack-netlib/SRC/zlaein.c b/lapack-netlib/SRC/zlaein.c new file mode 100644 index 000000000..b95ab8857 --- /dev/null +++ b/lapack-netlib/SRC/zlaein.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 +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAEIN computes a specified right or left eigenvector of an upper Hessenberg matrix by inverse +iteration. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAEIN + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAEIN( RIGHTV, NOINIT, N, H, LDH, W, V, B, LDB, RWORK, */ +/* EPS3, SMLNUM, INFO ) */ + +/* LOGICAL NOINIT, RIGHTV */ +/* INTEGER INFO, LDB, LDH, N */ +/* DOUBLE PRECISION EPS3, SMLNUM */ +/* COMPLEX*16 W */ +/* DOUBLE PRECISION RWORK( * ) */ +/* COMPLEX*16 B( LDB, * ), H( LDH, * ), V( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAEIN uses inverse iteration to find a right or left eigenvector */ +/* > corresponding to the eigenvalue W of a complex upper Hessenberg */ +/* > matrix H. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] RIGHTV */ +/* > \verbatim */ +/* > RIGHTV is LOGICAL */ +/* > = .TRUE. : compute right eigenvector; */ +/* > = .FALSE.: compute left eigenvector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NOINIT */ +/* > \verbatim */ +/* > NOINIT is LOGICAL */ +/* > = .TRUE. : no initial vector supplied in V */ +/* > = .FALSE.: initial vector supplied in V. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix H. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] H */ +/* > \verbatim */ +/* > H is COMPLEX*16 array, dimension (LDH,N) */ +/* > The upper Hessenberg matrix H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > The leading dimension of the array H. LDH >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] W */ +/* > \verbatim */ +/* > W is COMPLEX*16 */ +/* > The eigenvalue of H whose corresponding right or left */ +/* > eigenvector is to be computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] V */ +/* > \verbatim */ +/* > V is COMPLEX*16 array, dimension (N) */ +/* > On entry, if NOINIT = .FALSE., V must contain a starting */ +/* > vector for inverse iteration; otherwise V need not be set. */ +/* > On exit, V contains the computed eigenvector, normalized so */ +/* > that the component of largest magnitude has magnitude 1; here */ +/* > the magnitude of a complex number (x,y) is taken to be */ +/* > |x| + |y|. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,N) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] EPS3 */ +/* > \verbatim */ +/* > EPS3 is DOUBLE PRECISION */ +/* > A small machine-dependent value which is used to perturb */ +/* > close eigenvalues, and to replace zero pivots. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SMLNUM */ +/* > \verbatim */ +/* > SMLNUM is DOUBLE PRECISION */ +/* > A machine-dependent value close to the underflow threshold. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > = 1: inverse iteration did not converge; V is set to the */ +/* > last iterate. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlaein_(logical *rightv, logical *noinit, integer *n, + doublecomplex *h__, integer *ldh, doublecomplex *w, doublecomplex *v, + doublecomplex *b, integer *ldb, doublereal *rwork, doublereal *eps3, + doublereal *smlnum, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, h_dim1, h_offset, i__1, i__2, i__3, i__4, i__5; + doublereal d__1, d__2, d__3, d__4; + doublecomplex z__1, z__2; + + /* Local variables */ + integer ierr; + doublecomplex temp; + integer i__, j; + doublereal scale; + doublecomplex x; + char trans[1]; + doublereal rtemp, rootn, vnorm; + extern doublereal dznrm2_(integer *, doublecomplex *, integer *); + doublecomplex ei, ej; + extern /* Subroutine */ int zdscal_(integer *, doublereal *, + doublecomplex *, integer *); + extern integer izamax_(integer *, doublecomplex *, integer *); + extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *, + doublecomplex *); + char normin[1]; + extern doublereal dzasum_(integer *, doublecomplex *, integer *); + doublereal nrmsml; + extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublereal *, doublereal *, integer *); + doublereal growto; + integer its; + + +/* -- 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 */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + --v; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --rwork; + + /* Function Body */ + *info = 0; + +/* GROWTO is the threshold used in the acceptance test for an */ +/* eigenvector. */ + + rootn = sqrt((doublereal) (*n)); + growto = .1 / rootn; +/* Computing MAX */ + d__1 = 1., d__2 = *eps3 * rootn; + nrmsml = f2cmax(d__1,d__2) * *smlnum; + +/* Form B = H - W*I (except that the subdiagonal elements are not */ +/* stored). */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * h_dim1; + b[i__3].r = h__[i__4].r, b[i__3].i = h__[i__4].i; +/* L10: */ + } + i__2 = j + j * b_dim1; + i__3 = j + j * h_dim1; + z__1.r = h__[i__3].r - w->r, z__1.i = h__[i__3].i - w->i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; +/* L20: */ + } + + if (*noinit) { + +/* Initialize V. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + v[i__2].r = *eps3, v[i__2].i = 0.; +/* L30: */ + } + } else { + +/* Scale supplied initial vector. */ + + vnorm = dznrm2_(n, &v[1], &c__1); + d__1 = *eps3 * rootn / f2cmax(vnorm,nrmsml); + zdscal_(n, &d__1, &v[1], &c__1); + } + + if (*rightv) { + +/* LU decomposition with partial pivoting of B, replacing zero */ +/* pivots by EPS3. */ + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + 1 + i__ * h_dim1; + ei.r = h__[i__2].r, ei.i = h__[i__2].i; + i__2 = i__ + i__ * b_dim1; + if ((d__1 = b[i__2].r, abs(d__1)) + (d__2 = d_imag(&b[i__ + i__ * + b_dim1]), abs(d__2)) < (d__3 = ei.r, abs(d__3)) + (d__4 = + d_imag(&ei), abs(d__4))) { + +/* Interchange rows and eliminate. */ + + zladiv_(&z__1, &b[i__ + i__ * b_dim1], &ei); + x.r = z__1.r, x.i = z__1.i; + i__2 = i__ + i__ * b_dim1; + b[i__2].r = ei.r, b[i__2].i = ei.i; + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = i__ + 1 + j * b_dim1; + temp.r = b[i__3].r, temp.i = b[i__3].i; + i__3 = i__ + 1 + j * b_dim1; + i__4 = i__ + j * b_dim1; + z__2.r = x.r * temp.r - x.i * temp.i, z__2.i = x.r * + temp.i + x.i * temp.r; + z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4].i - z__2.i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; + i__3 = i__ + j * b_dim1; + b[i__3].r = temp.r, b[i__3].i = temp.i; +/* L40: */ + } + } else { + +/* Eliminate without interchange. */ + + i__2 = i__ + i__ * b_dim1; + if (b[i__2].r == 0. && b[i__2].i == 0.) { + i__3 = i__ + i__ * b_dim1; + b[i__3].r = *eps3, b[i__3].i = 0.; + } + zladiv_(&z__1, &ei, &b[i__ + i__ * b_dim1]); + x.r = z__1.r, x.i = z__1.i; + if (x.r != 0. || x.i != 0.) { + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = i__ + 1 + j * b_dim1; + i__4 = i__ + 1 + j * b_dim1; + i__5 = i__ + j * b_dim1; + z__2.r = x.r * b[i__5].r - x.i * b[i__5].i, z__2.i = + x.r * b[i__5].i + x.i * b[i__5].r; + z__1.r = b[i__4].r - z__2.r, z__1.i = b[i__4].i - + z__2.i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L50: */ + } + } + } +/* L60: */ + } + i__1 = *n + *n * b_dim1; + if (b[i__1].r == 0. && b[i__1].i == 0.) { + i__2 = *n + *n * b_dim1; + b[i__2].r = *eps3, b[i__2].i = 0.; + } + + *(unsigned char *)trans = 'N'; + + } else { + +/* UL decomposition with partial pivoting of B, replacing zero */ +/* pivots by EPS3. */ + + for (j = *n; j >= 2; --j) { + i__1 = j + (j - 1) * h_dim1; + ej.r = h__[i__1].r, ej.i = h__[i__1].i; + i__1 = j + j * b_dim1; + if ((d__1 = b[i__1].r, abs(d__1)) + (d__2 = d_imag(&b[j + j * + b_dim1]), abs(d__2)) < (d__3 = ej.r, abs(d__3)) + (d__4 = + d_imag(&ej), abs(d__4))) { + +/* Interchange columns and eliminate. */ + + zladiv_(&z__1, &b[j + j * b_dim1], &ej); + x.r = z__1.r, x.i = z__1.i; + i__1 = j + j * b_dim1; + b[i__1].r = ej.r, b[i__1].i = ej.i; + i__1 = j - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + (j - 1) * b_dim1; + temp.r = b[i__2].r, temp.i = b[i__2].i; + i__2 = i__ + (j - 1) * b_dim1; + i__3 = i__ + j * b_dim1; + z__2.r = x.r * temp.r - x.i * temp.i, z__2.i = x.r * + temp.i + x.i * temp.r; + z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i - z__2.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = i__ + j * b_dim1; + b[i__2].r = temp.r, b[i__2].i = temp.i; +/* L70: */ + } + } else { + +/* Eliminate without interchange. */ + + i__1 = j + j * b_dim1; + if (b[i__1].r == 0. && b[i__1].i == 0.) { + i__2 = j + j * b_dim1; + b[i__2].r = *eps3, b[i__2].i = 0.; + } + zladiv_(&z__1, &ej, &b[j + j * b_dim1]); + x.r = z__1.r, x.i = z__1.i; + if (x.r != 0. || x.i != 0.) { + i__1 = j - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + (j - 1) * b_dim1; + i__3 = i__ + (j - 1) * b_dim1; + i__4 = i__ + j * b_dim1; + z__2.r = x.r * b[i__4].r - x.i * b[i__4].i, z__2.i = + x.r * b[i__4].i + x.i * b[i__4].r; + z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i - + z__2.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; +/* L80: */ + } + } + } +/* L90: */ + } + i__1 = b_dim1 + 1; + if (b[i__1].r == 0. && b[i__1].i == 0.) { + i__2 = b_dim1 + 1; + b[i__2].r = *eps3, b[i__2].i = 0.; + } + + *(unsigned char *)trans = 'C'; + + } + + *(unsigned char *)normin = 'N'; + i__1 = *n; + for (its = 1; its <= i__1; ++its) { + +/* Solve U*x = scale*v for a right eigenvector */ +/* or U**H *x = scale*v for a left eigenvector, */ +/* overwriting x on v. */ + + zlatrs_("Upper", trans, "Nonunit", normin, n, &b[b_offset], ldb, &v[1] + , &scale, &rwork[1], &ierr); + *(unsigned char *)normin = 'Y'; + +/* Test for sufficient growth in the norm of v. */ + + vnorm = dzasum_(n, &v[1], &c__1); + if (vnorm >= growto * scale) { + goto L120; + } + +/* Choose new orthogonal starting vector and try again. */ + + rtemp = *eps3 / (rootn + 1.); + v[1].r = *eps3, v[1].i = 0.; + i__2 = *n; + for (i__ = 2; i__ <= i__2; ++i__) { + i__3 = i__; + v[i__3].r = rtemp, v[i__3].i = 0.; +/* L100: */ + } + i__2 = *n - its + 1; + i__3 = *n - its + 1; + d__1 = *eps3 * rootn; + z__1.r = v[i__3].r - d__1, z__1.i = v[i__3].i; + v[i__2].r = z__1.r, v[i__2].i = z__1.i; +/* L110: */ + } + +/* Failure to find eigenvector in N iterations. */ + + *info = 1; + +L120: + +/* Normalize eigenvector. */ + + i__ = izamax_(n, &v[1], &c__1); + i__1 = i__; + d__3 = 1. / ((d__1 = v[i__1].r, abs(d__1)) + (d__2 = d_imag(&v[i__]), abs( + d__2))); + zdscal_(n, &d__3, &v[1], &c__1); + + return 0; + +/* End of ZLAEIN */ + +} /* zlaein_ */ + diff --git a/lapack-netlib/SRC/zlaesy.c b/lapack-netlib/SRC/zlaesy.c new file mode 100644 index 000000000..3af9eb9a7 --- /dev/null +++ b/lapack-netlib/SRC/zlaesy.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 +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAESY computes the eigenvalues and eigenvectors of a 2-by-2 complex symmetric matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAESY + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAESY( A, B, C, RT1, RT2, EVSCAL, CS1, SN1 ) */ + +/* COMPLEX*16 A, B, C, CS1, EVSCAL, RT1, RT2, SN1 */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAESY computes the eigendecomposition of a 2-by-2 symmetric matrix */ +/* > ( ( A, B );( B, C ) ) */ +/* > provided the norm of the matrix of eigenvectors is larger than */ +/* > some threshold value. */ +/* > */ +/* > RT1 is the eigenvalue of larger absolute value, and RT2 of */ +/* > smaller absolute value. If the eigenvectors are computed, then */ +/* > on return ( CS1, SN1 ) is the unit eigenvector for RT1, hence */ +/* > */ +/* > [ CS1 SN1 ] . [ A B ] . [ CS1 -SN1 ] = [ RT1 0 ] */ +/* > [ -SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ] */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 */ +/* > The ( 1, 1 ) element of input matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 */ +/* > The ( 1, 2 ) element of input matrix. The ( 2, 1 ) element */ +/* > is also given by B, since the 2-by-2 matrix is symmetric. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is COMPLEX*16 */ +/* > The ( 2, 2 ) element of input matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RT1 */ +/* > \verbatim */ +/* > RT1 is COMPLEX*16 */ +/* > The eigenvalue of larger modulus. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RT2 */ +/* > \verbatim */ +/* > RT2 is COMPLEX*16 */ +/* > The eigenvalue of smaller modulus. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] EVSCAL */ +/* > \verbatim */ +/* > EVSCAL is COMPLEX*16 */ +/* > The complex value by which the eigenvector matrix was scaled */ +/* > to make it orthonormal. If EVSCAL is zero, the eigenvectors */ +/* > were not computed. This means one of two things: the 2-by-2 */ +/* > matrix could not be diagonalized, or the norm of the matrix */ +/* > of eigenvectors before scaling was larger than the threshold */ +/* > value THRESH (set below). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CS1 */ +/* > \verbatim */ +/* > CS1 is COMPLEX*16 */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SN1 */ +/* > \verbatim */ +/* > SN1 is COMPLEX*16 */ +/* > If EVSCAL .NE. 0, ( CS1, SN1 ) is the unit right eigenvector */ +/* > for RT1. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16SYauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlaesy_(doublecomplex *a, doublecomplex *b, + doublecomplex *c__, doublecomplex *rt1, doublecomplex *rt2, + doublecomplex *evscal, doublecomplex *cs1, doublecomplex *sn1) +{ + /* System generated locals */ + doublereal d__1, d__2; + doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7; + + /* Local variables */ + doublereal babs, tabs; + doublecomplex s, t; + doublereal z__, evnorm; + doublecomplex 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 */ + + +/* ===================================================================== */ + + + +/* Special case: The matrix is actually diagonal. */ +/* To avoid divide by zero later, we treat this case separately. */ + + if (z_abs(b) == 0.) { + rt1->r = a->r, rt1->i = a->i; + rt2->r = c__->r, rt2->i = c__->i; + if (z_abs(rt1) < z_abs(rt2)) { + tmp.r = rt1->r, tmp.i = rt1->i; + rt1->r = rt2->r, rt1->i = rt2->i; + rt2->r = tmp.r, rt2->i = tmp.i; + cs1->r = 0., cs1->i = 0.; + sn1->r = 1., sn1->i = 0.; + } else { + cs1->r = 1., cs1->i = 0.; + sn1->r = 0., sn1->i = 0.; + } + } else { + +/* Compute the eigenvalues and eigenvectors. */ +/* The characteristic equation is */ +/* lambda **2 - (A+C) lambda + (A*C - B*B) */ +/* and we solve it using the quadratic formula. */ + + z__2.r = a->r + c__->r, z__2.i = a->i + c__->i; + z__1.r = z__2.r * .5, z__1.i = z__2.i * .5; + s.r = z__1.r, s.i = z__1.i; + z__2.r = a->r - c__->r, z__2.i = a->i - c__->i; + z__1.r = z__2.r * .5, z__1.i = z__2.i * .5; + t.r = z__1.r, t.i = z__1.i; + +/* Take the square root carefully to avoid over/under flow. */ + + babs = z_abs(b); + tabs = z_abs(&t); + z__ = f2cmax(babs,tabs); + if (z__ > 0.) { + z__5.r = t.r / z__, z__5.i = t.i / z__; + pow_zi(&z__4, &z__5, &c__2); + z__7.r = b->r / z__, z__7.i = b->i / z__; + pow_zi(&z__6, &z__7, &c__2); + z__3.r = z__4.r + z__6.r, z__3.i = z__4.i + z__6.i; + z_sqrt(&z__2, &z__3); + z__1.r = z__ * z__2.r, z__1.i = z__ * z__2.i; + t.r = z__1.r, t.i = z__1.i; + } + +/* Compute the two eigenvalues. RT1 and RT2 are exchanged */ +/* if necessary so that RT1 will have the greater magnitude. */ + + z__1.r = s.r + t.r, z__1.i = s.i + t.i; + rt1->r = z__1.r, rt1->i = z__1.i; + z__1.r = s.r - t.r, z__1.i = s.i - t.i; + rt2->r = z__1.r, rt2->i = z__1.i; + if (z_abs(rt1) < z_abs(rt2)) { + tmp.r = rt1->r, tmp.i = rt1->i; + rt1->r = rt2->r, rt1->i = rt2->i; + rt2->r = tmp.r, rt2->i = tmp.i; + } + +/* Choose CS1 = 1 and SN1 to satisfy the first equation, then */ +/* scale the components of this eigenvector so that the matrix */ +/* of eigenvectors X satisfies X * X**T = I . (No scaling is */ +/* done if the norm of the eigenvalue matrix is less than THRESH.) */ + + z__2.r = rt1->r - a->r, z__2.i = rt1->i - a->i; + z_div(&z__1, &z__2, b); + sn1->r = z__1.r, sn1->i = z__1.i; + tabs = z_abs(sn1); + if (tabs > 1.) { +/* Computing 2nd power */ + d__2 = 1. / tabs; + d__1 = d__2 * d__2; + z__5.r = sn1->r / tabs, z__5.i = sn1->i / tabs; + pow_zi(&z__4, &z__5, &c__2); + z__3.r = d__1 + z__4.r, z__3.i = z__4.i; + z_sqrt(&z__2, &z__3); + z__1.r = tabs * z__2.r, z__1.i = tabs * z__2.i; + t.r = z__1.r, t.i = z__1.i; + } else { + z__3.r = sn1->r * sn1->r - sn1->i * sn1->i, z__3.i = sn1->r * + sn1->i + sn1->i * sn1->r; + z__2.r = z__3.r + 1., z__2.i = z__3.i + 0.; + z_sqrt(&z__1, &z__2); + t.r = z__1.r, t.i = z__1.i; + } + evnorm = z_abs(&t); + if (evnorm >= .1) { + z_div(&z__1, &c_b1, &t); + evscal->r = z__1.r, evscal->i = z__1.i; + cs1->r = evscal->r, cs1->i = evscal->i; + z__1.r = sn1->r * evscal->r - sn1->i * evscal->i, z__1.i = sn1->r + * evscal->i + sn1->i * evscal->r; + sn1->r = z__1.r, sn1->i = z__1.i; + } else { + evscal->r = 0., evscal->i = 0.; + } + } + return 0; + +/* End of ZLAESY */ + +} /* zlaesy_ */ + diff --git a/lapack-netlib/SRC/zlaev2.c b/lapack-netlib/SRC/zlaev2.c new file mode 100644 index 000000000..40d588f33 --- /dev/null +++ b/lapack-netlib/SRC/zlaev2.c @@ -0,0 +1,555 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAEV2 computes the eigenvalues and eigenvectors of a 2-by-2 symmetric/Hermitian matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAEV2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAEV2( A, B, C, RT1, RT2, CS1, SN1 ) */ + +/* DOUBLE PRECISION CS1, RT1, RT2 */ +/* COMPLEX*16 A, B, C, SN1 */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAEV2 computes the eigendecomposition of a 2-by-2 Hermitian matrix */ +/* > [ A B ] */ +/* > [ CONJG(B) C ]. */ +/* > On return, RT1 is the eigenvalue of larger absolute value, RT2 is the */ +/* > eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right */ +/* > eigenvector for RT1, giving the decomposition */ +/* > */ +/* > [ CS1 CONJG(SN1) ] [ A B ] [ CS1 -CONJG(SN1) ] = [ RT1 0 ] */ +/* > [-SN1 CS1 ] [ CONJG(B) C ] [ SN1 CS1 ] [ 0 RT2 ]. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 */ +/* > The (1,1) element of the 2-by-2 matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 */ +/* > The (1,2) element and the conjugate of the (2,1) element of */ +/* > the 2-by-2 matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is COMPLEX*16 */ +/* > The (2,2) element of the 2-by-2 matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RT1 */ +/* > \verbatim */ +/* > RT1 is DOUBLE PRECISION */ +/* > The eigenvalue of larger absolute value. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RT2 */ +/* > \verbatim */ +/* > RT2 is DOUBLE PRECISION */ +/* > The eigenvalue of smaller absolute value. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CS1 */ +/* > \verbatim */ +/* > CS1 is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SN1 */ +/* > \verbatim */ +/* > SN1 is COMPLEX*16 */ +/* > The vector (CS1, SN1) is a unit right eigenvector for RT1. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > RT1 is accurate to a few ulps barring over/underflow. */ +/* > */ +/* > RT2 may be inaccurate if there is massive cancellation in the */ +/* > determinant A*C-B*B; higher precision or correctly rounded or */ +/* > correctly truncated arithmetic would be needed to compute RT2 */ +/* > accurately in all cases. */ +/* > */ +/* > CS1 and SN1 are accurate to a few ulps barring over/underflow. */ +/* > */ +/* > Overflow is possible only if RT1 is within a factor of 5 of overflow. */ +/* > Underflow is harmless if the input data is 0 or exceeds */ +/* > underflow_threshold / macheps. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlaev2_(doublecomplex *a, doublecomplex *b, + doublecomplex *c__, doublereal *rt1, doublereal *rt2, doublereal *cs1, + doublecomplex *sn1) +{ + /* System generated locals */ + doublereal d__1, d__2, d__3; + doublecomplex z__1, z__2; + + /* Local variables */ + doublereal t; + doublecomplex w; + extern /* Subroutine */ int dlaev2_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + if (z_abs(b) == 0.) { + w.r = 1., w.i = 0.; + } else { + d_cnjg(&z__2, b); + d__1 = z_abs(b); + z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1; + w.r = z__1.r, w.i = z__1.i; + } + d__1 = a->r; + d__2 = z_abs(b); + d__3 = c__->r; + dlaev2_(&d__1, &d__2, &d__3, rt1, rt2, cs1, &t); + z__1.r = t * w.r, z__1.i = t * w.i; + sn1->r = z__1.r, sn1->i = z__1.i; + return 0; + +/* End of ZLAEV2 */ + +} /* zlaev2_ */ + diff --git a/lapack-netlib/SRC/zlag2c.c b/lapack-netlib/SRC/zlag2c.c new file mode 100644 index 000000000..edb095530 --- /dev/null +++ b/lapack-netlib/SRC/zlag2c.c @@ -0,0 +1,551 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAG2C converts a complex double precision matrix to a complex single precision matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAG2C + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAG2C( M, N, A, LDA, SA, LDSA, INFO ) */ + +/* INTEGER INFO, LDA, LDSA, M, N */ +/* COMPLEX SA( LDSA, * ) */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAG2C converts a COMPLEX*16 matrix, SA, to a COMPLEX matrix, A. */ +/* > */ +/* > RMAX is the overflow for the SINGLE PRECISION arithmetic */ +/* > ZLAG2C checks that all the entries of A are between -RMAX and */ +/* > RMAX. If not the conversion is aborted and a flag is raised. */ +/* > */ +/* > This is an auxiliary routine so there is no argument checking. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of lines of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the M-by-N coefficient matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SA */ +/* > \verbatim */ +/* > SA is COMPLEX array, dimension (LDSA,N) */ +/* > On exit, if INFO=0, the M-by-N coefficient matrix SA; if */ +/* > INFO>0, the content of SA is unspecified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDSA */ +/* > \verbatim */ +/* > LDSA is INTEGER */ +/* > The leading dimension of the array SA. LDSA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > = 1: an entry of the matrix A is greater than the SINGLE */ +/* > PRECISION overflow threshold, in this case, the content */ +/* > of SA in exit is unspecified. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlag2c_(integer *m, integer *n, doublecomplex *a, + integer *lda, complex *sa, integer *ldsa, integer *info) +{ + /* System generated locals */ + integer sa_dim1, sa_offset, a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + doublereal rmax; + integer i__, j; + extern real slamch_(char *); + + +/* -- 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; + sa_dim1 = *ldsa; + sa_offset = 1 + sa_dim1 * 1; + sa -= sa_offset; + + /* Function Body */ + rmax = slamch_("O"); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + if (a[i__3].r < -rmax || a[i__4].r > rmax || d_imag(&a[i__ + j * + a_dim1]) < -rmax || d_imag(&a[i__ + j * a_dim1]) > rmax) { + *info = 1; + goto L30; + } + i__3 = i__ + j * sa_dim1; + i__4 = i__ + j * a_dim1; + sa[i__3].r = a[i__4].r, sa[i__3].i = a[i__4].i; +/* L10: */ + } +/* L20: */ + } + *info = 0; +L30: + return 0; + +/* End of ZLAG2C */ + +} /* zlag2c_ */ + diff --git a/lapack-netlib/SRC/zlags2.c b/lapack-netlib/SRC/zlags2.c new file mode 100644 index 000000000..2649035e9 --- /dev/null +++ b/lapack-netlib/SRC/zlags2.c @@ -0,0 +1,916 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAGS2 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAGS2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, */ +/* SNV, CSQ, SNQ ) */ + +/* LOGICAL UPPER */ +/* DOUBLE PRECISION A1, A3, B1, B3, CSQ, CSU, CSV */ +/* COMPLEX*16 A2, B2, SNQ, SNU, SNV */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAGS2 computes 2-by-2 unitary matrices U, V and Q, such */ +/* > that if ( UPPER ) then */ +/* > */ +/* > U**H *A*Q = U**H *( A1 A2 )*Q = ( x 0 ) */ +/* > ( 0 A3 ) ( x x ) */ +/* > and */ +/* > V**H*B*Q = V**H *( B1 B2 )*Q = ( x 0 ) */ +/* > ( 0 B3 ) ( x x ) */ +/* > */ +/* > or if ( .NOT.UPPER ) then */ +/* > */ +/* > U**H *A*Q = U**H *( A1 0 )*Q = ( x x ) */ +/* > ( A2 A3 ) ( 0 x ) */ +/* > and */ +/* > V**H *B*Q = V**H *( B1 0 )*Q = ( x x ) */ +/* > ( B2 B3 ) ( 0 x ) */ +/* > where */ +/* > */ +/* > U = ( CSU SNU ), V = ( CSV SNV ), */ +/* > ( -SNU**H CSU ) ( -SNV**H CSV ) */ +/* > */ +/* > Q = ( CSQ SNQ ) */ +/* > ( -SNQ**H CSQ ) */ +/* > */ +/* > The rows of the transformed A and B are parallel. Moreover, if the */ +/* > input 2-by-2 matrix A is not zero, then the transformed (1,1) entry */ +/* > of A is not zero. If the input matrices A and B are both not zero, */ +/* > then the transformed (2,2) element of B is not zero, except when the */ +/* > first rows of input A and B are parallel and the second rows are */ +/* > zero. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPPER */ +/* > \verbatim */ +/* > UPPER is LOGICAL */ +/* > = .TRUE.: the input matrices A and B are upper triangular. */ +/* > = .FALSE.: the input matrices A and B are lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A1 */ +/* > \verbatim */ +/* > A1 is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A2 */ +/* > \verbatim */ +/* > A2 is COMPLEX*16 */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A3 */ +/* > \verbatim */ +/* > A3 is DOUBLE PRECISION */ +/* > On entry, A1, A2 and A3 are elements of the input 2-by-2 */ +/* > upper (lower) triangular matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B1 */ +/* > \verbatim */ +/* > B1 is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B2 */ +/* > \verbatim */ +/* > B2 is COMPLEX*16 */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B3 */ +/* > \verbatim */ +/* > B3 is DOUBLE PRECISION */ +/* > On entry, B1, B2 and B3 are elements of the input 2-by-2 */ +/* > upper (lower) triangular matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CSU */ +/* > \verbatim */ +/* > CSU is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SNU */ +/* > \verbatim */ +/* > SNU is COMPLEX*16 */ +/* > The desired unitary matrix U. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CSV */ +/* > \verbatim */ +/* > CSV is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SNV */ +/* > \verbatim */ +/* > SNV is COMPLEX*16 */ +/* > The desired unitary matrix V. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CSQ */ +/* > \verbatim */ +/* > CSQ is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SNQ */ +/* > \verbatim */ +/* > SNQ is COMPLEX*16 */ +/* > The desired unitary matrix Q. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlags2_(logical *upper, doublereal *a1, doublecomplex * + a2, doublereal *a3, doublereal *b1, doublecomplex *b2, doublereal *b3, + doublereal *csu, doublecomplex *snu, doublereal *csv, doublecomplex * + snv, doublereal *csq, doublecomplex *snq) +{ + /* System generated locals */ + doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8; + doublecomplex z__1, z__2, z__3, z__4, z__5; + + /* Local variables */ + doublereal aua11, aua12, aua21, aua22, avb12, avb11, avb21, avb22, ua11r, + ua22r, vb11r, vb22r, a; + doublecomplex b, c__; + doublereal d__; + doublecomplex r__, d1; + doublereal s1, s2; + extern /* Subroutine */ int dlasv2_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *); + doublereal fb, fc; + extern /* Subroutine */ int zlartg_(doublecomplex *, doublecomplex *, + doublereal *, doublecomplex *, doublecomplex *); + doublecomplex ua11, ua12, ua21, ua22, vb11, vb12, vb21, vb22; + doublereal csl, csr, snl, snr; + + +/* -- 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 */ + + +/* ===================================================================== */ + + + if (*upper) { + +/* Input matrices A and B are upper triangular matrices */ + +/* Form matrix C = A*adj(B) = ( a b ) */ +/* ( 0 d ) */ + + a = *a1 * *b3; + d__ = *a3 * *b1; + z__2.r = *b1 * a2->r, z__2.i = *b1 * a2->i; + z__3.r = *a1 * b2->r, z__3.i = *a1 * b2->i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + b.r = z__1.r, b.i = z__1.i; + fb = z_abs(&b); + +/* Transform complex 2-by-2 matrix C to real matrix by unitary */ +/* diagonal matrix diag(1,D1). */ + + d1.r = 1., d1.i = 0.; + if (fb != 0.) { + z__1.r = b.r / fb, z__1.i = b.i / fb; + d1.r = z__1.r, d1.i = z__1.i; + } + +/* The SVD of real 2 by 2 triangular C */ + +/* ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 ) */ +/* ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T ) */ + + dlasv2_(&a, &fb, &d__, &s1, &s2, &snr, &csr, &snl, &csl); + + if (abs(csl) >= abs(snl) || abs(csr) >= abs(snr)) { + +/* Compute the (1,1) and (1,2) elements of U**H *A and V**H *B, */ +/* and (1,2) element of |U|**H *|A| and |V|**H *|B|. */ + + ua11r = csl * *a1; + z__2.r = csl * a2->r, z__2.i = csl * a2->i; + z__4.r = snl * d1.r, z__4.i = snl * d1.i; + z__3.r = *a3 * z__4.r, z__3.i = *a3 * z__4.i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + ua12.r = z__1.r, ua12.i = z__1.i; + + vb11r = csr * *b1; + z__2.r = csr * b2->r, z__2.i = csr * b2->i; + z__4.r = snr * d1.r, z__4.i = snr * d1.i; + z__3.r = *b3 * z__4.r, z__3.i = *b3 * z__4.i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + vb12.r = z__1.r, vb12.i = z__1.i; + + aua12 = abs(csl) * ((d__1 = a2->r, abs(d__1)) + (d__2 = d_imag(a2) + , abs(d__2))) + abs(snl) * abs(*a3); + avb12 = abs(csr) * ((d__1 = b2->r, abs(d__1)) + (d__2 = d_imag(b2) + , abs(d__2))) + abs(snr) * abs(*b3); + +/* zero (1,2) elements of U**H *A and V**H *B */ + + if (abs(ua11r) + ((d__1 = ua12.r, abs(d__1)) + (d__2 = d_imag(& + ua12), abs(d__2))) == 0.) { + z__2.r = vb11r, z__2.i = 0.; + z__1.r = -z__2.r, z__1.i = -z__2.i; + d_cnjg(&z__3, &vb12); + zlartg_(&z__1, &z__3, csq, snq, &r__); + } else if (abs(vb11r) + ((d__1 = vb12.r, abs(d__1)) + (d__2 = + d_imag(&vb12), abs(d__2))) == 0.) { + z__2.r = ua11r, z__2.i = 0.; + z__1.r = -z__2.r, z__1.i = -z__2.i; + d_cnjg(&z__3, &ua12); + zlartg_(&z__1, &z__3, csq, snq, &r__); + } else if (aua12 / (abs(ua11r) + ((d__1 = ua12.r, abs(d__1)) + ( + d__2 = d_imag(&ua12), abs(d__2)))) <= avb12 / (abs(vb11r) + + ((d__3 = vb12.r, abs(d__3)) + (d__4 = d_imag(&vb12), + abs(d__4))))) { + z__2.r = ua11r, z__2.i = 0.; + z__1.r = -z__2.r, z__1.i = -z__2.i; + d_cnjg(&z__3, &ua12); + zlartg_(&z__1, &z__3, csq, snq, &r__); + } else { + z__2.r = vb11r, z__2.i = 0.; + z__1.r = -z__2.r, z__1.i = -z__2.i; + d_cnjg(&z__3, &vb12); + zlartg_(&z__1, &z__3, csq, snq, &r__); + } + + *csu = csl; + z__2.r = -d1.r, z__2.i = -d1.i; + z__1.r = snl * z__2.r, z__1.i = snl * z__2.i; + snu->r = z__1.r, snu->i = z__1.i; + *csv = csr; + z__2.r = -d1.r, z__2.i = -d1.i; + z__1.r = snr * z__2.r, z__1.i = snr * z__2.i; + snv->r = z__1.r, snv->i = z__1.i; + + } else { + +/* Compute the (2,1) and (2,2) elements of U**H *A and V**H *B, */ +/* and (2,2) element of |U|**H *|A| and |V|**H *|B|. */ + + d_cnjg(&z__4, &d1); + z__3.r = -z__4.r, z__3.i = -z__4.i; + z__2.r = snl * z__3.r, z__2.i = snl * z__3.i; + z__1.r = *a1 * z__2.r, z__1.i = *a1 * z__2.i; + ua21.r = z__1.r, ua21.i = z__1.i; + d_cnjg(&z__5, &d1); + z__4.r = -z__5.r, z__4.i = -z__5.i; + z__3.r = snl * z__4.r, z__3.i = snl * z__4.i; + z__2.r = z__3.r * a2->r - z__3.i * a2->i, z__2.i = z__3.r * a2->i + + z__3.i * a2->r; + d__1 = csl * *a3; + z__1.r = z__2.r + d__1, z__1.i = z__2.i; + ua22.r = z__1.r, ua22.i = z__1.i; + + d_cnjg(&z__4, &d1); + z__3.r = -z__4.r, z__3.i = -z__4.i; + z__2.r = snr * z__3.r, z__2.i = snr * z__3.i; + z__1.r = *b1 * z__2.r, z__1.i = *b1 * z__2.i; + vb21.r = z__1.r, vb21.i = z__1.i; + d_cnjg(&z__5, &d1); + z__4.r = -z__5.r, z__4.i = -z__5.i; + z__3.r = snr * z__4.r, z__3.i = snr * z__4.i; + z__2.r = z__3.r * b2->r - z__3.i * b2->i, z__2.i = z__3.r * b2->i + + z__3.i * b2->r; + d__1 = csr * *b3; + z__1.r = z__2.r + d__1, z__1.i = z__2.i; + vb22.r = z__1.r, vb22.i = z__1.i; + + aua22 = abs(snl) * ((d__1 = a2->r, abs(d__1)) + (d__2 = d_imag(a2) + , abs(d__2))) + abs(csl) * abs(*a3); + avb22 = abs(snr) * ((d__1 = b2->r, abs(d__1)) + (d__2 = d_imag(b2) + , abs(d__2))) + abs(csr) * abs(*b3); + +/* zero (2,2) elements of U**H *A and V**H *B, and then swap. */ + + if ((d__1 = ua21.r, abs(d__1)) + (d__2 = d_imag(&ua21), abs(d__2)) + + ((d__3 = ua22.r, abs(d__3)) + (d__4 = d_imag(&ua22), + abs(d__4))) == 0.) { + d_cnjg(&z__2, &vb21); + z__1.r = -z__2.r, z__1.i = -z__2.i; + d_cnjg(&z__3, &vb22); + zlartg_(&z__1, &z__3, csq, snq, &r__); + } else if ((d__1 = vb21.r, abs(d__1)) + (d__2 = d_imag(&vb21), + abs(d__2)) + z_abs(&vb22) == 0.) { + d_cnjg(&z__2, &ua21); + z__1.r = -z__2.r, z__1.i = -z__2.i; + d_cnjg(&z__3, &ua22); + zlartg_(&z__1, &z__3, csq, snq, &r__); + } else if (aua22 / ((d__1 = ua21.r, abs(d__1)) + (d__2 = d_imag(& + ua21), abs(d__2)) + ((d__3 = ua22.r, abs(d__3)) + (d__4 = + d_imag(&ua22), abs(d__4)))) <= avb22 / ((d__5 = vb21.r, + abs(d__5)) + (d__6 = d_imag(&vb21), abs(d__6)) + ((d__7 = + vb22.r, abs(d__7)) + (d__8 = d_imag(&vb22), abs(d__8))))) + { + d_cnjg(&z__2, &ua21); + z__1.r = -z__2.r, z__1.i = -z__2.i; + d_cnjg(&z__3, &ua22); + zlartg_(&z__1, &z__3, csq, snq, &r__); + } else { + d_cnjg(&z__2, &vb21); + z__1.r = -z__2.r, z__1.i = -z__2.i; + d_cnjg(&z__3, &vb22); + zlartg_(&z__1, &z__3, csq, snq, &r__); + } + + *csu = snl; + z__1.r = csl * d1.r, z__1.i = csl * d1.i; + snu->r = z__1.r, snu->i = z__1.i; + *csv = snr; + z__1.r = csr * d1.r, z__1.i = csr * d1.i; + snv->r = z__1.r, snv->i = z__1.i; + + } + + } else { + +/* Input matrices A and B are lower triangular matrices */ + +/* Form matrix C = A*adj(B) = ( a 0 ) */ +/* ( c d ) */ + + a = *a1 * *b3; + d__ = *a3 * *b1; + z__2.r = *b3 * a2->r, z__2.i = *b3 * a2->i; + z__3.r = *a3 * b2->r, z__3.i = *a3 * b2->i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + c__.r = z__1.r, c__.i = z__1.i; + fc = z_abs(&c__); + +/* Transform complex 2-by-2 matrix C to real matrix by unitary */ +/* diagonal matrix diag(d1,1). */ + + d1.r = 1., d1.i = 0.; + if (fc != 0.) { + z__1.r = c__.r / fc, z__1.i = c__.i / fc; + d1.r = z__1.r, d1.i = z__1.i; + } + +/* The SVD of real 2 by 2 triangular C */ + +/* ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 ) */ +/* ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T ) */ + + dlasv2_(&a, &fc, &d__, &s1, &s2, &snr, &csr, &snl, &csl); + + if (abs(csr) >= abs(snr) || abs(csl) >= abs(snl)) { + +/* Compute the (2,1) and (2,2) elements of U**H *A and V**H *B, */ +/* and (2,1) element of |U|**H *|A| and |V|**H *|B|. */ + + z__4.r = -d1.r, z__4.i = -d1.i; + z__3.r = snr * z__4.r, z__3.i = snr * z__4.i; + z__2.r = *a1 * z__3.r, z__2.i = *a1 * z__3.i; + z__5.r = csr * a2->r, z__5.i = csr * a2->i; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; + ua21.r = z__1.r, ua21.i = z__1.i; + ua22r = csr * *a3; + + z__4.r = -d1.r, z__4.i = -d1.i; + z__3.r = snl * z__4.r, z__3.i = snl * z__4.i; + z__2.r = *b1 * z__3.r, z__2.i = *b1 * z__3.i; + z__5.r = csl * b2->r, z__5.i = csl * b2->i; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; + vb21.r = z__1.r, vb21.i = z__1.i; + vb22r = csl * *b3; + + aua21 = abs(snr) * abs(*a1) + abs(csr) * ((d__1 = a2->r, abs(d__1) + ) + (d__2 = d_imag(a2), abs(d__2))); + avb21 = abs(snl) * abs(*b1) + abs(csl) * ((d__1 = b2->r, abs(d__1) + ) + (d__2 = d_imag(b2), abs(d__2))); + +/* zero (2,1) elements of U**H *A and V**H *B. */ + + if ((d__1 = ua21.r, abs(d__1)) + (d__2 = d_imag(&ua21), abs(d__2)) + + abs(ua22r) == 0.) { + z__1.r = vb22r, z__1.i = 0.; + zlartg_(&z__1, &vb21, csq, snq, &r__); + } else if ((d__1 = vb21.r, abs(d__1)) + (d__2 = d_imag(&vb21), + abs(d__2)) + abs(vb22r) == 0.) { + z__1.r = ua22r, z__1.i = 0.; + zlartg_(&z__1, &ua21, csq, snq, &r__); + } else if (aua21 / ((d__1 = ua21.r, abs(d__1)) + (d__2 = d_imag(& + ua21), abs(d__2)) + abs(ua22r)) <= avb21 / ((d__3 = + vb21.r, abs(d__3)) + (d__4 = d_imag(&vb21), abs(d__4)) + + abs(vb22r))) { + z__1.r = ua22r, z__1.i = 0.; + zlartg_(&z__1, &ua21, csq, snq, &r__); + } else { + z__1.r = vb22r, z__1.i = 0.; + zlartg_(&z__1, &vb21, csq, snq, &r__); + } + + *csu = csr; + d_cnjg(&z__3, &d1); + z__2.r = -z__3.r, z__2.i = -z__3.i; + z__1.r = snr * z__2.r, z__1.i = snr * z__2.i; + snu->r = z__1.r, snu->i = z__1.i; + *csv = csl; + d_cnjg(&z__3, &d1); + z__2.r = -z__3.r, z__2.i = -z__3.i; + z__1.r = snl * z__2.r, z__1.i = snl * z__2.i; + snv->r = z__1.r, snv->i = z__1.i; + + } else { + +/* Compute the (1,1) and (1,2) elements of U**H *A and V**H *B, */ +/* and (1,1) element of |U|**H *|A| and |V|**H *|B|. */ + + d__1 = csr * *a1; + d_cnjg(&z__4, &d1); + z__3.r = snr * z__4.r, z__3.i = snr * z__4.i; + z__2.r = z__3.r * a2->r - z__3.i * a2->i, z__2.i = z__3.r * a2->i + + z__3.i * a2->r; + z__1.r = d__1 + z__2.r, z__1.i = z__2.i; + ua11.r = z__1.r, ua11.i = z__1.i; + d_cnjg(&z__3, &d1); + z__2.r = snr * z__3.r, z__2.i = snr * z__3.i; + z__1.r = *a3 * z__2.r, z__1.i = *a3 * z__2.i; + ua12.r = z__1.r, ua12.i = z__1.i; + + d__1 = csl * *b1; + d_cnjg(&z__4, &d1); + z__3.r = snl * z__4.r, z__3.i = snl * z__4.i; + z__2.r = z__3.r * b2->r - z__3.i * b2->i, z__2.i = z__3.r * b2->i + + z__3.i * b2->r; + z__1.r = d__1 + z__2.r, z__1.i = z__2.i; + vb11.r = z__1.r, vb11.i = z__1.i; + d_cnjg(&z__3, &d1); + z__2.r = snl * z__3.r, z__2.i = snl * z__3.i; + z__1.r = *b3 * z__2.r, z__1.i = *b3 * z__2.i; + vb12.r = z__1.r, vb12.i = z__1.i; + + aua11 = abs(csr) * abs(*a1) + abs(snr) * ((d__1 = a2->r, abs(d__1) + ) + (d__2 = d_imag(a2), abs(d__2))); + avb11 = abs(csl) * abs(*b1) + abs(snl) * ((d__1 = b2->r, abs(d__1) + ) + (d__2 = d_imag(b2), abs(d__2))); + +/* zero (1,1) elements of U**H *A and V**H *B, and then swap. */ + + if ((d__1 = ua11.r, abs(d__1)) + (d__2 = d_imag(&ua11), abs(d__2)) + + ((d__3 = ua12.r, abs(d__3)) + (d__4 = d_imag(&ua12), + abs(d__4))) == 0.) { + zlartg_(&vb12, &vb11, csq, snq, &r__); + } else if ((d__1 = vb11.r, abs(d__1)) + (d__2 = d_imag(&vb11), + abs(d__2)) + ((d__3 = vb12.r, abs(d__3)) + (d__4 = d_imag( + &vb12), abs(d__4))) == 0.) { + zlartg_(&ua12, &ua11, csq, snq, &r__); + } else if (aua11 / ((d__1 = ua11.r, abs(d__1)) + (d__2 = d_imag(& + ua11), abs(d__2)) + ((d__3 = ua12.r, abs(d__3)) + (d__4 = + d_imag(&ua12), abs(d__4)))) <= avb11 / ((d__5 = vb11.r, + abs(d__5)) + (d__6 = d_imag(&vb11), abs(d__6)) + ((d__7 = + vb12.r, abs(d__7)) + (d__8 = d_imag(&vb12), abs(d__8))))) + { + zlartg_(&ua12, &ua11, csq, snq, &r__); + } else { + zlartg_(&vb12, &vb11, csq, snq, &r__); + } + + *csu = snr; + d_cnjg(&z__2, &d1); + z__1.r = csr * z__2.r, z__1.i = csr * z__2.i; + snu->r = z__1.r, snu->i = z__1.i; + *csv = snl; + d_cnjg(&z__2, &d1); + z__1.r = csl * z__2.r, z__1.i = csl * z__2.i; + snv->r = z__1.r, snv->i = z__1.i; + + } + + } + + return 0; + +/* End of ZLAGS2 */ + +} /* zlags2_ */ + diff --git a/lapack-netlib/SRC/zlagtm.c b/lapack-netlib/SRC/zlagtm.c new file mode 100644 index 000000000..96da7cae8 --- /dev/null +++ b/lapack-netlib/SRC/zlagtm.c @@ -0,0 +1,1045 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAGTM performs a matrix-matrix product of the form C = αAB+βC, where A is a tridiagonal matr +ix, B and C are rectangular matrices, and α and β are scalars, which may be 0, 1, or -1. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAGTM + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA, */ +/* B, LDB ) */ + +/* CHARACTER TRANS */ +/* INTEGER LDB, LDX, N, NRHS */ +/* DOUBLE PRECISION ALPHA, BETA */ +/* COMPLEX*16 B( LDB, * ), D( * ), DL( * ), DU( * ), */ +/* $ X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAGTM performs a matrix-vector product of the form */ +/* > */ +/* > B := alpha * A * X + beta * B */ +/* > */ +/* > where A is a tridiagonal matrix of order N, B and X are N by NRHS */ +/* > matrices, and alpha and beta are real scalars, each of which may be */ +/* > 0., 1., or -1. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the operation applied to A. */ +/* > = 'N': No transpose, B := alpha * A * X + beta * B */ +/* > = 'T': Transpose, B := alpha * A**T * X + beta * B */ +/* > = 'C': Conjugate transpose, B := alpha * A**H * X + beta * B */ +/* > \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 X and B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is DOUBLE PRECISION */ +/* > The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise, */ +/* > it is assumed to be 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DL */ +/* > \verbatim */ +/* > DL is COMPLEX*16 array, dimension (N-1) */ +/* > The (n-1) sub-diagonal elements of T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is COMPLEX*16 array, dimension (N) */ +/* > The diagonal elements of T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DU */ +/* > \verbatim */ +/* > DU is COMPLEX*16 array, dimension (N-1) */ +/* > The (n-1) super-diagonal elements of T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (LDX,NRHS) */ +/* > The N by NRHS matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(N,1). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION */ +/* > The scalar beta. BETA must be 0., 1., or -1.; otherwise, */ +/* > it is assumed to be 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > On entry, the N by NRHS matrix B. */ +/* > On exit, B is overwritten by the matrix expression */ +/* > B := alpha * A * X + beta * B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(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 complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlagtm_(char *trans, integer *n, integer *nrhs, + doublereal *alpha, doublecomplex *dl, doublecomplex *d__, + doublecomplex *du, doublecomplex *x, integer *ldx, doublereal *beta, + doublecomplex *b, integer *ldb) +{ + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5, + i__6, i__7, i__8, i__9, i__10; + doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8, z__9; + + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + + +/* -- 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 */ + --dl; + --d__; + --du; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + if (*n == 0) { + return 0; + } + +/* Multiply B by BETA if BETA.NE.1. */ + + if (*beta == 0.) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + b[i__3].r = 0., b[i__3].i = 0.; +/* L10: */ + } +/* L20: */ + } + } else if (*beta == -1.) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + z__1.r = -b[i__4].r, z__1.i = -b[i__4].i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L30: */ + } +/* L40: */ + } + } + + if (*alpha == 1.) { + if (lsame_(trans, "N")) { + +/* Compute B := B + A*X */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + if (*n == 1) { + i__2 = j * b_dim1 + 1; + i__3 = j * b_dim1 + 1; + i__4 = j * x_dim1 + 1; + z__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i, + z__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4] + .r; + z__1.r = b[i__3].r + z__2.r, z__1.i = b[i__3].i + z__2.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } else { + i__2 = j * b_dim1 + 1; + i__3 = j * b_dim1 + 1; + i__4 = j * x_dim1 + 1; + z__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i, + z__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4] + .r; + z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i; + i__5 = j * x_dim1 + 2; + z__4.r = du[1].r * x[i__5].r - du[1].i * x[i__5].i, + z__4.i = du[1].r * x[i__5].i + du[1].i * x[i__5] + .r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = *n + j * b_dim1; + i__3 = *n + j * b_dim1; + i__4 = *n - 1; + i__5 = *n - 1 + j * x_dim1; + z__3.r = dl[i__4].r * x[i__5].r - dl[i__4].i * x[i__5].i, + z__3.i = dl[i__4].r * x[i__5].i + dl[i__4].i * x[ + i__5].r; + z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i; + i__6 = *n; + i__7 = *n + j * x_dim1; + z__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7] + .i, z__4.i = d__[i__6].r * x[i__7].i + d__[i__6] + .i * x[i__7].r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = i__ - 1; + i__6 = i__ - 1 + j * x_dim1; + z__4.r = dl[i__5].r * x[i__6].r - dl[i__5].i * x[i__6] + .i, z__4.i = dl[i__5].r * x[i__6].i + dl[i__5] + .i * x[i__6].r; + z__3.r = b[i__4].r + z__4.r, z__3.i = b[i__4].i + + z__4.i; + i__7 = i__; + i__8 = i__ + j * x_dim1; + z__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[ + i__8].i, z__5.i = d__[i__7].r * x[i__8].i + + d__[i__7].i * x[i__8].r; + z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i; + i__9 = i__; + i__10 = i__ + 1 + j * x_dim1; + z__6.r = du[i__9].r * x[i__10].r - du[i__9].i * x[ + i__10].i, z__6.i = du[i__9].r * x[i__10].i + + du[i__9].i * x[i__10].r; + z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L50: */ + } + } +/* L60: */ + } + } else if (lsame_(trans, "T")) { + +/* Compute B := B + A**T * X */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + if (*n == 1) { + i__2 = j * b_dim1 + 1; + i__3 = j * b_dim1 + 1; + i__4 = j * x_dim1 + 1; + z__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i, + z__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4] + .r; + z__1.r = b[i__3].r + z__2.r, z__1.i = b[i__3].i + z__2.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } else { + i__2 = j * b_dim1 + 1; + i__3 = j * b_dim1 + 1; + i__4 = j * x_dim1 + 1; + z__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i, + z__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4] + .r; + z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i; + i__5 = j * x_dim1 + 2; + z__4.r = dl[1].r * x[i__5].r - dl[1].i * x[i__5].i, + z__4.i = dl[1].r * x[i__5].i + dl[1].i * x[i__5] + .r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = *n + j * b_dim1; + i__3 = *n + j * b_dim1; + i__4 = *n - 1; + i__5 = *n - 1 + j * x_dim1; + z__3.r = du[i__4].r * x[i__5].r - du[i__4].i * x[i__5].i, + z__3.i = du[i__4].r * x[i__5].i + du[i__4].i * x[ + i__5].r; + z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i; + i__6 = *n; + i__7 = *n + j * x_dim1; + z__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7] + .i, z__4.i = d__[i__6].r * x[i__7].i + d__[i__6] + .i * x[i__7].r; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = i__ - 1; + i__6 = i__ - 1 + j * x_dim1; + z__4.r = du[i__5].r * x[i__6].r - du[i__5].i * x[i__6] + .i, z__4.i = du[i__5].r * x[i__6].i + du[i__5] + .i * x[i__6].r; + z__3.r = b[i__4].r + z__4.r, z__3.i = b[i__4].i + + z__4.i; + i__7 = i__; + i__8 = i__ + j * x_dim1; + z__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[ + i__8].i, z__5.i = d__[i__7].r * x[i__8].i + + d__[i__7].i * x[i__8].r; + z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i; + i__9 = i__; + i__10 = i__ + 1 + j * x_dim1; + z__6.r = dl[i__9].r * x[i__10].r - dl[i__9].i * x[ + i__10].i, z__6.i = dl[i__9].r * x[i__10].i + + dl[i__9].i * x[i__10].r; + z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L70: */ + } + } +/* L80: */ + } + } else if (lsame_(trans, "C")) { + +/* Compute B := B + A**H * X */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + if (*n == 1) { + i__2 = j * b_dim1 + 1; + i__3 = j * b_dim1 + 1; + d_cnjg(&z__3, &d__[1]); + i__4 = j * x_dim1 + 1; + z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i = + z__3.r * x[i__4].i + z__3.i * x[i__4].r; + z__1.r = b[i__3].r + z__2.r, z__1.i = b[i__3].i + z__2.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } else { + i__2 = j * b_dim1 + 1; + i__3 = j * b_dim1 + 1; + d_cnjg(&z__4, &d__[1]); + i__4 = j * x_dim1 + 1; + z__3.r = z__4.r * x[i__4].r - z__4.i * x[i__4].i, z__3.i = + z__4.r * x[i__4].i + z__4.i * x[i__4].r; + z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i; + d_cnjg(&z__6, &dl[1]); + i__5 = j * x_dim1 + 2; + z__5.r = z__6.r * x[i__5].r - z__6.i * x[i__5].i, z__5.i = + z__6.r * x[i__5].i + z__6.i * x[i__5].r; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = *n + j * b_dim1; + i__3 = *n + j * b_dim1; + d_cnjg(&z__4, &du[*n - 1]); + i__4 = *n - 1 + j * x_dim1; + z__3.r = z__4.r * x[i__4].r - z__4.i * x[i__4].i, z__3.i = + z__4.r * x[i__4].i + z__4.i * x[i__4].r; + z__2.r = b[i__3].r + z__3.r, z__2.i = b[i__3].i + z__3.i; + d_cnjg(&z__6, &d__[*n]); + i__5 = *n + j * x_dim1; + z__5.r = z__6.r * x[i__5].r - z__6.i * x[i__5].i, z__5.i = + z__6.r * x[i__5].i + z__6.i * x[i__5].r; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + d_cnjg(&z__5, &du[i__ - 1]); + i__5 = i__ - 1 + j * x_dim1; + z__4.r = z__5.r * x[i__5].r - z__5.i * x[i__5].i, + z__4.i = z__5.r * x[i__5].i + z__5.i * x[i__5] + .r; + z__3.r = b[i__4].r + z__4.r, z__3.i = b[i__4].i + + z__4.i; + d_cnjg(&z__7, &d__[i__]); + i__6 = i__ + j * x_dim1; + z__6.r = z__7.r * x[i__6].r - z__7.i * x[i__6].i, + z__6.i = z__7.r * x[i__6].i + z__7.i * x[i__6] + .r; + z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i; + d_cnjg(&z__9, &dl[i__]); + i__7 = i__ + 1 + j * x_dim1; + z__8.r = z__9.r * x[i__7].r - z__9.i * x[i__7].i, + z__8.i = z__9.r * x[i__7].i + z__9.i * x[i__7] + .r; + z__1.r = z__2.r + z__8.r, z__1.i = z__2.i + z__8.i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L90: */ + } + } +/* L100: */ + } + } + } else if (*alpha == -1.) { + if (lsame_(trans, "N")) { + +/* Compute B := B - A*X */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + if (*n == 1) { + i__2 = j * b_dim1 + 1; + i__3 = j * b_dim1 + 1; + i__4 = j * x_dim1 + 1; + z__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i, + z__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4] + .r; + z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i - z__2.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } else { + i__2 = j * b_dim1 + 1; + i__3 = j * b_dim1 + 1; + i__4 = j * x_dim1 + 1; + z__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i, + z__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4] + .r; + z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i; + i__5 = j * x_dim1 + 2; + z__4.r = du[1].r * x[i__5].r - du[1].i * x[i__5].i, + z__4.i = du[1].r * x[i__5].i + du[1].i * x[i__5] + .r; + z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = *n + j * b_dim1; + i__3 = *n + j * b_dim1; + i__4 = *n - 1; + i__5 = *n - 1 + j * x_dim1; + z__3.r = dl[i__4].r * x[i__5].r - dl[i__4].i * x[i__5].i, + z__3.i = dl[i__4].r * x[i__5].i + dl[i__4].i * x[ + i__5].r; + z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i; + i__6 = *n; + i__7 = *n + j * x_dim1; + z__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7] + .i, z__4.i = d__[i__6].r * x[i__7].i + d__[i__6] + .i * x[i__7].r; + z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = i__ - 1; + i__6 = i__ - 1 + j * x_dim1; + z__4.r = dl[i__5].r * x[i__6].r - dl[i__5].i * x[i__6] + .i, z__4.i = dl[i__5].r * x[i__6].i + dl[i__5] + .i * x[i__6].r; + z__3.r = b[i__4].r - z__4.r, z__3.i = b[i__4].i - + z__4.i; + i__7 = i__; + i__8 = i__ + j * x_dim1; + z__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[ + i__8].i, z__5.i = d__[i__7].r * x[i__8].i + + d__[i__7].i * x[i__8].r; + z__2.r = z__3.r - z__5.r, z__2.i = z__3.i - z__5.i; + i__9 = i__; + i__10 = i__ + 1 + j * x_dim1; + z__6.r = du[i__9].r * x[i__10].r - du[i__9].i * x[ + i__10].i, z__6.i = du[i__9].r * x[i__10].i + + du[i__9].i * x[i__10].r; + z__1.r = z__2.r - z__6.r, z__1.i = z__2.i - z__6.i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L110: */ + } + } +/* L120: */ + } + } else if (lsame_(trans, "T")) { + +/* Compute B := B - A**T *X */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + if (*n == 1) { + i__2 = j * b_dim1 + 1; + i__3 = j * b_dim1 + 1; + i__4 = j * x_dim1 + 1; + z__2.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i, + z__2.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4] + .r; + z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i - z__2.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } else { + i__2 = j * b_dim1 + 1; + i__3 = j * b_dim1 + 1; + i__4 = j * x_dim1 + 1; + z__3.r = d__[1].r * x[i__4].r - d__[1].i * x[i__4].i, + z__3.i = d__[1].r * x[i__4].i + d__[1].i * x[i__4] + .r; + z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i; + i__5 = j * x_dim1 + 2; + z__4.r = dl[1].r * x[i__5].r - dl[1].i * x[i__5].i, + z__4.i = dl[1].r * x[i__5].i + dl[1].i * x[i__5] + .r; + z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = *n + j * b_dim1; + i__3 = *n + j * b_dim1; + i__4 = *n - 1; + i__5 = *n - 1 + j * x_dim1; + z__3.r = du[i__4].r * x[i__5].r - du[i__4].i * x[i__5].i, + z__3.i = du[i__4].r * x[i__5].i + du[i__4].i * x[ + i__5].r; + z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i; + i__6 = *n; + i__7 = *n + j * x_dim1; + z__4.r = d__[i__6].r * x[i__7].r - d__[i__6].i * x[i__7] + .i, z__4.i = d__[i__6].r * x[i__7].i + d__[i__6] + .i * x[i__7].r; + z__1.r = z__2.r - z__4.r, z__1.i = z__2.i - z__4.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + i__5 = i__ - 1; + i__6 = i__ - 1 + j * x_dim1; + z__4.r = du[i__5].r * x[i__6].r - du[i__5].i * x[i__6] + .i, z__4.i = du[i__5].r * x[i__6].i + du[i__5] + .i * x[i__6].r; + z__3.r = b[i__4].r - z__4.r, z__3.i = b[i__4].i - + z__4.i; + i__7 = i__; + i__8 = i__ + j * x_dim1; + z__5.r = d__[i__7].r * x[i__8].r - d__[i__7].i * x[ + i__8].i, z__5.i = d__[i__7].r * x[i__8].i + + d__[i__7].i * x[i__8].r; + z__2.r = z__3.r - z__5.r, z__2.i = z__3.i - z__5.i; + i__9 = i__; + i__10 = i__ + 1 + j * x_dim1; + z__6.r = dl[i__9].r * x[i__10].r - dl[i__9].i * x[ + i__10].i, z__6.i = dl[i__9].r * x[i__10].i + + dl[i__9].i * x[i__10].r; + z__1.r = z__2.r - z__6.r, z__1.i = z__2.i - z__6.i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L130: */ + } + } +/* L140: */ + } + } else if (lsame_(trans, "C")) { + +/* Compute B := B - A**H *X */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + if (*n == 1) { + i__2 = j * b_dim1 + 1; + i__3 = j * b_dim1 + 1; + d_cnjg(&z__3, &d__[1]); + i__4 = j * x_dim1 + 1; + z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, z__2.i = + z__3.r * x[i__4].i + z__3.i * x[i__4].r; + z__1.r = b[i__3].r - z__2.r, z__1.i = b[i__3].i - z__2.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } else { + i__2 = j * b_dim1 + 1; + i__3 = j * b_dim1 + 1; + d_cnjg(&z__4, &d__[1]); + i__4 = j * x_dim1 + 1; + z__3.r = z__4.r * x[i__4].r - z__4.i * x[i__4].i, z__3.i = + z__4.r * x[i__4].i + z__4.i * x[i__4].r; + z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i; + d_cnjg(&z__6, &dl[1]); + i__5 = j * x_dim1 + 2; + z__5.r = z__6.r * x[i__5].r - z__6.i * x[i__5].i, z__5.i = + z__6.r * x[i__5].i + z__6.i * x[i__5].r; + z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - z__5.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = *n + j * b_dim1; + i__3 = *n + j * b_dim1; + d_cnjg(&z__4, &du[*n - 1]); + i__4 = *n - 1 + j * x_dim1; + z__3.r = z__4.r * x[i__4].r - z__4.i * x[i__4].i, z__3.i = + z__4.r * x[i__4].i + z__4.i * x[i__4].r; + z__2.r = b[i__3].r - z__3.r, z__2.i = b[i__3].i - z__3.i; + d_cnjg(&z__6, &d__[*n]); + i__5 = *n + j * x_dim1; + z__5.r = z__6.r * x[i__5].r - z__6.i * x[i__5].i, z__5.i = + z__6.r * x[i__5].i + z__6.i * x[i__5].r; + z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - z__5.i; + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + i__4 = i__ + j * b_dim1; + d_cnjg(&z__5, &du[i__ - 1]); + i__5 = i__ - 1 + j * x_dim1; + z__4.r = z__5.r * x[i__5].r - z__5.i * x[i__5].i, + z__4.i = z__5.r * x[i__5].i + z__5.i * x[i__5] + .r; + z__3.r = b[i__4].r - z__4.r, z__3.i = b[i__4].i - + z__4.i; + d_cnjg(&z__7, &d__[i__]); + i__6 = i__ + j * x_dim1; + z__6.r = z__7.r * x[i__6].r - z__7.i * x[i__6].i, + z__6.i = z__7.r * x[i__6].i + z__7.i * x[i__6] + .r; + z__2.r = z__3.r - z__6.r, z__2.i = z__3.i - z__6.i; + d_cnjg(&z__9, &dl[i__]); + i__7 = i__ + 1 + j * x_dim1; + z__8.r = z__9.r * x[i__7].r - z__9.i * x[i__7].i, + z__8.i = z__9.r * x[i__7].i + z__9.i * x[i__7] + .r; + z__1.r = z__2.r - z__8.r, z__1.i = z__2.i - z__8.i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L150: */ + } + } +/* L160: */ + } + } + } + return 0; + +/* End of ZLAGTM */ + +} /* zlagtm_ */ + diff --git a/lapack-netlib/SRC/zlahef.c b/lapack-netlib/SRC/zlahef.c new file mode 100644 index 000000000..8fe0b341f --- /dev/null +++ b/lapack-netlib/SRC/zlahef.c @@ -0,0 +1,1617 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAHEF computes a partial factorization of a complex Hermitian indefinite matrix using the Bunc +h-Kaufman diagonal pivoting method (blocked algorithm, calling Level 3 BLAS). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAHEF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAHEF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, KB, LDA, LDW, N, NB */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), W( LDW, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAHEF computes a partial factorization of a complex Hermitian */ +/* > matrix A using the Bunch-Kaufman diagonal pivoting method. The */ +/* > partial factorization has the form: */ +/* > */ +/* > A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: */ +/* > ( 0 U22 ) ( 0 D ) ( U12**H U22**H ) */ +/* > */ +/* > A = ( L11 0 ) ( D 0 ) ( L11**H L21**H ) if UPLO = 'L' */ +/* > ( L21 I ) ( 0 A22 ) ( 0 I ) */ +/* > */ +/* > where the order of D is at most NB. The actual order is returned in */ +/* > the argument KB, and is either NB or NB-1, or N if N <= NB. */ +/* > Note that U**H denotes the conjugate transpose of U. */ +/* > */ +/* > ZLAHEF is an auxiliary routine called by ZHETRF. It uses blocked code */ +/* > (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or */ +/* > A22 (if UPLO = 'L'). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > Hermitian 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] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The maximum number of columns of the matrix A that should be */ +/* > factored. NB should be at least 2 to allow for 2-by-2 pivot */ +/* > blocks. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] KB */ +/* > \verbatim */ +/* > KB is INTEGER */ +/* > The number of columns of A that were actually factored. */ +/* > KB is either NB-1 or NB, or N if N <= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the Hermitian 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, A contains details of the partial factorization. */ +/* > \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': */ +/* > Only the last KB elements of IPIV are set. */ +/* > */ +/* > 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) = 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': */ +/* > Only the first KB elements of IPIV are set. */ +/* > */ +/* > 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) = 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] W */ +/* > \verbatim */ +/* > W is COMPLEX*16 array, dimension (LDW,NB) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDW */ +/* > \verbatim */ +/* > LDW is INTEGER */ +/* > The leading dimension of the array W. LDW >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > > 0: if INFO = k, D(k,k) is exactly zero. The factorization */ +/* > has been completed, but the block diagonal matrix D is */ +/* > exactly singular. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16HEcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > December 2016, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int zlahef_(char *uplo, integer *n, integer *nb, integer *kb, + doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *w, + integer *ldw, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5; + doublereal d__1, d__2, d__3, d__4; + doublecomplex z__1, z__2, z__3, z__4; + + /* Local variables */ + integer imax, jmax, j, k; + doublereal t, alpha; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + integer kstep; + extern /* Subroutine */ int zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + doublereal r1; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zswap_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *); + doublecomplex d11, d21, d22; + integer jb, jj, kk, jp, kp; + doublereal absakk; + integer kw; + extern /* Subroutine */ int zdscal_(integer *, doublereal *, + doublecomplex *, integer *); + doublereal colmax; + extern /* Subroutine */ int zlacgv_(integer *, doublecomplex *, integer *) + ; + extern integer izamax_(integer *, doublecomplex *, integer *); + doublereal rowmax; + integer kkw; + + +/* -- 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; + w_dim1 = *ldw; + w_offset = 1 + w_dim1 * 1; + w -= w_offset; + + /* Function Body */ + *info = 0; + +/* Initialize ALPHA for use in choosing pivot block size. */ + + alpha = (sqrt(17.) + 1.) / 8.; + + if (lsame_(uplo, "U")) { + +/* Factorize the trailing columns of A using the upper triangle */ +/* of A and working backwards, and compute the matrix W = U12*D */ +/* for use in updating A11 (note that conjg(W) is actually stored) */ + +/* K is the main loop index, decreasing from N in steps of 1 or 2 */ + +/* KW is the column of W which corresponds to column K of A */ + + k = *n; +L10: + kw = *nb + k - *n; + +/* Exit from loop */ + + if (k <= *n - *nb + 1 && *nb < *n || k < 1) { + goto L30; + } + + kstep = 1; + +/* Copy column K of A to column KW of W and update it */ + + i__1 = k - 1; + zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = k + kw * w_dim1; + i__2 = k + k * a_dim1; + d__1 = a[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + if (k < *n) { + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * + w_dim1 + 1], &c__1); + i__1 = k + kw * w_dim1; + i__2 = k + kw * w_dim1; + d__1 = w[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + } + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = k + kw * w_dim1; + absakk = (d__1 = w[i__1].r, abs(d__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k > 1) { + i__1 = k - 1; + imax = izamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = imax + kw * w_dim1; + colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + kw * w_dim1]), abs(d__2)); + } else { + colmax = 0.; + } + + if (f2cmax(absakk,colmax) == 0.) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + } else { + +/* ============================================================ */ + +/* BEGIN pivot search */ + +/* Case(1) */ + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + +/* BEGIN pivot search along IMAX row */ + + +/* Copy column IMAX to column KW-1 of W and update it */ + + i__1 = imax - 1; + zcopy_(&i__1, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + i__1 = imax + (kw - 1) * w_dim1; + i__2 = imax + imax * a_dim1; + d__1 = a[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + i__1 = k - imax; + zcopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + i__1 = k - imax; + zlacgv_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], &c__1); + if (k < *n) { + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1); + i__1 = imax + (kw - 1) * w_dim1; + i__2 = imax + (kw - 1) * w_dim1; + d__1 = w[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + } + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine only ROWMAX. */ + + i__1 = k - imax; + jmax = imax + izamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], + &c__1); + i__1 = jmax + (kw - 1) * w_dim1; + rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + jmax + (kw - 1) * w_dim1]), abs(d__2)); + if (imax > 1) { + i__1 = imax - 1; + jmax = izamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); +/* Computing MAX */ + i__1 = jmax + (kw - 1) * w_dim1; + d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) + ( + d__2 = d_imag(&w[jmax + (kw - 1) * w_dim1]), abs( + d__2)); + rowmax = f2cmax(d__3,d__4); + } + +/* Case(2) */ + if (absakk >= alpha * colmax * (colmax / rowmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + +/* Case(3) */ + } else /* if(complicated condition) */ { + i__1 = imax + (kw - 1) * w_dim1; + if ((d__1 = w[i__1].r, abs(d__1)) >= alpha * rowmax) { + +/* interchange rows and columns K and IMAX, use 1-by-1 */ +/* pivot block */ + + kp = imax; + +/* copy column KW-1 of W to column KW of W */ + + zcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + +/* Case(4) */ + } else { + +/* interchange rows and columns K-1 and IMAX, use 2-by-2 */ +/* pivot block */ + + kp = imax; + kstep = 2; + } + } + + +/* END pivot search along IMAX row */ + + } + +/* END pivot search */ + +/* ============================================================ */ + +/* KK is the column of A where pivoting step stopped */ + + kk = k - kstep + 1; + +/* KKW is the column of W which corresponds to column KK of A */ + + kkw = *nb + kk - *n; + +/* Interchange rows and columns KP and KK. */ +/* Updated column KP is already stored in column KKW of W. */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP of submatrix A */ +/* at step K. No need to copy element into column K */ +/* (or K and K-1 for 2-by-2 pivot) of A, since these columns */ +/* will be later overwritten. */ + + i__1 = kp + kp * a_dim1; + i__2 = kk + kk * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = kk - 1 - kp; + zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + i__1 = kk - 1 - kp; + zlacgv_(&i__1, &a[kp + (kp + 1) * a_dim1], lda); + if (kp > 1) { + i__1 = kp - 1; + zcopy_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + +/* Interchange rows KK and KP in last K+1 to N columns of A */ +/* (columns K (or K and K-1 for 2-by-2 pivot) of A will be */ +/* later overwritten). Interchange rows KK and KP */ +/* in last KKW to NB columns of W. */ + + if (k < *n) { + i__1 = *n - k; + zswap_(&i__1, &a[kk + (k + 1) * a_dim1], lda, &a[kp + (k + + 1) * a_dim1], lda); + } + i__1 = *n - kk + 1; + zswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column kw of W now holds */ + +/* W(kw) = U(k)*D(k), */ + +/* where U(k) is the k-th column of U */ + +/* (1) Store subdiag. elements of column U(k) */ +/* and 1-by-1 block D(k) in column k of A. */ +/* (NOTE: Diagonal element U(k,k) is a UNIT element */ +/* and not stored) */ +/* A(k,k) := D(k,k) = W(k,kw) */ +/* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k) */ + +/* (NOTE: No need to use for Hermitian matrix */ +/* A( K, K ) = DBLE( W( K, K) ) to separately copy diagonal */ +/* element D(k,k) from W (potentially saves only one load)) */ + zcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + if (k > 1) { + +/* (NOTE: No need to check if A(k,k) is NOT ZERO, */ +/* since that was ensured earlier in pivot search: */ +/* case A(k,k) = 0 falls into 2x2 pivot case(4)) */ + + i__1 = k + k * a_dim1; + r1 = 1. / a[i__1].r; + i__1 = k - 1; + zdscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + +/* (2) Conjugate column W(kw) */ + + i__1 = k - 1; + zlacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1); + } + + } else { + +/* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold */ + +/* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k) */ + +/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ +/* of U */ + +/* (1) Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2 */ +/* block D(k-1:k,k-1:k) in columns k-1 and k of A. */ +/* (NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT */ +/* block and not stored) */ +/* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw) */ +/* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) = */ +/* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) ) */ + + if (k > 2) { + +/* Factor out the columns of the inverse of 2-by-2 pivot */ +/* block D, so that each column contains 1, to reduce the */ +/* number of FLOPS when we multiply panel */ +/* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1). */ + +/* D**(-1) = ( d11 cj(d21) )**(-1) = */ +/* ( d21 d22 ) */ + +/* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) = */ +/* ( (-d21) ( d11 ) ) */ + +/* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) * */ + +/* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) = */ +/* ( ( -1 ) ( d11/conj(d21) ) ) */ + +/* = 1/(|d21|**2) * 1/(D22*D11-1) * */ + +/* * ( d21*( D11 ) conj(d21)*( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = ( conj(D21)*( D11 ) D21*( -1 ) ) */ +/* ( ( -1 ) ( D22 ) ), */ + +/* where D11 = d22/d21, */ +/* D22 = d11/conj(d21), */ +/* D21 = T/d21, */ +/* T = 1/(D22*D11-1). */ + +/* (NOTE: No need to check for division by ZERO, */ +/* since that was ensured earlier in pivot search: */ +/* (a) d21 != 0, since in 2x2 pivot case(4) */ +/* |d21| should be larger than |d11| and |d22|; */ +/* (b) (D22*D11 - 1) != 0, since from (a), */ +/* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.) */ + + i__1 = k - 1 + kw * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + d_cnjg(&z__2, &d21); + z_div(&z__1, &w[k + kw * w_dim1], &z__2); + d11.r = z__1.r, d11.i = z__1.i; + z_div(&z__1, &w[k - 1 + (kw - 1) * w_dim1], &d21); + d22.r = z__1.r, d22.i = z__1.i; + z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r * + d22.i + d11.i * d22.r; + t = 1. / (z__1.r - 1.); + z__2.r = t, z__2.i = 0.; + z_div(&z__1, &z__2, &d21); + d21.r = z__1.r, d21.i = z__1.i; + +/* Update elements in columns A(k-1) and A(k) as */ +/* dot products of rows of ( W(kw-1) W(kw) ) and columns */ +/* of D**(-1) */ + + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + i__2 = j + (k - 1) * a_dim1; + i__3 = j + (kw - 1) * w_dim1; + z__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__3.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + kw * w_dim1; + z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4] + .i; + z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i = + d21.r * z__2.i + d21.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + k * a_dim1; + d_cnjg(&z__2, &d21); + i__3 = j + kw * w_dim1; + z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + (kw - 1) * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = + z__2.r * z__3.i + z__2.i * z__3.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L20: */ + } + } + +/* Copy D(k) to A */ + + i__1 = k - 1 + (k - 1) * a_dim1; + i__2 = k - 1 + (kw - 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k - 1 + k * a_dim1; + i__2 = k - 1 + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + k * a_dim1; + i__2 = k + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + +/* (2) Conjugate columns W(kw) and W(kw-1) */ + + i__1 = k - 1; + zlacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = k - 2; + zlacgv_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); + + } + + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + goto L10; + +L30: + +/* Update the upper triangle of A11 (= A(1:k,1:k)) as */ + +/* A11 := A11 - U12*D*U12**H = A11 - U12*W**H */ + +/* computing blocks of NB columns at a time (note that conjg(W) is */ +/* actually stored) */ + + i__1 = -(*nb); + for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += + i__1) { +/* Computing MIN */ + i__2 = *nb, i__3 = k - j + 1; + jb = f2cmin(i__2,i__3); + +/* Update the upper triangle of the diagonal block */ + + i__2 = j + jb - 1; + for (jj = j; jj <= i__2; ++jj) { + i__3 = jj + jj * a_dim1; + i__4 = jj + jj * a_dim1; + d__1 = a[i__4].r; + a[i__3].r = d__1, a[i__3].i = 0.; + i__3 = jj - j + 1; + i__4 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__3, &i__4, &z__1, &a[j + (k + 1) * + a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b1, + &a[j + jj * a_dim1], &c__1); + i__3 = jj + jj * a_dim1; + i__4 = jj + jj * a_dim1; + d__1 = a[i__4].r; + a[i__3].r = d__1, a[i__3].i = 0.; +/* L40: */ + } + +/* Update the rectangular superdiagonal block */ + + i__2 = j - 1; + i__3 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &z__1, &a[( + k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * w_dim1], ldw, + &c_b1, &a[j * a_dim1 + 1], lda); +/* L50: */ + } + +/* Put U12 in standard form by partially undoing the interchanges */ +/* in columns k+1:n looping backwards from k+1 to n */ + + j = k + 1; +L60: + +/* Undo the interchanges (if any) of rows JJ and JP at each */ +/* step J */ + +/* (Here, J is a diagonal index) */ + jj = j; + jp = ipiv[j]; + if (jp < 0) { + jp = -jp; +/* (Here, J is a diagonal index) */ + ++j; + } +/* (NOTE: Here, J is used to determine row length. Length N-J+1 */ +/* of the rows to swap back doesn't include diagonal element) */ + ++j; + if (jp != jj && j <= *n) { + i__1 = *n - j + 1; + zswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda); + } + if (j < *n) { + goto L60; + } + +/* Set KB to the number of columns factorized */ + + *kb = *n - k; + + } else { + +/* Factorize the leading columns of A using the lower triangle */ +/* of A and working forwards, and compute the matrix W = L21*D */ +/* for use in updating A22 (note that conjg(W) is actually stored) */ + +/* K is the main loop index, increasing from 1 in steps of 1 or 2 */ + + k = 1; +L70: + +/* Exit from loop */ + + if (k >= *nb && *nb < *n || k > *n) { + goto L90; + } + + kstep = 1; + +/* Copy column K of A to column K of W and update it */ + + i__1 = k + k * w_dim1; + i__2 = k + k * a_dim1; + d__1 = a[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + if (k < *n) { + i__1 = *n - k; + zcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &w[k + 1 + k * + w_dim1], &c__1); + } + i__1 = *n - k + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], lda, &w[k + + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1); + i__1 = k + k * w_dim1; + i__2 = k + k * w_dim1; + d__1 = w[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = k + k * w_dim1; + absakk = (d__1 = w[i__1].r, abs(d__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k < *n) { + i__1 = *n - k; + imax = k + izamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = imax + k * w_dim1; + colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + k * w_dim1]), abs(d__2)); + } else { + colmax = 0.; + } + + if (f2cmax(absakk,colmax) == 0.) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + } else { + +/* ============================================================ */ + +/* BEGIN pivot search */ + +/* Case(1) */ + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + +/* BEGIN pivot search along IMAX row */ + + +/* Copy column IMAX to column K+1 of W and update it */ + + i__1 = imax - k; + zcopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = imax - k; + zlacgv_(&i__1, &w[k + (k + 1) * w_dim1], &c__1); + i__1 = imax + (k + 1) * w_dim1; + i__2 = imax + imax * a_dim1; + d__1 = a[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + if (imax < *n) { + i__1 = *n - imax; + zcopy_(&i__1, &a[imax + 1 + imax * a_dim1], &c__1, &w[ + imax + 1 + (k + 1) * w_dim1], &c__1); + } + i__1 = *n - k + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], + lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = imax + (k + 1) * w_dim1; + i__2 = imax + (k + 1) * w_dim1; + d__1 = w[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine only ROWMAX. */ + + i__1 = imax - k; + jmax = k - 1 + izamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1) + ; + i__1 = jmax + (k + 1) * w_dim1; + rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + jmax + (k + 1) * w_dim1]), abs(d__2)); + if (imax < *n) { + i__1 = *n - imax; + jmax = imax + izamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); +/* Computing MAX */ + i__1 = jmax + (k + 1) * w_dim1; + d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) + ( + d__2 = d_imag(&w[jmax + (k + 1) * w_dim1]), abs( + d__2)); + rowmax = f2cmax(d__3,d__4); + } + +/* Case(2) */ + if (absakk >= alpha * colmax * (colmax / rowmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + +/* Case(3) */ + } else /* if(complicated condition) */ { + i__1 = imax + (k + 1) * w_dim1; + if ((d__1 = w[i__1].r, abs(d__1)) >= alpha * rowmax) { + +/* interchange rows and columns K and IMAX, use 1-by-1 */ +/* pivot block */ + + kp = imax; + +/* copy column K+1 of W to column K of W */ + + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + + k * w_dim1], &c__1); + +/* Case(4) */ + } else { + +/* interchange rows and columns K+1 and IMAX, use 2-by-2 */ +/* pivot block */ + + kp = imax; + kstep = 2; + } + } + + +/* END pivot search along IMAX row */ + + } + +/* END pivot search */ + +/* ============================================================ */ + +/* KK is the column of A where pivoting step stopped */ + + kk = k + kstep - 1; + +/* Interchange rows and columns KP and KK. */ +/* Updated column KP is already stored in column KK of W. */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP of submatrix A */ +/* at step K. No need to copy element into column K */ +/* (or K and K+1 for 2-by-2 pivot) of A, since these columns */ +/* will be later overwritten. */ + + i__1 = kp + kp * a_dim1; + i__2 = kk + kk * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = kp - kk - 1; + zcopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + + 1) * a_dim1], lda); + i__1 = kp - kk - 1; + zlacgv_(&i__1, &a[kp + (kk + 1) * a_dim1], lda); + if (kp < *n) { + i__1 = *n - kp; + zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + +/* Interchange rows KK and KP in first K-1 columns of A */ +/* (columns K (or K and K+1 for 2-by-2 pivot) of A will be */ +/* later overwritten). Interchange rows KK and KP */ +/* in first KK columns of W. */ + + if (k > 1) { + i__1 = k - 1; + zswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + } + zswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k of W now holds */ + +/* W(k) = L(k)*D(k), */ + +/* where L(k) is the k-th column of L */ + +/* (1) Store subdiag. elements of column L(k) */ +/* and 1-by-1 block D(k) in column k of A. */ +/* (NOTE: Diagonal element L(k,k) is a UNIT element */ +/* and not stored) */ +/* A(k,k) := D(k,k) = W(k,k) */ +/* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k) */ + +/* (NOTE: No need to use for Hermitian matrix */ +/* A( K, K ) = DBLE( W( K, K) ) to separately copy diagonal */ +/* element D(k,k) from W (potentially saves only one load)) */ + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + +/* (NOTE: No need to check if A(k,k) is NOT ZERO, */ +/* since that was ensured earlier in pivot search: */ +/* case A(k,k) = 0 falls into 2x2 pivot case(4)) */ + + i__1 = k + k * a_dim1; + r1 = 1. / a[i__1].r; + i__1 = *n - k; + zdscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + +/* (2) Conjugate column W(k) */ + + i__1 = *n - k; + zlacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + } + + } else { + +/* 2-by-2 pivot block D(k): columns k and k+1 of W now hold */ + +/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */ + +/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */ +/* of L */ + +/* (1) Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2 */ +/* block D(k:k+1,k:k+1) in columns k and k+1 of A. */ +/* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT */ +/* block and not stored) */ +/* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1) */ +/* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) = */ +/* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) ) */ + + if (k < *n - 1) { + +/* Factor out the columns of the inverse of 2-by-2 pivot */ +/* block D, so that each column contains 1, to reduce the */ +/* number of FLOPS when we multiply panel */ +/* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1). */ + +/* D**(-1) = ( d11 cj(d21) )**(-1) = */ +/* ( d21 d22 ) */ + +/* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) = */ +/* ( (-d21) ( d11 ) ) */ + +/* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) * */ + +/* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) = */ +/* ( ( -1 ) ( d11/conj(d21) ) ) */ + +/* = 1/(|d21|**2) * 1/(D22*D11-1) * */ + +/* * ( d21*( D11 ) conj(d21)*( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = ( conj(D21)*( D11 ) D21*( -1 ) ) */ +/* ( ( -1 ) ( D22 ) ), */ + +/* where D11 = d22/d21, */ +/* D22 = d11/conj(d21), */ +/* D21 = T/d21, */ +/* T = 1/(D22*D11-1). */ + +/* (NOTE: No need to check for division by ZERO, */ +/* since that was ensured earlier in pivot search: */ +/* (a) d21 != 0, since in 2x2 pivot case(4) */ +/* |d21| should be larger than |d11| and |d22|; */ +/* (b) (D22*D11 - 1) != 0, since from (a), */ +/* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.) */ + + i__1 = k + 1 + k * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + z_div(&z__1, &w[k + 1 + (k + 1) * w_dim1], &d21); + d11.r = z__1.r, d11.i = z__1.i; + d_cnjg(&z__2, &d21); + z_div(&z__1, &w[k + k * w_dim1], &z__2); + d22.r = z__1.r, d22.i = z__1.i; + z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r * + d22.i + d11.i * d22.r; + t = 1. / (z__1.r - 1.); + z__2.r = t, z__2.i = 0.; + z_div(&z__1, &z__2, &d21); + d21.r = z__1.r, d21.i = z__1.i; + +/* Update elements in columns A(k) and A(k+1) as */ +/* dot products of rows of ( W(k) W(k+1) ) and columns */ +/* of D**(-1) */ + + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + d_cnjg(&z__2, &d21); + i__3 = j + k * w_dim1; + z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + (k + 1) * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = + z__2.r * z__3.i + z__2.i * z__3.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + (k + 1) * a_dim1; + i__3 = j + (k + 1) * w_dim1; + z__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__3.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + k * w_dim1; + z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4] + .i; + z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i = + d21.r * z__2.i + d21.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L80: */ + } + } + +/* Copy D(k) to A */ + + i__1 = k + k * a_dim1; + i__2 = k + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + k * a_dim1; + i__2 = k + 1 + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + (k + 1) * a_dim1; + i__2 = k + 1 + (k + 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + +/* (2) Conjugate columns W(k) and W(k+1) */ + + i__1 = *n - k; + zlacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = *n - k - 1; + zlacgv_(&i__1, &w[k + 2 + (k + 1) * w_dim1], &c__1); + + } + + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + goto L70; + +L90: + +/* Update the lower triangle of A22 (= A(k:n,k:n)) as */ + +/* A22 := A22 - L21*D*L21**H = A22 - L21*W**H */ + +/* computing blocks of NB columns at a time (note that conjg(W) is */ +/* actually stored) */ + + i__1 = *n; + i__2 = *nb; + for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = *nb, i__4 = *n - j + 1; + jb = f2cmin(i__3,i__4); + +/* Update the lower triangle of the diagonal block */ + + i__3 = j + jb - 1; + for (jj = j; jj <= i__3; ++jj) { + i__4 = jj + jj * a_dim1; + i__5 = jj + jj * a_dim1; + d__1 = a[i__5].r; + a[i__4].r = d__1, a[i__4].i = 0.; + i__4 = j + jb - jj; + i__5 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__4, &i__5, &z__1, &a[jj + a_dim1], + lda, &w[jj + w_dim1], ldw, &c_b1, &a[jj + jj * a_dim1] + , &c__1); + i__4 = jj + jj * a_dim1; + i__5 = jj + jj * a_dim1; + d__1 = a[i__5].r; + a[i__4].r = d__1, a[i__4].i = 0.; +/* L100: */ + } + +/* Update the rectangular subdiagonal block */ + + if (j + jb <= *n) { + i__3 = *n - j - jb + 1; + i__4 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &z__1, + &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b1, + &a[j + jb + j * a_dim1], lda); + } +/* L110: */ + } + +/* Put L21 in standard form by partially undoing the interchanges */ +/* of rows in columns 1:k-1 looping backwards from k-1 to 1 */ + + j = k - 1; +L120: + +/* Undo the interchanges (if any) of rows JJ and JP at each */ +/* step J */ + +/* (Here, J is a diagonal index) */ + jj = j; + jp = ipiv[j]; + if (jp < 0) { + jp = -jp; +/* (Here, J is a diagonal index) */ + --j; + } +/* (NOTE: Here, J is used to determine row length. Length J */ +/* of the rows to swap back doesn't include diagonal element) */ + --j; + if (jp != jj && j >= 1) { + zswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda); + } + if (j > 1) { + goto L120; + } + +/* Set KB to the number of columns factorized */ + + *kb = k - 1; + + } + return 0; + +/* End of ZLAHEF */ + +} /* zlahef_ */ + diff --git a/lapack-netlib/SRC/zlahef_aa.c b/lapack-netlib/SRC/zlahef_aa.c new file mode 100644 index 000000000..b8a6319d4 --- /dev/null +++ b/lapack-netlib/SRC/zlahef_aa.c @@ -0,0 +1,984 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAHEF_AA */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAHEF_AA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAHEF_AA( UPLO, J1, M, NB, A, LDA, IPIV, */ +/* H, LDH, WORK ) */ + +/* CHARACTER UPLO */ +/* INTEGER J1, M, NB, LDA, LDH */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), H( LDH, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLAHEF_AA factorizes a panel of a complex hermitian matrix A using */ +/* > the Aasen's algorithm. The panel consists of a set of NB rows of A */ +/* > when UPLO is U, or a set of NB columns when UPLO is L. */ +/* > */ +/* > In order to factorize the panel, the Aasen's algorithm requires the */ +/* > last row, or column, of the previous panel. The first row, or column, */ +/* > of A is set to be the first row, or column, of an identity matrix, */ +/* > which is used to factorize the first panel. */ +/* > */ +/* > The resulting J-th row of U, or J-th column of L, is stored in the */ +/* > (J-1)-th row, or column, of A (without the unit diagonals), while */ +/* > the diagonal and subdiagonal of A are overwritten by those of 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] J1 */ +/* > \verbatim */ +/* > J1 is INTEGER */ +/* > The location of the first row, or column, of the panel */ +/* > within the submatrix of A, passed to this routine, e.g., */ +/* > when called by ZHETRF_AA, for the first panel, J1 is 1, */ +/* > while for the remaining panels, J1 is 2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The dimension of the submatrix. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The dimension of the panel to be facotorized. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,M) for */ +/* > the first panel, while dimension (LDA,M+1) for the */ +/* > remaining panels. */ +/* > */ +/* > On entry, A contains the last row, or column, of */ +/* > the previous panel, and the trailing submatrix of A */ +/* > to be factorized, except for the first panel, only */ +/* > the panel is passed. */ +/* > */ +/* > On exit, the leading panel is factorized. */ +/* > \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 row and column interchanges, */ +/* > the row and column k were interchanged with the row and */ +/* > column IPIV(k). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] H */ +/* > \verbatim */ +/* > H is COMPLEX*16 workspace, dimension (LDH,NB). */ +/* > */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > The leading dimension of the workspace H. LDH >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 workspace, dimension (M). */ +/* > \endverbatim */ +/* > */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup complex16HEcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zlahef_aa_(char *uplo, integer *j1, integer *m, integer + *nb, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex * + h__, integer *ldh, doublecomplex *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, h_dim1, h_offset, i__1, i__2; + doublereal d__1; + doublecomplex z__1, z__2; + + /* Local variables */ + integer j, k; + doublecomplex alpha; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *), zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + integer i1, k1, i2; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zswap_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *), zaxpy_(integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *); + integer mj; + extern /* Subroutine */ int zlacgv_(integer *, doublecomplex *, integer *) + ; + extern integer izamax_(integer *, doublecomplex *, integer *); + extern /* Subroutine */ int zlaset_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *); + doublecomplex piv; + + +/* -- 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; + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + --work; + + /* Function Body */ + j = 1; + +/* K1 is the first column of the panel to be factorized */ +/* i.e., K1 is 2 for the first block column, and 1 for the rest of the blocks */ + + k1 = 2 - *j1 + 1; + + if (lsame_(uplo, "U")) { + +/* ..................................................... */ +/* Factorize A as U**T*D*U using the upper triangle of A */ +/* ..................................................... */ + +L10: + if (j > f2cmin(*m,*nb)) { + goto L20; + } + +/* K is the column to be factorized */ +/* when being called from ZHETRF_AA, */ +/* > for the first block column, J1 is 1, hence J1+J-1 is J, */ +/* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, */ + + k = *j1 + j - 1; + if (j == *m) { + +/* Only need to compute T(J, J) */ + + mj = 1; + } else { + mj = *m - j + 1; + } + +/* H(J:N, J) := A(J, J:N) - H(J:N, 1:(J-1)) * L(J1:(J-1), J), */ +/* where H(J:N, J) has been initialized to be A(J, J:N) */ + + if (k > 2) { + +/* K is the column to be factorized */ +/* > for the first block column, K is J, skipping the first two */ +/* columns */ +/* > for the rest of the columns, K is J+1, skipping only the */ +/* first column */ + + i__1 = j - k1; + zlacgv_(&i__1, &a[j * a_dim1 + 1], &c__1); + i__1 = j - k1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &mj, &i__1, &z__1, &h__[j + k1 * h_dim1], + ldh, &a[j * a_dim1 + 1], &c__1, &c_b2, &h__[j + j * + h_dim1], &c__1); + i__1 = j - k1; + zlacgv_(&i__1, &a[j * a_dim1 + 1], &c__1); + } + +/* Copy H(i:n, i) into WORK */ + + zcopy_(&mj, &h__[j + j * h_dim1], &c__1, &work[1], &c__1); + + if (j > k1) { + +/* Compute WORK := WORK - L(J-1, J:N) * T(J-1,J), */ +/* where A(J-1, J) stores T(J-1, J) and A(J-2, J:N) stores U(J-1, J:N) */ + + d_cnjg(&z__2, &a[k - 1 + j * a_dim1]); + z__1.r = -z__2.r, z__1.i = -z__2.i; + alpha.r = z__1.r, alpha.i = z__1.i; + zaxpy_(&mj, &alpha, &a[k - 2 + j * a_dim1], lda, &work[1], &c__1); + } + +/* Set A(J, J) = T(J, J) */ + + i__1 = k + j * a_dim1; + d__1 = work[1].r; + a[i__1].r = d__1, a[i__1].i = 0.; + + if (j < *m) { + +/* Compute WORK(2:N) = T(J, J) L(J, (J+1):N) */ +/* where A(J, J) stores T(J, J) and A(J-1, (J+1):N) stores U(J, (J+1):N) */ + + if (k > 1) { + i__1 = k + j * a_dim1; + z__1.r = -a[i__1].r, z__1.i = -a[i__1].i; + alpha.r = z__1.r, alpha.i = z__1.i; + i__1 = *m - j; + zaxpy_(&i__1, &alpha, &a[k - 1 + (j + 1) * a_dim1], lda, & + work[2], &c__1); + } + +/* Find f2cmax(|WORK(2:n)|) */ + + i__1 = *m - j; + i2 = izamax_(&i__1, &work[2], &c__1) + 1; + i__1 = i2; + piv.r = work[i__1].r, piv.i = work[i__1].i; + +/* Apply hermitian pivot */ + + if (i2 != 2 && (piv.r != 0. || piv.i != 0.)) { + +/* Swap WORK(I1) and WORK(I2) */ + + i1 = 2; + i__1 = i2; + i__2 = i1; + work[i__1].r = work[i__2].r, work[i__1].i = work[i__2].i; + i__1 = i1; + work[i__1].r = piv.r, work[i__1].i = piv.i; + +/* Swap A(I1, I1+1:N) with A(I1+1:N, I2) */ + + i1 = i1 + j - 1; + i2 = i2 + j - 1; + i__1 = i2 - i1 - 1; + zswap_(&i__1, &a[*j1 + i1 - 1 + (i1 + 1) * a_dim1], lda, &a[* + j1 + i1 + i2 * a_dim1], &c__1); + i__1 = i2 - i1; + zlacgv_(&i__1, &a[*j1 + i1 - 1 + (i1 + 1) * a_dim1], lda); + i__1 = i2 - i1 - 1; + zlacgv_(&i__1, &a[*j1 + i1 + i2 * a_dim1], &c__1); + +/* Swap A(I1, I2+1:N) with A(I2, I2+1:N) */ + + if (i2 < *m) { + i__1 = *m - i2; + zswap_(&i__1, &a[*j1 + i1 - 1 + (i2 + 1) * a_dim1], lda, & + a[*j1 + i2 - 1 + (i2 + 1) * a_dim1], lda); + } + +/* Swap A(I1, I1) with A(I2,I2) */ + + i__1 = i1 + *j1 - 1 + i1 * a_dim1; + piv.r = a[i__1].r, piv.i = a[i__1].i; + i__1 = *j1 + i1 - 1 + i1 * a_dim1; + i__2 = *j1 + i2 - 1 + i2 * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = *j1 + i2 - 1 + i2 * a_dim1; + a[i__1].r = piv.r, a[i__1].i = piv.i; + +/* Swap H(I1, 1:J1) with H(I2, 1:J1) */ + + i__1 = i1 - 1; + zswap_(&i__1, &h__[i1 + h_dim1], ldh, &h__[i2 + h_dim1], ldh); + ipiv[i1] = i2; + + if (i1 > k1 - 1) { + +/* Swap L(1:I1-1, I1) with L(1:I1-1, I2), */ +/* skipping the first column */ + + i__1 = i1 - k1 + 1; + zswap_(&i__1, &a[i1 * a_dim1 + 1], &c__1, &a[i2 * a_dim1 + + 1], &c__1); + } + } else { + ipiv[j + 1] = j + 1; + } + +/* Set A(J, J+1) = T(J, J+1) */ + + i__1 = k + (j + 1) * a_dim1; + a[i__1].r = work[2].r, a[i__1].i = work[2].i; + + if (j < *nb) { + +/* Copy A(J+1:N, J+1) into H(J:N, J), */ + + i__1 = *m - j; + zcopy_(&i__1, &a[k + 1 + (j + 1) * a_dim1], lda, &h__[j + 1 + + (j + 1) * h_dim1], &c__1); + } + +/* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), */ +/* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) */ + + if (j < *m - 1) { + i__1 = k + (j + 1) * a_dim1; + if (a[i__1].r != 0. || a[i__1].i != 0.) { + z_div(&z__1, &c_b2, &a[k + (j + 1) * a_dim1]); + alpha.r = z__1.r, alpha.i = z__1.i; + i__1 = *m - j - 1; + zcopy_(&i__1, &work[3], &c__1, &a[k + (j + 2) * a_dim1], + lda); + i__1 = *m - j - 1; + zscal_(&i__1, &alpha, &a[k + (j + 2) * a_dim1], lda); + } else { + i__1 = *m - j - 1; + zlaset_("Full", &c__1, &i__1, &c_b1, &c_b1, &a[k + (j + 2) + * a_dim1], lda); + } + } + } + ++j; + goto L10; +L20: + + ; + } else { + +/* ..................................................... */ +/* Factorize A as L*D*L**T using the lower triangle of A */ +/* ..................................................... */ + +L30: + if (j > f2cmin(*m,*nb)) { + goto L40; + } + +/* K is the column to be factorized */ +/* when being called from ZHETRF_AA, */ +/* > for the first block column, J1 is 1, hence J1+J-1 is J, */ +/* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, */ + + k = *j1 + j - 1; + if (j == *m) { + +/* Only need to compute T(J, J) */ + + mj = 1; + } else { + mj = *m - j + 1; + } + +/* H(J:N, J) := A(J:N, J) - H(J:N, 1:(J-1)) * L(J, J1:(J-1))^T, */ +/* where H(J:N, J) has been initialized to be A(J:N, J) */ + + if (k > 2) { + +/* K is the column to be factorized */ +/* > for the first block column, K is J, skipping the first two */ +/* columns */ +/* > for the rest of the columns, K is J+1, skipping only the */ +/* first column */ + + i__1 = j - k1; + zlacgv_(&i__1, &a[j + a_dim1], lda); + i__1 = j - k1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &mj, &i__1, &z__1, &h__[j + k1 * h_dim1], + ldh, &a[j + a_dim1], lda, &c_b2, &h__[j + j * h_dim1], & + c__1); + i__1 = j - k1; + zlacgv_(&i__1, &a[j + a_dim1], lda); + } + +/* Copy H(J:N, J) into WORK */ + + zcopy_(&mj, &h__[j + j * h_dim1], &c__1, &work[1], &c__1); + + if (j > k1) { + +/* Compute WORK := WORK - L(J:N, J-1) * T(J-1,J), */ +/* where A(J-1, J) = T(J-1, J) and A(J, J-2) = L(J, J-1) */ + + d_cnjg(&z__2, &a[j + (k - 1) * a_dim1]); + z__1.r = -z__2.r, z__1.i = -z__2.i; + alpha.r = z__1.r, alpha.i = z__1.i; + zaxpy_(&mj, &alpha, &a[j + (k - 2) * a_dim1], &c__1, &work[1], & + c__1); + } + +/* Set A(J, J) = T(J, J) */ + + i__1 = j + k * a_dim1; + d__1 = work[1].r; + a[i__1].r = d__1, a[i__1].i = 0.; + + if (j < *m) { + +/* Compute WORK(2:N) = T(J, J) L((J+1):N, J) */ +/* where A(J, J) = T(J, J) and A((J+1):N, J-1) = L((J+1):N, J) */ + + if (k > 1) { + i__1 = j + k * a_dim1; + z__1.r = -a[i__1].r, z__1.i = -a[i__1].i; + alpha.r = z__1.r, alpha.i = z__1.i; + i__1 = *m - j; + zaxpy_(&i__1, &alpha, &a[j + 1 + (k - 1) * a_dim1], &c__1, & + work[2], &c__1); + } + +/* Find f2cmax(|WORK(2:n)|) */ + + i__1 = *m - j; + i2 = izamax_(&i__1, &work[2], &c__1) + 1; + i__1 = i2; + piv.r = work[i__1].r, piv.i = work[i__1].i; + +/* Apply hermitian pivot */ + + if (i2 != 2 && (piv.r != 0. || piv.i != 0.)) { + +/* Swap WORK(I1) and WORK(I2) */ + + i1 = 2; + i__1 = i2; + i__2 = i1; + work[i__1].r = work[i__2].r, work[i__1].i = work[i__2].i; + i__1 = i1; + work[i__1].r = piv.r, work[i__1].i = piv.i; + +/* Swap A(I1+1:N, I1) with A(I2, I1+1:N) */ + + i1 = i1 + j - 1; + i2 = i2 + j - 1; + i__1 = i2 - i1 - 1; + zswap_(&i__1, &a[i1 + 1 + (*j1 + i1 - 1) * a_dim1], &c__1, &a[ + i2 + (*j1 + i1) * a_dim1], lda); + i__1 = i2 - i1; + zlacgv_(&i__1, &a[i1 + 1 + (*j1 + i1 - 1) * a_dim1], &c__1); + i__1 = i2 - i1 - 1; + zlacgv_(&i__1, &a[i2 + (*j1 + i1) * a_dim1], lda); + +/* Swap A(I2+1:N, I1) with A(I2+1:N, I2) */ + + if (i2 < *m) { + i__1 = *m - i2; + zswap_(&i__1, &a[i2 + 1 + (*j1 + i1 - 1) * a_dim1], &c__1, + &a[i2 + 1 + (*j1 + i2 - 1) * a_dim1], &c__1); + } + +/* Swap A(I1, I1) with A(I2, I2) */ + + i__1 = i1 + (*j1 + i1 - 1) * a_dim1; + piv.r = a[i__1].r, piv.i = a[i__1].i; + i__1 = i1 + (*j1 + i1 - 1) * a_dim1; + i__2 = i2 + (*j1 + i2 - 1) * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = i2 + (*j1 + i2 - 1) * a_dim1; + a[i__1].r = piv.r, a[i__1].i = piv.i; + +/* Swap H(I1, I1:J1) with H(I2, I2:J1) */ + + i__1 = i1 - 1; + zswap_(&i__1, &h__[i1 + h_dim1], ldh, &h__[i2 + h_dim1], ldh); + ipiv[i1] = i2; + + if (i1 > k1 - 1) { + +/* Swap L(1:I1-1, I1) with L(1:I1-1, I2), */ +/* skipping the first column */ + + i__1 = i1 - k1 + 1; + zswap_(&i__1, &a[i1 + a_dim1], lda, &a[i2 + a_dim1], lda); + } + } else { + ipiv[j + 1] = j + 1; + } + +/* Set A(J+1, J) = T(J+1, J) */ + + i__1 = j + 1 + k * a_dim1; + a[i__1].r = work[2].r, a[i__1].i = work[2].i; + + if (j < *nb) { + +/* Copy A(J+1:N, J+1) into H(J+1:N, J), */ + + i__1 = *m - j; + zcopy_(&i__1, &a[j + 1 + (k + 1) * a_dim1], &c__1, &h__[j + 1 + + (j + 1) * h_dim1], &c__1); + } + +/* Compute L(J+2, J+1) = WORK( 3:N ) / T(J, J+1), */ +/* where A(J, J+1) = T(J, J+1) and A(J+2:N, J) = L(J+2:N, J+1) */ + + if (j < *m - 1) { + i__1 = j + 1 + k * a_dim1; + if (a[i__1].r != 0. || a[i__1].i != 0.) { + z_div(&z__1, &c_b2, &a[j + 1 + k * a_dim1]); + alpha.r = z__1.r, alpha.i = z__1.i; + i__1 = *m - j - 1; + zcopy_(&i__1, &work[3], &c__1, &a[j + 2 + k * a_dim1], & + c__1); + i__1 = *m - j - 1; + zscal_(&i__1, &alpha, &a[j + 2 + k * a_dim1], &c__1); + } else { + i__1 = *m - j - 1; + zlaset_("Full", &i__1, &c__1, &c_b1, &c_b1, &a[j + 2 + k * + a_dim1], lda); + } + } + } + ++j; + goto L30; +L40: + ; + } + return 0; + +/* End of ZLAHEF_AA */ + +} /* zlahef_aa__ */ + diff --git a/lapack-netlib/SRC/zlahef_rk.c b/lapack-netlib/SRC/zlahef_rk.c new file mode 100644 index 000000000..19f4df981 --- /dev/null +++ b/lapack-netlib/SRC/zlahef_rk.c @@ -0,0 +1,1914 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAHEF_RK computes a partial factorization of a complex Hermitian indefinite matrix using bound +ed Bunch-Kaufman (rook) diagonal pivoting method. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAHEF_RK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAHEF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, */ +/* INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, KB, LDA, LDW, N, NB */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), E( * ), W( LDW, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > ZLAHEF_RK computes a partial factorization of a complex Hermitian */ +/* > matrix A using the bounded Bunch-Kaufman (rook) diagonal */ +/* > pivoting method. The partial factorization has the form: */ +/* > */ +/* > A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: */ +/* > ( 0 U22 ) ( 0 D ) ( U12**H U22**H ) */ +/* > */ +/* > A = ( L11 0 ) ( D 0 ) ( L11**H L21**H ) if UPLO = 'L', */ +/* > ( L21 I ) ( 0 A22 ) ( 0 I ) */ +/* > */ +/* > where the order of D is at most NB. The actual order is returned in */ +/* > the argument KB, and is either NB or NB-1, or N if N <= NB. */ +/* > */ +/* > ZLAHEF_RK is an auxiliary routine called by ZHETRF_RK. It uses */ +/* > blocked code (calling Level 3 BLAS) to update the submatrix */ +/* > A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > Hermitian 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] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The maximum number of columns of the matrix A that should be */ +/* > factored. NB should be at least 2 to allow for 2-by-2 pivot */ +/* > blocks. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] KB */ +/* > \verbatim */ +/* > KB is INTEGER */ +/* > The number of columns of A that were actually factored. */ +/* > KB is either NB-1 or NB, or N if N <= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the Hermitian 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 Hermitian 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 COMPLEX*16 array, dimension (N) */ +/* > On exit, contains the superdiagonal (or subdiagonal) */ +/* > elements of the Hermitian 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 Hermitian 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. */ +/* > */ +/* > 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 submatrix A(1:N,N-KB+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,N-KB+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 submatrix A(1:N,N-KB+1:N). */ +/* > If -IPIV(k-1) = k-1, no interchange occurred. */ +/* > */ +/* > c) In both cases a) and b) is 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 submatrix A(1:N,1:KB). */ +/* > 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 submatrix A(1:N,1:KB). */ +/* > 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 submatrix A(1:N,1:KB). */ +/* > If -IPIV(k+1) = k+1, no interchange occurred. */ +/* > */ +/* > c) In both cases a) and b) is always ABS( IPIV(k) ) >= k. */ +/* > */ +/* > d) NOTE: Any entry IPIV(k) is always NONZERO on output. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is COMPLEX*16 array, dimension (LDW,NB) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDW */ +/* > \verbatim */ +/* > LDW is INTEGER */ +/* > The leading dimension of the array W. LDW >= f2cmax(1,N). */ +/* > \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 complex16HEcomputational */ + +/* > \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 zlahef_rk_(char *uplo, integer *n, integer *nb, integer + *kb, doublecomplex *a, integer *lda, doublecomplex *e, integer *ipiv, + doublecomplex *w, integer *ldw, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5; + doublereal d__1, d__2; + doublecomplex z__1, z__2, z__3, z__4, z__5; + + /* Local variables */ + logical done; + integer imax, jmax, j, k, p; + doublereal t, alpha; + extern logical lsame_(char *, char *); + doublereal dtemp, sfmin; + integer itemp; + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + integer kstep; + extern /* Subroutine */ int zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + doublereal r1; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zswap_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *); + doublecomplex d11, d21, d22; + integer jb, ii, jj, kk; + extern doublereal dlamch_(char *); + integer kp; + doublereal absakk; + integer kw; + extern /* Subroutine */ int zdscal_(integer *, doublereal *, + doublecomplex *, integer *); + doublereal colmax; + extern /* Subroutine */ int zlacgv_(integer *, doublecomplex *, integer *) + ; + extern integer izamax_(integer *, doublecomplex *, integer *); + doublereal rowmax; + integer kkw; + + +/* -- 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; + --e; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1 * 1; + w -= w_offset; + + /* Function Body */ + *info = 0; + +/* Initialize ALPHA for use in choosing pivot block size. */ + + alpha = (sqrt(17.) + 1.) / 8.; + +/* Compute machine safe minimum */ + + sfmin = dlamch_("S"); + + if (lsame_(uplo, "U")) { + +/* Factorize the trailing columns of A using the upper triangle */ +/* of A and working backwards, and compute the matrix W = U12*D */ +/* for use in updating A11 (note that conjg(W) is actually stored) */ +/* Initialize the first entry of array E, where superdiagonal */ +/* elements of D are stored */ + + e[1].r = 0., e[1].i = 0.; + +/* K is the main loop index, decreasing from N in steps of 1 or 2 */ + + k = *n; +L10: + +/* KW is the column of W which corresponds to column K of A */ + + kw = *nb + k - *n; + +/* Exit from loop */ + + if (k <= *n - *nb + 1 && *nb < *n || k < 1) { + goto L30; + } + + kstep = 1; + p = k; + +/* Copy column K of A to column KW of W and update it */ + + if (k > 1) { + i__1 = k - 1; + zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], & + c__1); + } + i__1 = k + kw * w_dim1; + i__2 = k + k * a_dim1; + d__1 = a[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + if (k < *n) { + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * + w_dim1 + 1], &c__1); + i__1 = k + kw * w_dim1; + i__2 = k + kw * w_dim1; + d__1 = w[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + } + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = k + kw * w_dim1; + absakk = (d__1 = w[i__1].r, abs(d__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k > 1) { + i__1 = k - 1; + imax = izamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = imax + kw * w_dim1; + colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + kw * w_dim1]), abs(d__2)); + } else { + colmax = 0.; + } + + if (f2cmax(absakk,colmax) == 0.) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = k + k * a_dim1; + i__2 = k + kw * w_dim1; + d__1 = w[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + if (k > 1) { + i__1 = k - 1; + zcopy_(&i__1, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], + &c__1); + } + +/* Set E( K ) to zero */ + + if (k > 1) { + i__1 = k; + e[i__1].r = 0., e[i__1].i = 0.; + } + + } else { + +/* ============================================================ */ + +/* BEGIN pivot search */ + +/* Case(1) */ +/* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX */ +/* (used to handle NaN and Inf) */ + if (! (absakk < alpha * colmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + + } else { + +/* Lop until pivot found */ + + done = FALSE_; + +L12: + +/* BEGIN pivot search loop body */ + + +/* Copy column IMAX to column KW-1 of W and update it */ + + if (imax > 1) { + i__1 = imax - 1; + zcopy_(&i__1, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + } + i__1 = imax + (kw - 1) * w_dim1; + i__2 = imax + imax * a_dim1; + d__1 = a[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + + i__1 = k - imax; + zcopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + i__1 = k - imax; + zlacgv_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], &c__1); + + if (k < *n) { + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1); + i__1 = imax + (kw - 1) * w_dim1; + i__2 = imax + (kw - 1) * w_dim1; + d__1 = w[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + } + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine both ROWMAX and JMAX. */ + + if (imax != k) { + i__1 = k - imax; + jmax = imax + izamax_(&i__1, &w[imax + 1 + (kw - 1) * + w_dim1], &c__1); + i__1 = jmax + (kw - 1) * w_dim1; + rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(& + w[jmax + (kw - 1) * w_dim1]), abs(d__2)); + } else { + rowmax = 0.; + } + + if (imax > 1) { + i__1 = imax - 1; + itemp = izamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); + i__1 = itemp + (kw - 1) * w_dim1; + dtemp = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + itemp + (kw - 1) * w_dim1]), abs(d__2)); + if (dtemp > rowmax) { + rowmax = dtemp; + jmax = itemp; + } + } + +/* Case(2) */ +/* Equivalent to testing for */ +/* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX */ +/* (used to handle NaN and Inf) */ + + i__1 = imax + (kw - 1) * w_dim1; + if (! ((d__1 = w[i__1].r, abs(d__1)) < alpha * rowmax)) { + +/* interchange rows and columns K and IMAX, */ +/* use 1-by-1 pivot block */ + + kp = imax; + +/* copy column KW-1 of W to column KW of W */ + + zcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + + done = TRUE_; + +/* Case(3) */ +/* Equivalent to testing for ROWMAX.EQ.COLMAX, */ +/* (used to handle NaN and Inf) */ + + } else if (p == jmax || rowmax <= colmax) { + +/* interchange rows and columns K-1 and IMAX, */ +/* use 2-by-2 pivot block */ + + kp = imax; + kstep = 2; + done = TRUE_; + +/* Case(4) */ + } else { + +/* Pivot not found: set params and repeat */ + + p = imax; + colmax = rowmax; + imax = jmax; + +/* Copy updated JMAXth (next IMAXth) column to Kth of W */ + + zcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + + } + + +/* END pivot search loop body */ + + if (! done) { + goto L12; + } + + } + +/* END pivot search */ + +/* ============================================================ */ + +/* KK is the column of A where pivoting step stopped */ + + kk = k - kstep + 1; + +/* KKW is the column of W which corresponds to column KK of A */ + + kkw = *nb + kk - *n; + +/* Interchange rows and columns P and K. */ +/* Updated column P is already stored in column KW of W. */ + + if (kstep == 2 && p != k) { + +/* Copy non-updated column K to column P of submatrix A */ +/* at step K. No need to copy element into columns */ +/* K and K-1 of A for 2-by-2 pivot, since these columns */ +/* will be later overwritten. */ + + i__1 = p + p * a_dim1; + i__2 = k + k * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = k - 1 - p; + zcopy_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + (p + 1) * + a_dim1], lda); + i__1 = k - 1 - p; + zlacgv_(&i__1, &a[p + (p + 1) * a_dim1], lda); + if (p > 1) { + i__1 = p - 1; + zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[p * a_dim1 + + 1], &c__1); + } + +/* Interchange rows K and P in the last K+1 to N columns of A */ +/* (columns K and K-1 of A for 2-by-2 pivot will be */ +/* later overwritten). Interchange rows K and P */ +/* in last KKW to NB columns of W. */ + + if (k < *n) { + i__1 = *n - k; + zswap_(&i__1, &a[k + (k + 1) * a_dim1], lda, &a[p + (k + + 1) * a_dim1], lda); + } + i__1 = *n - kk + 1; + zswap_(&i__1, &w[k + kkw * w_dim1], ldw, &w[p + kkw * w_dim1], + ldw); + } + +/* Interchange rows and columns KP and KK. */ +/* Updated column KP is already stored in column KKW of W. */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP of submatrix A */ +/* at step K. No need to copy element into column K */ +/* (or K and K-1 for 2-by-2 pivot) of A, since these columns */ +/* will be later overwritten. */ + + i__1 = kp + kp * a_dim1; + i__2 = kk + kk * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = kk - 1 - kp; + zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + i__1 = kk - 1 - kp; + zlacgv_(&i__1, &a[kp + (kp + 1) * a_dim1], lda); + if (kp > 1) { + i__1 = kp - 1; + zcopy_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + +/* Interchange rows KK and KP in last K+1 to N columns of A */ +/* (columns K (or K and K-1 for 2-by-2 pivot) of A will be */ +/* later overwritten). Interchange rows KK and KP */ +/* in last KKW to NB columns of W. */ + + if (k < *n) { + i__1 = *n - k; + zswap_(&i__1, &a[kk + (k + 1) * a_dim1], lda, &a[kp + (k + + 1) * a_dim1], lda); + } + i__1 = *n - kk + 1; + zswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column kw of W now holds */ + +/* W(kw) = U(k)*D(k), */ + +/* where U(k) is the k-th column of U */ + +/* (1) Store subdiag. elements of column U(k) */ +/* and 1-by-1 block D(k) in column k of A. */ +/* (NOTE: Diagonal element U(k,k) is a UNIT element */ +/* and not stored) */ +/* A(k,k) := D(k,k) = W(k,kw) */ +/* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k) */ + +/* (NOTE: No need to use for Hermitian matrix */ +/* A( K, K ) = REAL( W( K, K) ) to separately copy diagonal */ +/* element D(k,k) from W (potentially saves only one load)) */ + zcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + if (k > 1) { + +/* (NOTE: No need to check if A(k,k) is NOT ZERO, */ +/* since that was ensured earlier in pivot search: */ +/* case A(k,k) = 0 falls into 2x2 pivot case(3)) */ + +/* Handle division by a small number */ + + i__1 = k + k * a_dim1; + t = a[i__1].r; + if (abs(t) >= sfmin) { + r1 = 1. / t; + i__1 = k - 1; + zdscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + } else { + i__1 = k - 1; + for (ii = 1; ii <= i__1; ++ii) { + i__2 = ii + k * a_dim1; + i__3 = ii + k * a_dim1; + z__1.r = a[i__3].r / t, z__1.i = a[i__3].i / t; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L14: */ + } + } + +/* (2) Conjugate column W(kw) */ + + i__1 = k - 1; + zlacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1); + +/* Store the superdiagonal element of D in array E */ + + i__1 = k; + e[i__1].r = 0., e[i__1].i = 0.; + + } + + } else { + +/* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold */ + +/* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k) */ + +/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ +/* of U */ + +/* (1) Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2 */ +/* block D(k-1:k,k-1:k) in columns k-1 and k of A. */ +/* (NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT */ +/* block and not stored) */ +/* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw) */ +/* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) = */ +/* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) ) */ + + if (k > 2) { + +/* Factor out the columns of the inverse of 2-by-2 pivot */ +/* block D, so that each column contains 1, to reduce the */ +/* number of FLOPS when we multiply panel */ +/* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1). */ + +/* D**(-1) = ( d11 cj(d21) )**(-1) = */ +/* ( d21 d22 ) */ + +/* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) = */ +/* ( (-d21) ( d11 ) ) */ + +/* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) * */ + +/* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) = */ +/* ( ( -1 ) ( d11/conj(d21) ) ) */ + +/* = 1/(|d21|**2) * 1/(D22*D11-1) * */ + +/* * ( d21*( D11 ) conj(d21)*( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* Handle division by a small number. (NOTE: order of */ +/* operations is important) */ + +/* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) ) */ +/* ( (( -1 ) ) (( D22 ) ) ), */ + +/* where D11 = d22/d21, */ +/* D22 = d11/conj(d21), */ +/* D21 = d21, */ +/* T = 1/(D22*D11-1). */ + +/* (NOTE: No need to check for division by ZERO, */ +/* since that was ensured earlier in pivot search: */ +/* (a) d21 != 0 in 2x2 pivot case(4), */ +/* since |d21| should be larger than |d11| and |d22|; */ +/* (b) (D22*D11 - 1) != 0, since from (a), */ +/* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.) */ + + i__1 = k - 1 + kw * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + d_cnjg(&z__2, &d21); + z_div(&z__1, &w[k + kw * w_dim1], &z__2); + d11.r = z__1.r, d11.i = z__1.i; + z_div(&z__1, &w[k - 1 + (kw - 1) * w_dim1], &d21); + d22.r = z__1.r, d22.i = z__1.i; + z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r * + d22.i + d11.i * d22.r; + t = 1. / (z__1.r - 1.); + +/* Update elements in columns A(k-1) and A(k) as */ +/* dot products of rows of ( W(kw-1) W(kw) ) and columns */ +/* of D**(-1) */ + + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + i__2 = j + (k - 1) * a_dim1; + i__3 = j + (kw - 1) * w_dim1; + z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + kw * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + z_div(&z__2, &z__3, &d21); + z__1.r = t * z__2.r, z__1.i = t * z__2.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + k * a_dim1; + i__3 = j + kw * w_dim1; + z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + (kw - 1) * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + d_cnjg(&z__5, &d21); + z_div(&z__2, &z__3, &z__5); + z__1.r = t * z__2.r, z__1.i = t * z__2.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L20: */ + } + } + +/* Copy diagonal elements of D(K) to A, */ +/* copy superdiagonal element of D(K) to E(K) and */ +/* ZERO out superdiagonal entry of A */ + + i__1 = k - 1 + (k - 1) * a_dim1; + i__2 = k - 1 + (kw - 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k - 1 + k * a_dim1; + a[i__1].r = 0., a[i__1].i = 0.; + i__1 = k + k * a_dim1; + i__2 = k + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k; + i__2 = k - 1 + kw * w_dim1; + e[i__1].r = w[i__2].r, e[i__1].i = w[i__2].i; + i__1 = k - 1; + e[i__1].r = 0., e[i__1].i = 0.; + +/* (2) Conjugate columns W(kw) and W(kw-1) */ + + i__1 = k - 1; + zlacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = k - 2; + zlacgv_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); + + } + +/* End column K is nonsingular */ + + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + goto L10; + +L30: + +/* Update the upper triangle of A11 (= A(1:k,1:k)) as */ + +/* A11 := A11 - U12*D*U12**H = A11 - U12*W**H */ + +/* computing blocks of NB columns at a time (note that conjg(W) is */ +/* actually stored) */ + + i__1 = -(*nb); + for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += + i__1) { +/* Computing MIN */ + i__2 = *nb, i__3 = k - j + 1; + jb = f2cmin(i__2,i__3); + +/* Update the upper triangle of the diagonal block */ + + i__2 = j + jb - 1; + for (jj = j; jj <= i__2; ++jj) { + i__3 = jj + jj * a_dim1; + i__4 = jj + jj * a_dim1; + d__1 = a[i__4].r; + a[i__3].r = d__1, a[i__3].i = 0.; + i__3 = jj - j + 1; + i__4 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__3, &i__4, &z__1, &a[j + (k + 1) * + a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b1, + &a[j + jj * a_dim1], &c__1); + i__3 = jj + jj * a_dim1; + i__4 = jj + jj * a_dim1; + d__1 = a[i__4].r; + a[i__3].r = d__1, a[i__3].i = 0.; +/* L40: */ + } + +/* Update the rectangular superdiagonal block */ + + if (j >= 2) { + i__2 = j - 1; + i__3 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &z__1, + &a[(k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * + w_dim1], ldw, &c_b1, &a[j * a_dim1 + 1], lda); + } +/* L50: */ + } + +/* Set KB to the number of columns factorized */ + + *kb = *n - k; + + } else { + +/* Factorize the leading columns of A using the lower triangle */ +/* of A and working forwards, and compute the matrix W = L21*D */ +/* for use in updating A22 (note that conjg(W) is actually stored) */ + +/* Initialize the unused last entry of the subdiagonal array E. */ + + i__1 = *n; + e[i__1].r = 0., e[i__1].i = 0.; + +/* K is the main loop index, increasing from 1 in steps of 1 or 2 */ + + k = 1; +L70: + +/* Exit from loop */ + + if (k >= *nb && *nb < *n || k > *n) { + goto L90; + } + + kstep = 1; + p = k; + +/* Copy column K of A to column K of W and update column K of W */ + + i__1 = k + k * w_dim1; + i__2 = k + k * a_dim1; + d__1 = a[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + if (k < *n) { + i__1 = *n - k; + zcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &w[k + 1 + k * + w_dim1], &c__1); + } + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], lda, & + w[k + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1); + i__1 = k + k * w_dim1; + i__2 = k + k * w_dim1; + d__1 = w[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + } + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = k + k * w_dim1; + absakk = (d__1 = w[i__1].r, abs(d__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k < *n) { + i__1 = *n - k; + imax = k + izamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = imax + k * w_dim1; + colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + k * w_dim1]), abs(d__2)); + } else { + colmax = 0.; + } + + if (f2cmax(absakk,colmax) == 0.) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = k + k * a_dim1; + i__2 = k + k * w_dim1; + d__1 = w[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + if (k < *n) { + i__1 = *n - k; + zcopy_(&i__1, &w[k + 1 + k * w_dim1], &c__1, &a[k + 1 + k * + a_dim1], &c__1); + } + +/* Set E( K ) to zero */ + + if (k < *n) { + i__1 = k; + e[i__1].r = 0., e[i__1].i = 0.; + } + + } else { + +/* ============================================================ */ + +/* BEGIN pivot search */ + +/* Case(1) */ +/* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX */ +/* (used to handle NaN and Inf) */ + + if (! (absakk < alpha * colmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + + } else { + + done = FALSE_; + +/* Loop until pivot found */ + +L72: + +/* BEGIN pivot search loop body */ + + +/* Copy column IMAX to column k+1 of W and update it */ + + i__1 = imax - k; + zcopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = imax - k; + zlacgv_(&i__1, &w[k + (k + 1) * w_dim1], &c__1); + i__1 = imax + (k + 1) * w_dim1; + i__2 = imax + imax * a_dim1; + d__1 = a[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + + if (imax < *n) { + i__1 = *n - imax; + zcopy_(&i__1, &a[imax + 1 + imax * a_dim1], &c__1, &w[ + imax + 1 + (k + 1) * w_dim1], &c__1); + } + + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1] + , lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + + 1) * w_dim1], &c__1); + i__1 = imax + (k + 1) * w_dim1; + i__2 = imax + (k + 1) * w_dim1; + d__1 = w[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + } + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine both ROWMAX and JMAX. */ + + if (imax != k) { + i__1 = imax - k; + jmax = k - 1 + izamax_(&i__1, &w[k + (k + 1) * w_dim1], & + c__1); + i__1 = jmax + (k + 1) * w_dim1; + rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(& + w[jmax + (k + 1) * w_dim1]), abs(d__2)); + } else { + rowmax = 0.; + } + + if (imax < *n) { + i__1 = *n - imax; + itemp = imax + izamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); + i__1 = itemp + (k + 1) * w_dim1; + dtemp = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + itemp + (k + 1) * w_dim1]), abs(d__2)); + if (dtemp > rowmax) { + rowmax = dtemp; + jmax = itemp; + } + } + +/* Case(2) */ +/* Equivalent to testing for */ +/* ABS( REAL( W( IMAX,K+1 ) ) ).GE.ALPHA*ROWMAX */ +/* (used to handle NaN and Inf) */ + + i__1 = imax + (k + 1) * w_dim1; + if (! ((d__1 = w[i__1].r, abs(d__1)) < alpha * rowmax)) { + +/* interchange rows and columns K and IMAX, */ +/* use 1-by-1 pivot block */ + + kp = imax; + +/* copy column K+1 of W to column K of W */ + + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + + done = TRUE_; + +/* Case(3) */ +/* Equivalent to testing for ROWMAX.EQ.COLMAX, */ +/* (used to handle NaN and Inf) */ + + } else if (p == jmax || rowmax <= colmax) { + +/* interchange rows and columns K+1 and IMAX, */ +/* use 2-by-2 pivot block */ + + kp = imax; + kstep = 2; + done = TRUE_; + +/* Case(4) */ + } else { + +/* Pivot not found: set params and repeat */ + + p = imax; + colmax = rowmax; + imax = jmax; + +/* Copy updated JMAXth (next IMAXth) column to Kth of W */ + + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + + } + + +/* End pivot search loop body */ + + if (! done) { + goto L72; + } + + } + +/* END pivot search */ + +/* ============================================================ */ + +/* KK is the column of A where pivoting step stopped */ + + kk = k + kstep - 1; + +/* Interchange rows and columns P and K (only for 2-by-2 pivot). */ +/* Updated column P is already stored in column K of W. */ + + if (kstep == 2 && p != k) { + +/* Copy non-updated column KK-1 to column P of submatrix A */ +/* at step K. No need to copy element into columns */ +/* K and K+1 of A for 2-by-2 pivot, since these columns */ +/* will be later overwritten. */ + + i__1 = p + p * a_dim1; + i__2 = k + k * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = p - k - 1; + zcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[p + (k + 1) * + a_dim1], lda); + i__1 = p - k - 1; + zlacgv_(&i__1, &a[p + (k + 1) * a_dim1], lda); + if (p < *n) { + i__1 = *n - p; + zcopy_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + 1 + p + * a_dim1], &c__1); + } + +/* Interchange rows K and P in first K-1 columns of A */ +/* (columns K and K+1 of A for 2-by-2 pivot will be */ +/* later overwritten). Interchange rows K and P */ +/* in first KK columns of W. */ + + if (k > 1) { + i__1 = k - 1; + zswap_(&i__1, &a[k + a_dim1], lda, &a[p + a_dim1], lda); + } + zswap_(&kk, &w[k + w_dim1], ldw, &w[p + w_dim1], ldw); + } + +/* Interchange rows and columns KP and KK. */ +/* Updated column KP is already stored in column KK of W. */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP of submatrix A */ +/* at step K. No need to copy element into column K */ +/* (or K and K+1 for 2-by-2 pivot) of A, since these columns */ +/* will be later overwritten. */ + + i__1 = kp + kp * a_dim1; + i__2 = kk + kk * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = kp - kk - 1; + zcopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + + 1) * a_dim1], lda); + i__1 = kp - kk - 1; + zlacgv_(&i__1, &a[kp + (kk + 1) * a_dim1], lda); + if (kp < *n) { + i__1 = *n - kp; + zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + +/* Interchange rows KK and KP in first K-1 columns of A */ +/* (column K (or K and K+1 for 2-by-2 pivot) of A will be */ +/* later overwritten). Interchange rows KK and KP */ +/* in first KK columns of W. */ + + if (k > 1) { + i__1 = k - 1; + zswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + } + zswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k of W now holds */ + +/* W(k) = L(k)*D(k), */ + +/* where L(k) is the k-th column of L */ + +/* (1) Store subdiag. elements of column L(k) */ +/* and 1-by-1 block D(k) in column k of A. */ +/* (NOTE: Diagonal element L(k,k) is a UNIT element */ +/* and not stored) */ +/* A(k,k) := D(k,k) = W(k,k) */ +/* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k) */ + +/* (NOTE: No need to use for Hermitian matrix */ +/* A( K, K ) = REAL( W( K, K) ) to separately copy diagonal */ +/* element D(k,k) from W (potentially saves only one load)) */ + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + +/* (NOTE: No need to check if A(k,k) is NOT ZERO, */ +/* since that was ensured earlier in pivot search: */ +/* case A(k,k) = 0 falls into 2x2 pivot case(3)) */ + +/* Handle division by a small number */ + + i__1 = k + k * a_dim1; + t = a[i__1].r; + if (abs(t) >= sfmin) { + r1 = 1. / t; + i__1 = *n - k; + zdscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + } else { + i__1 = *n; + for (ii = k + 1; ii <= i__1; ++ii) { + i__2 = ii + k * a_dim1; + i__3 = ii + k * a_dim1; + z__1.r = a[i__3].r / t, z__1.i = a[i__3].i / t; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L74: */ + } + } + +/* (2) Conjugate column W(k) */ + + i__1 = *n - k; + zlacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + +/* Store the subdiagonal element of D in array E */ + + i__1 = k; + e[i__1].r = 0., e[i__1].i = 0.; + + } + + } else { + +/* 2-by-2 pivot block D(k): columns k and k+1 of W now hold */ + +/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */ + +/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */ +/* of L */ + +/* (1) Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2 */ +/* block D(k:k+1,k:k+1) in columns k and k+1 of A. */ +/* NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT */ +/* block and not stored. */ +/* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1) */ +/* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) = */ +/* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) ) */ + + if (k < *n - 1) { + +/* Factor out the columns of the inverse of 2-by-2 pivot */ +/* block D, so that each column contains 1, to reduce the */ +/* number of FLOPS when we multiply panel */ +/* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1). */ + +/* D**(-1) = ( d11 cj(d21) )**(-1) = */ +/* ( d21 d22 ) */ + +/* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) = */ +/* ( (-d21) ( d11 ) ) */ + +/* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) * */ + +/* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) = */ +/* ( ( -1 ) ( d11/conj(d21) ) ) */ + +/* = 1/(|d21|**2) * 1/(D22*D11-1) * */ + +/* * ( d21*( D11 ) conj(d21)*( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* Handle division by a small number. (NOTE: order of */ +/* operations is important) */ + +/* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) ) */ +/* ( (( -1 ) ) (( D22 ) ) ), */ + +/* where D11 = d22/d21, */ +/* D22 = d11/conj(d21), */ +/* D21 = d21, */ +/* T = 1/(D22*D11-1). */ + +/* (NOTE: No need to check for division by ZERO, */ +/* since that was ensured earlier in pivot search: */ +/* (a) d21 != 0 in 2x2 pivot case(4), */ +/* since |d21| should be larger than |d11| and |d22|; */ +/* (b) (D22*D11 - 1) != 0, since from (a), */ +/* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.) */ + + i__1 = k + 1 + k * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + z_div(&z__1, &w[k + 1 + (k + 1) * w_dim1], &d21); + d11.r = z__1.r, d11.i = z__1.i; + d_cnjg(&z__2, &d21); + z_div(&z__1, &w[k + k * w_dim1], &z__2); + d22.r = z__1.r, d22.i = z__1.i; + z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r * + d22.i + d11.i * d22.r; + t = 1. / (z__1.r - 1.); + +/* Update elements in columns A(k) and A(k+1) as */ +/* dot products of rows of ( W(k) W(k+1) ) and columns */ +/* of D**(-1) */ + + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + i__3 = j + k * w_dim1; + z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + (k + 1) * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + d_cnjg(&z__5, &d21); + z_div(&z__2, &z__3, &z__5); + z__1.r = t * z__2.r, z__1.i = t * z__2.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + (k + 1) * a_dim1; + i__3 = j + (k + 1) * w_dim1; + z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + k * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + z_div(&z__2, &z__3, &d21); + z__1.r = t * z__2.r, z__1.i = t * z__2.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L80: */ + } + } + +/* Copy diagonal elements of D(K) to A, */ +/* copy subdiagonal element of D(K) to E(K) and */ +/* ZERO out subdiagonal entry of A */ + + i__1 = k + k * a_dim1; + i__2 = k + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + k * a_dim1; + a[i__1].r = 0., a[i__1].i = 0.; + i__1 = k + 1 + (k + 1) * a_dim1; + i__2 = k + 1 + (k + 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k; + i__2 = k + 1 + k * w_dim1; + e[i__1].r = w[i__2].r, e[i__1].i = w[i__2].i; + i__1 = k + 1; + e[i__1].r = 0., e[i__1].i = 0.; + +/* (2) Conjugate columns W(k) and W(k+1) */ + + i__1 = *n - k; + zlacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = *n - k - 1; + zlacgv_(&i__1, &w[k + 2 + (k + 1) * w_dim1], &c__1); + + } + +/* End column K is nonsingular */ + + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + goto L70; + +L90: + +/* Update the lower triangle of A22 (= A(k:n,k:n)) as */ + +/* A22 := A22 - L21*D*L21**H = A22 - L21*W**H */ + +/* computing blocks of NB columns at a time (note that conjg(W) is */ +/* actually stored) */ + + i__1 = *n; + i__2 = *nb; + for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = *nb, i__4 = *n - j + 1; + jb = f2cmin(i__3,i__4); + +/* Update the lower triangle of the diagonal block */ + + i__3 = j + jb - 1; + for (jj = j; jj <= i__3; ++jj) { + i__4 = jj + jj * a_dim1; + i__5 = jj + jj * a_dim1; + d__1 = a[i__5].r; + a[i__4].r = d__1, a[i__4].i = 0.; + i__4 = j + jb - jj; + i__5 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__4, &i__5, &z__1, &a[jj + a_dim1], + lda, &w[jj + w_dim1], ldw, &c_b1, &a[jj + jj * a_dim1] + , &c__1); + i__4 = jj + jj * a_dim1; + i__5 = jj + jj * a_dim1; + d__1 = a[i__5].r; + a[i__4].r = d__1, a[i__4].i = 0.; +/* L100: */ + } + +/* Update the rectangular subdiagonal block */ + + if (j + jb <= *n) { + i__3 = *n - j - jb + 1; + i__4 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &z__1, + &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b1, + &a[j + jb + j * a_dim1], lda); + } +/* L110: */ + } + +/* Set KB to the number of columns factorized */ + + *kb = k - 1; + + } + return 0; + +/* End of ZLAHEF_RK */ + +} /* zlahef_rk__ */ + diff --git a/lapack-netlib/SRC/zlahef_rook.c b/lapack-netlib/SRC/zlahef_rook.c new file mode 100644 index 000000000..f70426969 --- /dev/null +++ b/lapack-netlib/SRC/zlahef_rook.c @@ -0,0 +1,1857 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \htmlonly */ +/* > Download ZLAHEF_ROOK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAHEF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, KB, LDA, LDW, N, NB */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), W( LDW, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAHEF_ROOK computes a partial factorization of a complex Hermitian */ +/* > matrix A using the bounded Bunch-Kaufman ("rook") diagonal pivoting */ +/* > method. The partial factorization has the form: */ +/* > */ +/* > A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: */ +/* > ( 0 U22 ) ( 0 D ) ( U12**H U22**H ) */ +/* > */ +/* > A = ( L11 0 ) ( D 0 ) ( L11**H L21**H ) if UPLO = 'L' */ +/* > ( L21 I ) ( 0 A22 ) ( 0 I ) */ +/* > */ +/* > where the order of D is at most NB. The actual order is returned in */ +/* > the argument KB, and is either NB or NB-1, or N if N <= NB. */ +/* > Note that U**H denotes the conjugate transpose of U. */ +/* > */ +/* > ZLAHEF_ROOK is an auxiliary routine called by ZHETRF_ROOK. It uses */ +/* > blocked code (calling Level 3 BLAS) to update the submatrix */ +/* > A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > Hermitian 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] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The maximum number of columns of the matrix A that should be */ +/* > factored. NB should be at least 2 to allow for 2-by-2 pivot */ +/* > blocks. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] KB */ +/* > \verbatim */ +/* > KB is INTEGER */ +/* > The number of columns of A that were actually factored. */ +/* > KB is either NB-1 or NB, or N if N <= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the Hermitian 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, A contains details of the partial factorization. */ +/* > \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': */ +/* > Only the last KB elements of IPIV are set. */ +/* > */ +/* > 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': */ +/* > Only the first KB elements of IPIV are set. */ +/* > */ +/* > 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] W */ +/* > \verbatim */ +/* > W is COMPLEX*16 array, dimension (LDW,NB) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDW */ +/* > \verbatim */ +/* > LDW is INTEGER */ +/* > The leading dimension of the array W. LDW >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > > 0: if INFO = k, D(k,k) is exactly zero. The factorization */ +/* > has been completed, but the block diagonal matrix D is */ +/* > exactly singular. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2013 */ + +/* > \ingroup complex16HEcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2013, 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 zlahef_rook_(char *uplo, integer *n, integer *nb, + integer *kb, doublecomplex *a, integer *lda, integer *ipiv, + doublecomplex *w, integer *ldw, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5; + doublereal d__1, d__2; + doublecomplex z__1, z__2, z__3, z__4, z__5; + + /* Local variables */ + logical done; + integer imax, jmax, j, k, p; + doublereal t, alpha; + extern logical lsame_(char *, char *); + doublereal dtemp, sfmin; + integer itemp; + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + integer kstep; + extern /* Subroutine */ int zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + doublereal r1; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zswap_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *); + doublecomplex d11, d21, d22; + integer jb, ii, jj, kk; + extern doublereal dlamch_(char *); + integer kp; + doublereal absakk; + integer kw; + extern /* Subroutine */ int zdscal_(integer *, doublereal *, + doublecomplex *, integer *); + doublereal colmax; + extern /* Subroutine */ int zlacgv_(integer *, doublecomplex *, integer *) + ; + extern integer izamax_(integer *, doublecomplex *, integer *); + integer jp1, jp2; + doublereal rowmax; + integer kkw; + + +/* -- LAPACK computational routine (version 3.5.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2013 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1 * 1; + w -= w_offset; + + /* Function Body */ + *info = 0; + +/* Initialize ALPHA for use in choosing pivot block size. */ + + alpha = (sqrt(17.) + 1.) / 8.; + +/* Compute machine safe minimum */ + + sfmin = dlamch_("S"); + + if (lsame_(uplo, "U")) { + +/* Factorize the trailing columns of A using the upper triangle */ +/* of A and working backwards, and compute the matrix W = U12*D */ +/* for use in updating A11 (note that conjg(W) is actually stored) */ + +/* K is the main loop index, decreasing from N in steps of 1 or 2 */ + + k = *n; +L10: + +/* KW is the column of W which corresponds to column K of A */ + + kw = *nb + k - *n; + +/* Exit from loop */ + + if (k <= *n - *nb + 1 && *nb < *n || k < 1) { + goto L30; + } + + kstep = 1; + p = k; + +/* Copy column K of A to column KW of W and update it */ + + if (k > 1) { + i__1 = k - 1; + zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], & + c__1); + } + i__1 = k + kw * w_dim1; + i__2 = k + k * a_dim1; + d__1 = a[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + if (k < *n) { + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * + w_dim1 + 1], &c__1); + i__1 = k + kw * w_dim1; + i__2 = k + kw * w_dim1; + d__1 = w[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + } + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = k + kw * w_dim1; + absakk = (d__1 = w[i__1].r, abs(d__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k > 1) { + i__1 = k - 1; + imax = izamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = imax + kw * w_dim1; + colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + kw * w_dim1]), abs(d__2)); + } else { + colmax = 0.; + } + + if (f2cmax(absakk,colmax) == 0.) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = k + k * a_dim1; + i__2 = k + kw * w_dim1; + d__1 = w[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + if (k > 1) { + i__1 = k - 1; + zcopy_(&i__1, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], + &c__1); + } + } else { + +/* ============================================================ */ + +/* BEGIN pivot search */ + +/* Case(1) */ +/* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX */ +/* (used to handle NaN and Inf) */ + if (! (absakk < alpha * colmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + + } else { + +/* Lop until pivot found */ + + done = FALSE_; + +L12: + +/* BEGIN pivot search loop body */ + + +/* Copy column IMAX to column KW-1 of W and update it */ + + if (imax > 1) { + i__1 = imax - 1; + zcopy_(&i__1, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + } + i__1 = imax + (kw - 1) * w_dim1; + i__2 = imax + imax * a_dim1; + d__1 = a[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + + i__1 = k - imax; + zcopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + i__1 = k - imax; + zlacgv_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], &c__1); + + if (k < *n) { + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1); + i__1 = imax + (kw - 1) * w_dim1; + i__2 = imax + (kw - 1) * w_dim1; + d__1 = w[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + } + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine both ROWMAX and JMAX. */ + + if (imax != k) { + i__1 = k - imax; + jmax = imax + izamax_(&i__1, &w[imax + 1 + (kw - 1) * + w_dim1], &c__1); + i__1 = jmax + (kw - 1) * w_dim1; + rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(& + w[jmax + (kw - 1) * w_dim1]), abs(d__2)); + } else { + rowmax = 0.; + } + + if (imax > 1) { + i__1 = imax - 1; + itemp = izamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); + i__1 = itemp + (kw - 1) * w_dim1; + dtemp = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + itemp + (kw - 1) * w_dim1]), abs(d__2)); + if (dtemp > rowmax) { + rowmax = dtemp; + jmax = itemp; + } + } + +/* Case(2) */ +/* Equivalent to testing for */ +/* ABS( REAL( W( IMAX,KW-1 ) ) ).GE.ALPHA*ROWMAX */ +/* (used to handle NaN and Inf) */ + + i__1 = imax + (kw - 1) * w_dim1; + if (! ((d__1 = w[i__1].r, abs(d__1)) < alpha * rowmax)) { + +/* interchange rows and columns K and IMAX, */ +/* use 1-by-1 pivot block */ + + kp = imax; + +/* copy column KW-1 of W to column KW of W */ + + zcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + + done = TRUE_; + +/* Case(3) */ +/* Equivalent to testing for ROWMAX.EQ.COLMAX, */ +/* (used to handle NaN and Inf) */ + + } else if (p == jmax || rowmax <= colmax) { + +/* interchange rows and columns K-1 and IMAX, */ +/* use 2-by-2 pivot block */ + + kp = imax; + kstep = 2; + done = TRUE_; + +/* Case(4) */ + } else { + +/* Pivot not found: set params and repeat */ + + p = imax; + colmax = rowmax; + imax = jmax; + +/* Copy updated JMAXth (next IMAXth) column to Kth of W */ + + zcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + + } + + +/* END pivot search loop body */ + + if (! done) { + goto L12; + } + + } + +/* END pivot search */ + +/* ============================================================ */ + +/* KK is the column of A where pivoting step stopped */ + + kk = k - kstep + 1; + +/* KKW is the column of W which corresponds to column KK of A */ + + kkw = *nb + kk - *n; + +/* Interchange rows and columns P and K. */ +/* Updated column P is already stored in column KW of W. */ + + if (kstep == 2 && p != k) { + +/* Copy non-updated column K to column P of submatrix A */ +/* at step K. No need to copy element into columns */ +/* K and K-1 of A for 2-by-2 pivot, since these columns */ +/* will be later overwritten. */ + + i__1 = p + p * a_dim1; + i__2 = k + k * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = k - 1 - p; + zcopy_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + (p + 1) * + a_dim1], lda); + i__1 = k - 1 - p; + zlacgv_(&i__1, &a[p + (p + 1) * a_dim1], lda); + if (p > 1) { + i__1 = p - 1; + zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[p * a_dim1 + + 1], &c__1); + } + +/* Interchange rows K and P in the last K+1 to N columns of A */ +/* (columns K and K-1 of A for 2-by-2 pivot will be */ +/* later overwritten). Interchange rows K and P */ +/* in last KKW to NB columns of W. */ + + if (k < *n) { + i__1 = *n - k; + zswap_(&i__1, &a[k + (k + 1) * a_dim1], lda, &a[p + (k + + 1) * a_dim1], lda); + } + i__1 = *n - kk + 1; + zswap_(&i__1, &w[k + kkw * w_dim1], ldw, &w[p + kkw * w_dim1], + ldw); + } + +/* Interchange rows and columns KP and KK. */ +/* Updated column KP is already stored in column KKW of W. */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP of submatrix A */ +/* at step K. No need to copy element into column K */ +/* (or K and K-1 for 2-by-2 pivot) of A, since these columns */ +/* will be later overwritten. */ + + i__1 = kp + kp * a_dim1; + i__2 = kk + kk * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = kk - 1 - kp; + zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + i__1 = kk - 1 - kp; + zlacgv_(&i__1, &a[kp + (kp + 1) * a_dim1], lda); + if (kp > 1) { + i__1 = kp - 1; + zcopy_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + +/* Interchange rows KK and KP in last K+1 to N columns of A */ +/* (columns K (or K and K-1 for 2-by-2 pivot) of A will be */ +/* later overwritten). Interchange rows KK and KP */ +/* in last KKW to NB columns of W. */ + + if (k < *n) { + i__1 = *n - k; + zswap_(&i__1, &a[kk + (k + 1) * a_dim1], lda, &a[kp + (k + + 1) * a_dim1], lda); + } + i__1 = *n - kk + 1; + zswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column kw of W now holds */ + +/* W(kw) = U(k)*D(k), */ + +/* where U(k) is the k-th column of U */ + +/* (1) Store subdiag. elements of column U(k) */ +/* and 1-by-1 block D(k) in column k of A. */ +/* (NOTE: Diagonal element U(k,k) is a UNIT element */ +/* and not stored) */ +/* A(k,k) := D(k,k) = W(k,kw) */ +/* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k) */ + +/* (NOTE: No need to use for Hermitian matrix */ +/* A( K, K ) = REAL( W( K, K) ) to separately copy diagonal */ +/* element D(k,k) from W (potentially saves only one load)) */ + zcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + if (k > 1) { + +/* (NOTE: No need to check if A(k,k) is NOT ZERO, */ +/* since that was ensured earlier in pivot search: */ +/* case A(k,k) = 0 falls into 2x2 pivot case(3)) */ + +/* Handle division by a small number */ + + i__1 = k + k * a_dim1; + t = a[i__1].r; + if (abs(t) >= sfmin) { + r1 = 1. / t; + i__1 = k - 1; + zdscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + } else { + i__1 = k - 1; + for (ii = 1; ii <= i__1; ++ii) { + i__2 = ii + k * a_dim1; + i__3 = ii + k * a_dim1; + z__1.r = a[i__3].r / t, z__1.i = a[i__3].i / t; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L14: */ + } + } + +/* (2) Conjugate column W(kw) */ + + i__1 = k - 1; + zlacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1); + } + + } else { + +/* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold */ + +/* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k) */ + +/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ +/* of U */ + +/* (1) Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2 */ +/* block D(k-1:k,k-1:k) in columns k-1 and k of A. */ +/* (NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT */ +/* block and not stored) */ +/* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw) */ +/* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) = */ +/* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) ) */ + + if (k > 2) { + +/* Factor out the columns of the inverse of 2-by-2 pivot */ +/* block D, so that each column contains 1, to reduce the */ +/* number of FLOPS when we multiply panel */ +/* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1). */ + +/* D**(-1) = ( d11 cj(d21) )**(-1) = */ +/* ( d21 d22 ) */ + +/* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) = */ +/* ( (-d21) ( d11 ) ) */ + +/* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) * */ + +/* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) = */ +/* ( ( -1 ) ( d11/conj(d21) ) ) */ + +/* = 1/(|d21|**2) * 1/(D22*D11-1) * */ + +/* * ( d21*( D11 ) conj(d21)*( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* Handle division by a small number. (NOTE: order of */ +/* operations is important) */ + +/* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) ) */ +/* ( (( -1 ) ) (( D22 ) ) ), */ + +/* where D11 = d22/d21, */ +/* D22 = d11/conj(d21), */ +/* D21 = d21, */ +/* T = 1/(D22*D11-1). */ + +/* (NOTE: No need to check for division by ZERO, */ +/* since that was ensured earlier in pivot search: */ +/* (a) d21 != 0 in 2x2 pivot case(4), */ +/* since |d21| should be larger than |d11| and |d22|; */ +/* (b) (D22*D11 - 1) != 0, since from (a), */ +/* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.) */ + + i__1 = k - 1 + kw * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + d_cnjg(&z__2, &d21); + z_div(&z__1, &w[k + kw * w_dim1], &z__2); + d11.r = z__1.r, d11.i = z__1.i; + z_div(&z__1, &w[k - 1 + (kw - 1) * w_dim1], &d21); + d22.r = z__1.r, d22.i = z__1.i; + z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r * + d22.i + d11.i * d22.r; + t = 1. / (z__1.r - 1.); + +/* Update elements in columns A(k-1) and A(k) as */ +/* dot products of rows of ( W(kw-1) W(kw) ) and columns */ +/* of D**(-1) */ + + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + i__2 = j + (k - 1) * a_dim1; + i__3 = j + (kw - 1) * w_dim1; + z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + kw * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + z_div(&z__2, &z__3, &d21); + z__1.r = t * z__2.r, z__1.i = t * z__2.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + k * a_dim1; + i__3 = j + kw * w_dim1; + z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + (kw - 1) * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + d_cnjg(&z__5, &d21); + z_div(&z__2, &z__3, &z__5); + z__1.r = t * z__2.r, z__1.i = t * z__2.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L20: */ + } + } + +/* Copy D(k) to A */ + + i__1 = k - 1 + (k - 1) * a_dim1; + i__2 = k - 1 + (kw - 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k - 1 + k * a_dim1; + i__2 = k - 1 + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + k * a_dim1; + i__2 = k + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + +/* (2) Conjugate columns W(kw) and W(kw-1) */ + + i__1 = k - 1; + zlacgv_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = k - 2; + zlacgv_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); + + } + + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + goto L10; + +L30: + +/* Update the upper triangle of A11 (= A(1:k,1:k)) as */ + +/* A11 := A11 - U12*D*U12**H = A11 - U12*W**H */ + +/* computing blocks of NB columns at a time (note that conjg(W) is */ +/* actually stored) */ + + i__1 = -(*nb); + for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += + i__1) { +/* Computing MIN */ + i__2 = *nb, i__3 = k - j + 1; + jb = f2cmin(i__2,i__3); + +/* Update the upper triangle of the diagonal block */ + + i__2 = j + jb - 1; + for (jj = j; jj <= i__2; ++jj) { + i__3 = jj + jj * a_dim1; + i__4 = jj + jj * a_dim1; + d__1 = a[i__4].r; + a[i__3].r = d__1, a[i__3].i = 0.; + i__3 = jj - j + 1; + i__4 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__3, &i__4, &z__1, &a[j + (k + 1) * + a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b1, + &a[j + jj * a_dim1], &c__1); + i__3 = jj + jj * a_dim1; + i__4 = jj + jj * a_dim1; + d__1 = a[i__4].r; + a[i__3].r = d__1, a[i__3].i = 0.; +/* L40: */ + } + +/* Update the rectangular superdiagonal block */ + + if (j >= 2) { + i__2 = j - 1; + i__3 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &z__1, + &a[(k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * + w_dim1], ldw, &c_b1, &a[j * a_dim1 + 1], lda); + } +/* L50: */ + } + +/* Put U12 in standard form by partially undoing the interchanges */ +/* in of rows in columns k+1:n looping backwards from k+1 to n */ + + j = k + 1; +L60: + +/* Undo the interchanges (if any) of rows J and JP2 */ +/* (or J and JP2, and J+1 and JP1) at each step J */ + + kstep = 1; + jp1 = 1; +/* (Here, J is a diagonal index) */ + jj = j; + jp2 = ipiv[j]; + if (jp2 < 0) { + jp2 = -jp2; +/* (Here, J is a diagonal index) */ + ++j; + jp1 = -ipiv[j]; + kstep = 2; + } +/* (NOTE: Here, J is used to determine row length. Length N-J+1 */ +/* of the rows to swap back doesn't include diagonal element) */ + ++j; + if (jp2 != jj && j <= *n) { + i__1 = *n - j + 1; + zswap_(&i__1, &a[jp2 + j * a_dim1], lda, &a[jj + j * a_dim1], lda) + ; + } + ++jj; + if (kstep == 2 && jp1 != jj && j <= *n) { + i__1 = *n - j + 1; + zswap_(&i__1, &a[jp1 + j * a_dim1], lda, &a[jj + j * a_dim1], lda) + ; + } + if (j < *n) { + goto L60; + } + +/* Set KB to the number of columns factorized */ + + *kb = *n - k; + + } else { + +/* Factorize the leading columns of A using the lower triangle */ +/* of A and working forwards, and compute the matrix W = L21*D */ +/* for use in updating A22 (note that conjg(W) is actually stored) */ + +/* K is the main loop index, increasing from 1 in steps of 1 or 2 */ + + k = 1; +L70: + +/* Exit from loop */ + + if (k >= *nb && *nb < *n || k > *n) { + goto L90; + } + + kstep = 1; + p = k; + +/* Copy column K of A to column K of W and update column K of W */ + + i__1 = k + k * w_dim1; + i__2 = k + k * a_dim1; + d__1 = a[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + if (k < *n) { + i__1 = *n - k; + zcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &w[k + 1 + k * + w_dim1], &c__1); + } + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], lda, & + w[k + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1); + i__1 = k + k * w_dim1; + i__2 = k + k * w_dim1; + d__1 = w[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + } + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = k + k * w_dim1; + absakk = (d__1 = w[i__1].r, abs(d__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k < *n) { + i__1 = *n - k; + imax = k + izamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = imax + k * w_dim1; + colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + k * w_dim1]), abs(d__2)); + } else { + colmax = 0.; + } + + if (f2cmax(absakk,colmax) == 0.) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = k + k * a_dim1; + i__2 = k + k * w_dim1; + d__1 = w[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + if (k < *n) { + i__1 = *n - k; + zcopy_(&i__1, &w[k + 1 + k * w_dim1], &c__1, &a[k + 1 + k * + a_dim1], &c__1); + } + } else { + +/* ============================================================ */ + +/* BEGIN pivot search */ + +/* Case(1) */ +/* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX */ +/* (used to handle NaN and Inf) */ + + if (! (absakk < alpha * colmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + + } else { + + done = FALSE_; + +/* Loop until pivot found */ + +L72: + +/* BEGIN pivot search loop body */ + + +/* Copy column IMAX to column k+1 of W and update it */ + + i__1 = imax - k; + zcopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = imax - k; + zlacgv_(&i__1, &w[k + (k + 1) * w_dim1], &c__1); + i__1 = imax + (k + 1) * w_dim1; + i__2 = imax + imax * a_dim1; + d__1 = a[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + + if (imax < *n) { + i__1 = *n - imax; + zcopy_(&i__1, &a[imax + 1 + imax * a_dim1], &c__1, &w[ + imax + 1 + (k + 1) * w_dim1], &c__1); + } + + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1] + , lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + + 1) * w_dim1], &c__1); + i__1 = imax + (k + 1) * w_dim1; + i__2 = imax + (k + 1) * w_dim1; + d__1 = w[i__2].r; + w[i__1].r = d__1, w[i__1].i = 0.; + } + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine both ROWMAX and JMAX. */ + + if (imax != k) { + i__1 = imax - k; + jmax = k - 1 + izamax_(&i__1, &w[k + (k + 1) * w_dim1], & + c__1); + i__1 = jmax + (k + 1) * w_dim1; + rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(& + w[jmax + (k + 1) * w_dim1]), abs(d__2)); + } else { + rowmax = 0.; + } + + if (imax < *n) { + i__1 = *n - imax; + itemp = imax + izamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); + i__1 = itemp + (k + 1) * w_dim1; + dtemp = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + itemp + (k + 1) * w_dim1]), abs(d__2)); + if (dtemp > rowmax) { + rowmax = dtemp; + jmax = itemp; + } + } + +/* Case(2) */ +/* Equivalent to testing for */ +/* ABS( REAL( W( IMAX,K+1 ) ) ).GE.ALPHA*ROWMAX */ +/* (used to handle NaN and Inf) */ + + i__1 = imax + (k + 1) * w_dim1; + if (! ((d__1 = w[i__1].r, abs(d__1)) < alpha * rowmax)) { + +/* interchange rows and columns K and IMAX, */ +/* use 1-by-1 pivot block */ + + kp = imax; + +/* copy column K+1 of W to column K of W */ + + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + + done = TRUE_; + +/* Case(3) */ +/* Equivalent to testing for ROWMAX.EQ.COLMAX, */ +/* (used to handle NaN and Inf) */ + + } else if (p == jmax || rowmax <= colmax) { + +/* interchange rows and columns K+1 and IMAX, */ +/* use 2-by-2 pivot block */ + + kp = imax; + kstep = 2; + done = TRUE_; + +/* Case(4) */ + } else { + +/* Pivot not found: set params and repeat */ + + p = imax; + colmax = rowmax; + imax = jmax; + +/* Copy updated JMAXth (next IMAXth) column to Kth of W */ + + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + + } + + +/* End pivot search loop body */ + + if (! done) { + goto L72; + } + + } + +/* END pivot search */ + +/* ============================================================ */ + +/* KK is the column of A where pivoting step stopped */ + + kk = k + kstep - 1; + +/* Interchange rows and columns P and K (only for 2-by-2 pivot). */ +/* Updated column P is already stored in column K of W. */ + + if (kstep == 2 && p != k) { + +/* Copy non-updated column KK-1 to column P of submatrix A */ +/* at step K. No need to copy element into columns */ +/* K and K+1 of A for 2-by-2 pivot, since these columns */ +/* will be later overwritten. */ + + i__1 = p + p * a_dim1; + i__2 = k + k * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = p - k - 1; + zcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[p + (k + 1) * + a_dim1], lda); + i__1 = p - k - 1; + zlacgv_(&i__1, &a[p + (k + 1) * a_dim1], lda); + if (p < *n) { + i__1 = *n - p; + zcopy_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + 1 + p + * a_dim1], &c__1); + } + +/* Interchange rows K and P in first K-1 columns of A */ +/* (columns K and K+1 of A for 2-by-2 pivot will be */ +/* later overwritten). Interchange rows K and P */ +/* in first KK columns of W. */ + + if (k > 1) { + i__1 = k - 1; + zswap_(&i__1, &a[k + a_dim1], lda, &a[p + a_dim1], lda); + } + zswap_(&kk, &w[k + w_dim1], ldw, &w[p + w_dim1], ldw); + } + +/* Interchange rows and columns KP and KK. */ +/* Updated column KP is already stored in column KK of W. */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP of submatrix A */ +/* at step K. No need to copy element into column K */ +/* (or K and K+1 for 2-by-2 pivot) of A, since these columns */ +/* will be later overwritten. */ + + i__1 = kp + kp * a_dim1; + i__2 = kk + kk * a_dim1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = kp - kk - 1; + zcopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + + 1) * a_dim1], lda); + i__1 = kp - kk - 1; + zlacgv_(&i__1, &a[kp + (kk + 1) * a_dim1], lda); + if (kp < *n) { + i__1 = *n - kp; + zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + +/* Interchange rows KK and KP in first K-1 columns of A */ +/* (column K (or K and K+1 for 2-by-2 pivot) of A will be */ +/* later overwritten). Interchange rows KK and KP */ +/* in first KK columns of W. */ + + if (k > 1) { + i__1 = k - 1; + zswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + } + zswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k of W now holds */ + +/* W(k) = L(k)*D(k), */ + +/* where L(k) is the k-th column of L */ + +/* (1) Store subdiag. elements of column L(k) */ +/* and 1-by-1 block D(k) in column k of A. */ +/* (NOTE: Diagonal element L(k,k) is a UNIT element */ +/* and not stored) */ +/* A(k,k) := D(k,k) = W(k,k) */ +/* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k) */ + +/* (NOTE: No need to use for Hermitian matrix */ +/* A( K, K ) = REAL( W( K, K) ) to separately copy diagonal */ +/* element D(k,k) from W (potentially saves only one load)) */ + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + +/* (NOTE: No need to check if A(k,k) is NOT ZERO, */ +/* since that was ensured earlier in pivot search: */ +/* case A(k,k) = 0 falls into 2x2 pivot case(3)) */ + +/* Handle division by a small number */ + + i__1 = k + k * a_dim1; + t = a[i__1].r; + if (abs(t) >= sfmin) { + r1 = 1. / t; + i__1 = *n - k; + zdscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + } else { + i__1 = *n; + for (ii = k + 1; ii <= i__1; ++ii) { + i__2 = ii + k * a_dim1; + i__3 = ii + k * a_dim1; + z__1.r = a[i__3].r / t, z__1.i = a[i__3].i / t; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L74: */ + } + } + +/* (2) Conjugate column W(k) */ + + i__1 = *n - k; + zlacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + } + + } else { + +/* 2-by-2 pivot block D(k): columns k and k+1 of W now hold */ + +/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */ + +/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */ +/* of L */ + +/* (1) Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2 */ +/* block D(k:k+1,k:k+1) in columns k and k+1 of A. */ +/* NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT */ +/* block and not stored. */ +/* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1) */ +/* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) = */ +/* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) ) */ + + if (k < *n - 1) { + +/* Factor out the columns of the inverse of 2-by-2 pivot */ +/* block D, so that each column contains 1, to reduce the */ +/* number of FLOPS when we multiply panel */ +/* ( W(kw-1) W(kw) ) by this inverse, i.e. by D**(-1). */ + +/* D**(-1) = ( d11 cj(d21) )**(-1) = */ +/* ( d21 d22 ) */ + +/* = 1/(d11*d22-|d21|**2) * ( ( d22) (-cj(d21) ) ) = */ +/* ( (-d21) ( d11 ) ) */ + +/* = 1/(|d21|**2) * 1/((d11/cj(d21))*(d22/d21)-1) * */ + +/* * ( d21*( d22/d21 ) conj(d21)*( - 1 ) ) = */ +/* ( ( -1 ) ( d11/conj(d21) ) ) */ + +/* = 1/(|d21|**2) * 1/(D22*D11-1) * */ + +/* * ( d21*( D11 ) conj(d21)*( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = (1/|d21|**2) * T * ( d21*( D11 ) conj(d21)*( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = ( (T/conj(d21))*( D11 ) (T/d21)*( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* Handle division by a small number. (NOTE: order of */ +/* operations is important) */ + +/* = ( T*(( D11 )/conj(D21)) T*(( -1 )/D21 ) ) */ +/* ( (( -1 ) ) (( D22 ) ) ), */ + +/* where D11 = d22/d21, */ +/* D22 = d11/conj(d21), */ +/* D21 = d21, */ +/* T = 1/(D22*D11-1). */ + +/* (NOTE: No need to check for division by ZERO, */ +/* since that was ensured earlier in pivot search: */ +/* (a) d21 != 0 in 2x2 pivot case(4), */ +/* since |d21| should be larger than |d11| and |d22|; */ +/* (b) (D22*D11 - 1) != 0, since from (a), */ +/* both |D11| < 1, |D22| < 1, hence |D22*D11| << 1.) */ + + i__1 = k + 1 + k * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + z_div(&z__1, &w[k + 1 + (k + 1) * w_dim1], &d21); + d11.r = z__1.r, d11.i = z__1.i; + d_cnjg(&z__2, &d21); + z_div(&z__1, &w[k + k * w_dim1], &z__2); + d22.r = z__1.r, d22.i = z__1.i; + z__1.r = d11.r * d22.r - d11.i * d22.i, z__1.i = d11.r * + d22.i + d11.i * d22.r; + t = 1. / (z__1.r - 1.); + +/* Update elements in columns A(k) and A(k+1) as */ +/* dot products of rows of ( W(k) W(k+1) ) and columns */ +/* of D**(-1) */ + + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + i__3 = j + k * w_dim1; + z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + (k + 1) * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + d_cnjg(&z__5, &d21); + z_div(&z__2, &z__3, &z__5); + z__1.r = t * z__2.r, z__1.i = t * z__2.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + (k + 1) * a_dim1; + i__3 = j + (k + 1) * w_dim1; + z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + k * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + z_div(&z__2, &z__3, &d21); + z__1.r = t * z__2.r, z__1.i = t * z__2.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L80: */ + } + } + +/* Copy D(k) to A */ + + i__1 = k + k * a_dim1; + i__2 = k + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + k * a_dim1; + i__2 = k + 1 + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + (k + 1) * a_dim1; + i__2 = k + 1 + (k + 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + +/* (2) Conjugate columns W(k) and W(k+1) */ + + i__1 = *n - k; + zlacgv_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = *n - k - 1; + zlacgv_(&i__1, &w[k + 2 + (k + 1) * w_dim1], &c__1); + + } + + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + goto L70; + +L90: + +/* Update the lower triangle of A22 (= A(k:n,k:n)) as */ + +/* A22 := A22 - L21*D*L21**H = A22 - L21*W**H */ + +/* computing blocks of NB columns at a time (note that conjg(W) is */ +/* actually stored) */ + + i__1 = *n; + i__2 = *nb; + for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = *nb, i__4 = *n - j + 1; + jb = f2cmin(i__3,i__4); + +/* Update the lower triangle of the diagonal block */ + + i__3 = j + jb - 1; + for (jj = j; jj <= i__3; ++jj) { + i__4 = jj + jj * a_dim1; + i__5 = jj + jj * a_dim1; + d__1 = a[i__5].r; + a[i__4].r = d__1, a[i__4].i = 0.; + i__4 = j + jb - jj; + i__5 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__4, &i__5, &z__1, &a[jj + a_dim1], + lda, &w[jj + w_dim1], ldw, &c_b1, &a[jj + jj * a_dim1] + , &c__1); + i__4 = jj + jj * a_dim1; + i__5 = jj + jj * a_dim1; + d__1 = a[i__5].r; + a[i__4].r = d__1, a[i__4].i = 0.; +/* L100: */ + } + +/* Update the rectangular subdiagonal block */ + + if (j + jb <= *n) { + i__3 = *n - j - jb + 1; + i__4 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &z__1, + &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b1, + &a[j + jb + j * a_dim1], lda); + } +/* L110: */ + } + +/* Put L21 in standard form by partially undoing the interchanges */ +/* of rows in columns 1:k-1 looping backwards from k-1 to 1 */ + + j = k - 1; +L120: + +/* Undo the interchanges (if any) of rows J and JP2 */ +/* (or J and JP2, and J-1 and JP1) at each step J */ + + kstep = 1; + jp1 = 1; +/* (Here, J is a diagonal index) */ + jj = j; + jp2 = ipiv[j]; + if (jp2 < 0) { + jp2 = -jp2; +/* (Here, J is a diagonal index) */ + --j; + jp1 = -ipiv[j]; + kstep = 2; + } +/* (NOTE: Here, J is used to determine row length. Length J */ +/* of the rows to swap back doesn't include diagonal element) */ + --j; + if (jp2 != jj && j >= 1) { + zswap_(&j, &a[jp2 + a_dim1], lda, &a[jj + a_dim1], lda); + } + --jj; + if (kstep == 2 && jp1 != jj && j >= 1) { + zswap_(&j, &a[jp1 + a_dim1], lda, &a[jj + a_dim1], lda); + } + if (j > 1) { + goto L120; + } + +/* Set KB to the number of columns factorized */ + + *kb = k - 1; + + } + return 0; + +/* End of ZLAHEF_ROOK */ + +} /* zlahef_rook__ */ + diff --git a/lapack-netlib/SRC/zlahqr.c b/lapack-netlib/SRC/zlahqr.c new file mode 100644 index 000000000..381e0f1d4 --- /dev/null +++ b/lapack-netlib/SRC/zlahqr.c @@ -0,0 +1,1202 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAHQR computes the eigenvalues and Schur factorization of an upper Hessenberg matrix, using th +e double-shift/single-shift QR algorithm. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAHQR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, */ +/* IHIZ, Z, LDZ, INFO ) */ + +/* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N */ +/* LOGICAL WANTT, WANTZ */ +/* COMPLEX*16 H( LDH, * ), W( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAHQR is an auxiliary routine called by CHSEQR to update the */ +/* > eigenvalues and Schur decomposition already computed by CHSEQR, by */ +/* > dealing with the Hessenberg submatrix in rows and columns ILO to */ +/* > IHI. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] WANTT */ +/* > \verbatim */ +/* > WANTT is LOGICAL */ +/* > = .TRUE. : the full Schur form T is required; */ +/* > = .FALSE.: only eigenvalues are required. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTZ */ +/* > \verbatim */ +/* > WANTZ is LOGICAL */ +/* > = .TRUE. : the matrix of Schur vectors Z is required; */ +/* > = .FALSE.: Schur vectors are not required. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix H. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILO */ +/* > \verbatim */ +/* > ILO is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHI */ +/* > \verbatim */ +/* > IHI is INTEGER */ +/* > It is assumed that H is already upper triangular in rows and */ +/* > columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1). */ +/* > ZLAHQR works primarily with the Hessenberg submatrix in rows */ +/* > and columns ILO to IHI, but applies transformations to all of */ +/* > H if WANTT is .TRUE.. */ +/* > 1 <= ILO <= f2cmax(1,IHI); IHI <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] H */ +/* > \verbatim */ +/* > H is COMPLEX*16 array, dimension (LDH,N) */ +/* > On entry, the upper Hessenberg matrix H. */ +/* > On exit, if INFO is zero and if WANTT is .TRUE., then H */ +/* > is upper triangular in rows and columns ILO:IHI. If INFO */ +/* > is zero and if WANTT is .FALSE., then the contents of H */ +/* > are unspecified on exit. The output state of H in case */ +/* > INF is positive is below under the description of INFO. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > The leading dimension of the array H. LDH >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is COMPLEX*16 array, dimension (N) */ +/* > The computed eigenvalues ILO to IHI are stored in the */ +/* > corresponding elements of W. If WANTT is .TRUE., the */ +/* > eigenvalues are stored in the same order as on the diagonal */ +/* > of the Schur form returned in H, with W(i) = H(i,i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILOZ */ +/* > \verbatim */ +/* > ILOZ is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHIZ */ +/* > \verbatim */ +/* > IHIZ is INTEGER */ +/* > Specify the rows of Z to which transformations must be */ +/* > applied if WANTZ is .TRUE.. */ +/* > 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX*16 array, dimension (LDZ,N) */ +/* > If WANTZ is .TRUE., on entry Z must contain the current */ +/* > matrix Z of transformations accumulated by CHSEQR, and on */ +/* > exit Z has been updated; transformations are applied only to */ +/* > the submatrix Z(ILOZ:IHIZ,ILO:IHI). */ +/* > If WANTZ is .FALSE., Z is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > > 0: if INFO = i, ZLAHQR failed to compute all the */ +/* > eigenvalues ILO to IHI in a total of 30 iterations */ +/* > per eigenvalue; elements i+1:ihi of W contain */ +/* > those eigenvalues which have been successfully */ +/* > computed. */ +/* > */ +/* > If INFO > 0 and WANTT is .FALSE., then on exit, */ +/* > the remaining unconverged eigenvalues are the */ +/* > eigenvalues of the upper Hessenberg matrix */ +/* > rows and columns ILO through INFO of the final, */ +/* > output value of H. */ +/* > */ +/* > If INFO > 0 and WANTT is .TRUE., then on exit */ +/* > (*) (initial value of H)*U = U*(final value of H) */ +/* > where U is an orthogonal matrix. The final */ +/* > value of H is upper Hessenberg and triangular in */ +/* > rows and columns INFO+1 through IHI. */ +/* > */ +/* > If INFO > 0 and WANTZ is .TRUE., then on exit */ +/* > (final value of Z) = (initial value of Z)*U */ +/* > where U is the orthogonal matrix in (*) */ +/* > (regardless of the value of WANTT.) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > 02-96 Based on modifications by */ +/* > David Day, Sandia National Laboratory, USA */ +/* > */ +/* > 12-04 Further modifications by */ +/* > Ralph Byers, University of Kansas, USA */ +/* > This is a modified version of ZLAHQR from LAPACK version 3.0. */ +/* > It is (1) more robust against overflow and underflow and */ +/* > (2) adopts the more conservative Ahues & Tisseur stopping */ +/* > criterion (LAWN 122, 1997). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlahqr_(logical *wantt, logical *wantz, integer *n, + integer *ilo, integer *ihi, doublecomplex *h__, integer *ldh, + doublecomplex *w, integer *iloz, integer *ihiz, doublecomplex *z__, + integer *ldz, integer *info) +{ + /* System generated locals */ + integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; + doublereal d__1, d__2, d__3, d__4, d__5, d__6; + doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7; + + /* Local variables */ + doublecomplex temp; + integer i__, j, k, l, m; + doublereal s; + doublecomplex t, u, v[2], x, y; + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *); + integer itmax; + doublereal rtemp; + integer i1, i2; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + doublecomplex t1; + doublereal t2; + doublecomplex v2; + doublereal aa, ab, ba, bb; + extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); + doublereal h10; + doublecomplex h11; + doublereal h21; + doublecomplex h22, sc; + integer nh; + extern doublereal dlamch_(char *); + integer nz; + doublereal sx, safmin, safmax; + extern /* Subroutine */ int zlarfg_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *); + extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *, + doublecomplex *); + doublereal smlnum; + integer jhi; + doublecomplex h11s; + integer jlo, its; + doublereal ulp; + doublecomplex sum; + doublereal tst; + + +/* -- 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 */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + if (*ilo == *ihi) { + i__1 = *ilo; + i__2 = *ilo + *ilo * h_dim1; + w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i; + return 0; + } + +/* ==== clear out the trash ==== */ + i__1 = *ihi - 3; + for (j = *ilo; j <= i__1; ++j) { + i__2 = j + 2 + j * h_dim1; + h__[i__2].r = 0., h__[i__2].i = 0.; + i__2 = j + 3 + j * h_dim1; + h__[i__2].r = 0., h__[i__2].i = 0.; +/* L10: */ + } + if (*ilo <= *ihi - 2) { + i__1 = *ihi + (*ihi - 2) * h_dim1; + h__[i__1].r = 0., h__[i__1].i = 0.; + } +/* ==== ensure that subdiagonal entries are real ==== */ + if (*wantt) { + jlo = 1; + jhi = *n; + } else { + jlo = *ilo; + jhi = *ihi; + } + i__1 = *ihi; + for (i__ = *ilo + 1; i__ <= i__1; ++i__) { + if (d_imag(&h__[i__ + (i__ - 1) * h_dim1]) != 0.) { +/* ==== The following redundant normalization */ +/* . avoids problems with both gradual and */ +/* . sudden underflow in ABS(H(I,I-1)) ==== */ + i__2 = i__ + (i__ - 1) * h_dim1; + i__3 = i__ + (i__ - 1) * h_dim1; + d__3 = (d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(&h__[i__ + + (i__ - 1) * h_dim1]), abs(d__2)); + z__1.r = h__[i__2].r / d__3, z__1.i = h__[i__2].i / d__3; + sc.r = z__1.r, sc.i = z__1.i; + d_cnjg(&z__2, &sc); + d__1 = z_abs(&sc); + z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1; + sc.r = z__1.r, sc.i = z__1.i; + i__2 = i__ + (i__ - 1) * h_dim1; + d__1 = z_abs(&h__[i__ + (i__ - 1) * h_dim1]); + h__[i__2].r = d__1, h__[i__2].i = 0.; + i__2 = jhi - i__ + 1; + zscal_(&i__2, &sc, &h__[i__ + i__ * h_dim1], ldh); +/* Computing MIN */ + i__3 = jhi, i__4 = i__ + 1; + i__2 = f2cmin(i__3,i__4) - jlo + 1; + d_cnjg(&z__1, &sc); + zscal_(&i__2, &z__1, &h__[jlo + i__ * h_dim1], &c__1); + if (*wantz) { + i__2 = *ihiz - *iloz + 1; + d_cnjg(&z__1, &sc); + zscal_(&i__2, &z__1, &z__[*iloz + i__ * z_dim1], &c__1); + } + } +/* L20: */ + } + + nh = *ihi - *ilo + 1; + nz = *ihiz - *iloz + 1; + +/* Set machine-dependent constants for the stopping criterion. */ + + safmin = dlamch_("SAFE MINIMUM"); + safmax = 1. / safmin; + dlabad_(&safmin, &safmax); + ulp = dlamch_("PRECISION"); + smlnum = safmin * ((doublereal) nh / ulp); + +/* I1 and I2 are the indices of the first row and last column of H */ +/* to which transformations must be applied. If eigenvalues only are */ +/* being computed, I1 and I2 are set inside the main loop. */ + + if (*wantt) { + i1 = 1; + i2 = *n; + } + +/* ITMAX is the total number of QR iterations allowed. */ + + itmax = f2cmax(10,nh) * 30; + +/* The main loop begins here. I is the loop index and decreases from */ +/* IHI to ILO in steps of 1. Each iteration of the loop works */ +/* with the active submatrix in rows and columns L to I. */ +/* Eigenvalues I+1 to IHI have already converged. Either L = ILO, or */ +/* H(L,L-1) is negligible so that the matrix splits. */ + + i__ = *ihi; +L30: + if (i__ < *ilo) { + goto L150; + } + +/* Perform QR iterations on rows and columns ILO to I until a */ +/* submatrix of order 1 splits off at the bottom because a */ +/* subdiagonal element has become negligible. */ + + l = *ilo; + i__1 = itmax; + for (its = 0; its <= i__1; ++its) { + +/* Look for a single small subdiagonal element. */ + + i__2 = l + 1; + for (k = i__; k >= i__2; --k) { + i__3 = k + (k - 1) * h_dim1; + if ((d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(&h__[k + (k + - 1) * h_dim1]), abs(d__2)) <= smlnum) { + goto L50; + } + i__3 = k - 1 + (k - 1) * h_dim1; + i__4 = k + k * h_dim1; + tst = (d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(&h__[k - 1 + + (k - 1) * h_dim1]), abs(d__2)) + ((d__3 = h__[i__4].r, + abs(d__3)) + (d__4 = d_imag(&h__[k + k * h_dim1]), abs( + d__4))); + if (tst == 0.) { + if (k - 2 >= *ilo) { + i__3 = k - 1 + (k - 2) * h_dim1; + tst += (d__1 = h__[i__3].r, abs(d__1)); + } + if (k + 1 <= *ihi) { + i__3 = k + 1 + k * h_dim1; + tst += (d__1 = h__[i__3].r, abs(d__1)); + } + } +/* ==== The following is a conservative small subdiagonal */ +/* . deflation criterion due to Ahues & Tisseur (LAWN 122, */ +/* . 1997). It has better mathematical foundation and */ +/* . improves accuracy in some examples. ==== */ + i__3 = k + (k - 1) * h_dim1; + if ((d__1 = h__[i__3].r, abs(d__1)) <= ulp * tst) { +/* Computing MAX */ + i__3 = k + (k - 1) * h_dim1; + i__4 = k - 1 + k * h_dim1; + d__5 = (d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(&h__[ + k + (k - 1) * h_dim1]), abs(d__2)), d__6 = (d__3 = + h__[i__4].r, abs(d__3)) + (d__4 = d_imag(&h__[k - 1 + + k * h_dim1]), abs(d__4)); + ab = f2cmax(d__5,d__6); +/* Computing MIN */ + i__3 = k + (k - 1) * h_dim1; + i__4 = k - 1 + k * h_dim1; + d__5 = (d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(&h__[ + k + (k - 1) * h_dim1]), abs(d__2)), d__6 = (d__3 = + h__[i__4].r, abs(d__3)) + (d__4 = d_imag(&h__[k - 1 + + k * h_dim1]), abs(d__4)); + ba = f2cmin(d__5,d__6); + i__3 = k - 1 + (k - 1) * h_dim1; + i__4 = k + k * h_dim1; + z__2.r = h__[i__3].r - h__[i__4].r, z__2.i = h__[i__3].i - + h__[i__4].i; + z__1.r = z__2.r, z__1.i = z__2.i; +/* Computing MAX */ + i__5 = k + k * h_dim1; + d__5 = (d__1 = h__[i__5].r, abs(d__1)) + (d__2 = d_imag(&h__[ + k + k * h_dim1]), abs(d__2)), d__6 = (d__3 = z__1.r, + abs(d__3)) + (d__4 = d_imag(&z__1), abs(d__4)); + aa = f2cmax(d__5,d__6); + i__3 = k - 1 + (k - 1) * h_dim1; + i__4 = k + k * h_dim1; + z__2.r = h__[i__3].r - h__[i__4].r, z__2.i = h__[i__3].i - + h__[i__4].i; + z__1.r = z__2.r, z__1.i = z__2.i; +/* Computing MIN */ + i__5 = k + k * h_dim1; + d__5 = (d__1 = h__[i__5].r, abs(d__1)) + (d__2 = d_imag(&h__[ + k + k * h_dim1]), abs(d__2)), d__6 = (d__3 = z__1.r, + abs(d__3)) + (d__4 = d_imag(&z__1), abs(d__4)); + bb = f2cmin(d__5,d__6); + s = aa + ab; +/* Computing MAX */ + d__1 = smlnum, d__2 = ulp * (bb * (aa / s)); + if (ba * (ab / s) <= f2cmax(d__1,d__2)) { + goto L50; + } + } +/* L40: */ + } +L50: + l = k; + if (l > *ilo) { + +/* H(L,L-1) is negligible */ + + i__2 = l + (l - 1) * h_dim1; + h__[i__2].r = 0., h__[i__2].i = 0.; + } + +/* Exit from loop if a submatrix of order 1 has split off. */ + + if (l >= i__) { + goto L140; + } + +/* Now the active submatrix is in rows and columns L to I. If */ +/* eigenvalues only are being computed, only the active submatrix */ +/* need be transformed. */ + + if (! (*wantt)) { + i1 = l; + i2 = i__; + } + + if (its == 10) { + +/* Exceptional shift. */ + + i__2 = l + 1 + l * h_dim1; + s = (d__1 = h__[i__2].r, abs(d__1)) * .75; + i__2 = l + l * h_dim1; + z__1.r = s + h__[i__2].r, z__1.i = h__[i__2].i; + t.r = z__1.r, t.i = z__1.i; + } else if (its == 20) { + +/* Exceptional shift. */ + + i__2 = i__ + (i__ - 1) * h_dim1; + s = (d__1 = h__[i__2].r, abs(d__1)) * .75; + i__2 = i__ + i__ * h_dim1; + z__1.r = s + h__[i__2].r, z__1.i = h__[i__2].i; + t.r = z__1.r, t.i = z__1.i; + } else { + +/* Wilkinson's shift. */ + + i__2 = i__ + i__ * h_dim1; + t.r = h__[i__2].r, t.i = h__[i__2].i; + z_sqrt(&z__2, &h__[i__ - 1 + i__ * h_dim1]); + z_sqrt(&z__3, &h__[i__ + (i__ - 1) * h_dim1]); + z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * + z__3.i + z__2.i * z__3.r; + u.r = z__1.r, u.i = z__1.i; + s = (d__1 = u.r, abs(d__1)) + (d__2 = d_imag(&u), abs(d__2)); + if (s != 0.) { + i__2 = i__ - 1 + (i__ - 1) * h_dim1; + z__2.r = h__[i__2].r - t.r, z__2.i = h__[i__2].i - t.i; + z__1.r = z__2.r * .5, z__1.i = z__2.i * .5; + x.r = z__1.r, x.i = z__1.i; + sx = (d__1 = x.r, abs(d__1)) + (d__2 = d_imag(&x), abs(d__2)); +/* Computing MAX */ + d__3 = s, d__4 = (d__1 = x.r, abs(d__1)) + (d__2 = d_imag(&x), + abs(d__2)); + s = f2cmax(d__3,d__4); + z__5.r = x.r / s, z__5.i = x.i / s; + pow_zi(&z__4, &z__5, &c__2); + z__7.r = u.r / s, z__7.i = u.i / s; + pow_zi(&z__6, &z__7, &c__2); + z__3.r = z__4.r + z__6.r, z__3.i = z__4.i + z__6.i; + z_sqrt(&z__2, &z__3); + z__1.r = s * z__2.r, z__1.i = s * z__2.i; + y.r = z__1.r, y.i = z__1.i; + if (sx > 0.) { + z__1.r = x.r / sx, z__1.i = x.i / sx; + z__2.r = x.r / sx, z__2.i = x.i / sx; + if (z__1.r * y.r + d_imag(&z__2) * d_imag(&y) < 0.) { + z__3.r = -y.r, z__3.i = -y.i; + y.r = z__3.r, y.i = z__3.i; + } + } + z__4.r = x.r + y.r, z__4.i = x.i + y.i; + zladiv_(&z__3, &u, &z__4); + z__2.r = u.r * z__3.r - u.i * z__3.i, z__2.i = u.r * z__3.i + + u.i * z__3.r; + z__1.r = t.r - z__2.r, z__1.i = t.i - z__2.i; + t.r = z__1.r, t.i = z__1.i; + } + } + +/* Look for two consecutive small subdiagonal elements. */ + + i__2 = l + 1; + for (m = i__ - 1; m >= i__2; --m) { + +/* Determine the effect of starting the single-shift QR */ +/* iteration at row M, and see if this would make H(M,M-1) */ +/* negligible. */ + + i__3 = m + m * h_dim1; + h11.r = h__[i__3].r, h11.i = h__[i__3].i; + i__3 = m + 1 + (m + 1) * h_dim1; + h22.r = h__[i__3].r, h22.i = h__[i__3].i; + z__1.r = h11.r - t.r, z__1.i = h11.i - t.i; + h11s.r = z__1.r, h11s.i = z__1.i; + i__3 = m + 1 + m * h_dim1; + h21 = h__[i__3].r; + s = (d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs(d__2)) + + abs(h21); + z__1.r = h11s.r / s, z__1.i = h11s.i / s; + h11s.r = z__1.r, h11s.i = z__1.i; + h21 /= s; + v[0].r = h11s.r, v[0].i = h11s.i; + v[1].r = h21, v[1].i = 0.; + i__3 = m + (m - 1) * h_dim1; + h10 = h__[i__3].r; + if (abs(h10) * abs(h21) <= ulp * (((d__1 = h11s.r, abs(d__1)) + ( + d__2 = d_imag(&h11s), abs(d__2))) * ((d__3 = h11.r, abs( + d__3)) + (d__4 = d_imag(&h11), abs(d__4)) + ((d__5 = + h22.r, abs(d__5)) + (d__6 = d_imag(&h22), abs(d__6)))))) { + goto L70; + } +/* L60: */ + } + i__2 = l + l * h_dim1; + h11.r = h__[i__2].r, h11.i = h__[i__2].i; + i__2 = l + 1 + (l + 1) * h_dim1; + h22.r = h__[i__2].r, h22.i = h__[i__2].i; + z__1.r = h11.r - t.r, z__1.i = h11.i - t.i; + h11s.r = z__1.r, h11s.i = z__1.i; + i__2 = l + 1 + l * h_dim1; + h21 = h__[i__2].r; + s = (d__1 = h11s.r, abs(d__1)) + (d__2 = d_imag(&h11s), abs(d__2)) + + abs(h21); + z__1.r = h11s.r / s, z__1.i = h11s.i / s; + h11s.r = z__1.r, h11s.i = z__1.i; + h21 /= s; + v[0].r = h11s.r, v[0].i = h11s.i; + v[1].r = h21, v[1].i = 0.; +L70: + +/* Single-shift QR step */ + + i__2 = i__ - 1; + for (k = m; k <= i__2; ++k) { + +/* The first iteration of this loop determines a reflection G */ +/* from the vector V and applies it from left and right to H, */ +/* thus creating a nonzero bulge below the subdiagonal. */ + +/* Each subsequent iteration determines a reflection G to */ +/* restore the Hessenberg form in the (K-1)th column, and thus */ +/* chases the bulge one step toward the bottom of the active */ +/* submatrix. */ + +/* V(2) is always real before the call to ZLARFG, and hence */ +/* after the call T2 ( = T1*V(2) ) is also real. */ + + if (k > m) { + zcopy_(&c__2, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1); + } + zlarfg_(&c__2, v, &v[1], &c__1, &t1); + if (k > m) { + i__3 = k + (k - 1) * h_dim1; + h__[i__3].r = v[0].r, h__[i__3].i = v[0].i; + i__3 = k + 1 + (k - 1) * h_dim1; + h__[i__3].r = 0., h__[i__3].i = 0.; + } + v2.r = v[1].r, v2.i = v[1].i; + z__1.r = t1.r * v2.r - t1.i * v2.i, z__1.i = t1.r * v2.i + t1.i * + v2.r; + t2 = z__1.r; + +/* Apply G from the left to transform the rows of the matrix */ +/* in columns K to I2. */ + + i__3 = i2; + for (j = k; j <= i__3; ++j) { + d_cnjg(&z__3, &t1); + i__4 = k + j * h_dim1; + z__2.r = z__3.r * h__[i__4].r - z__3.i * h__[i__4].i, z__2.i = + z__3.r * h__[i__4].i + z__3.i * h__[i__4].r; + i__5 = k + 1 + j * h_dim1; + z__4.r = t2 * h__[i__5].r, z__4.i = t2 * h__[i__5].i; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + sum.r = z__1.r, sum.i = z__1.i; + i__4 = k + j * h_dim1; + i__5 = k + j * h_dim1; + z__1.r = h__[i__5].r - sum.r, z__1.i = h__[i__5].i - sum.i; + h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; + i__4 = k + 1 + j * h_dim1; + i__5 = k + 1 + j * h_dim1; + z__2.r = sum.r * v2.r - sum.i * v2.i, z__2.i = sum.r * v2.i + + sum.i * v2.r; + z__1.r = h__[i__5].r - z__2.r, z__1.i = h__[i__5].i - z__2.i; + h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; +/* L80: */ + } + +/* Apply G from the right to transform the columns of the */ +/* matrix in rows I1 to f2cmin(K+2,I). */ + +/* Computing MIN */ + i__4 = k + 2; + i__3 = f2cmin(i__4,i__); + for (j = i1; j <= i__3; ++j) { + i__4 = j + k * h_dim1; + z__2.r = t1.r * h__[i__4].r - t1.i * h__[i__4].i, z__2.i = + t1.r * h__[i__4].i + t1.i * h__[i__4].r; + i__5 = j + (k + 1) * h_dim1; + z__3.r = t2 * h__[i__5].r, z__3.i = t2 * h__[i__5].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + sum.r = z__1.r, sum.i = z__1.i; + i__4 = j + k * h_dim1; + i__5 = j + k * h_dim1; + z__1.r = h__[i__5].r - sum.r, z__1.i = h__[i__5].i - sum.i; + h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; + i__4 = j + (k + 1) * h_dim1; + i__5 = j + (k + 1) * h_dim1; + d_cnjg(&z__3, &v2); + z__2.r = sum.r * z__3.r - sum.i * z__3.i, z__2.i = sum.r * + z__3.i + sum.i * z__3.r; + z__1.r = h__[i__5].r - z__2.r, z__1.i = h__[i__5].i - z__2.i; + h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; +/* L90: */ + } + + if (*wantz) { + +/* Accumulate transformations in the matrix Z */ + + i__3 = *ihiz; + for (j = *iloz; j <= i__3; ++j) { + i__4 = j + k * z_dim1; + z__2.r = t1.r * z__[i__4].r - t1.i * z__[i__4].i, z__2.i = + t1.r * z__[i__4].i + t1.i * z__[i__4].r; + i__5 = j + (k + 1) * z_dim1; + z__3.r = t2 * z__[i__5].r, z__3.i = t2 * z__[i__5].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + sum.r = z__1.r, sum.i = z__1.i; + i__4 = j + k * z_dim1; + i__5 = j + k * z_dim1; + z__1.r = z__[i__5].r - sum.r, z__1.i = z__[i__5].i - + sum.i; + z__[i__4].r = z__1.r, z__[i__4].i = z__1.i; + i__4 = j + (k + 1) * z_dim1; + i__5 = j + (k + 1) * z_dim1; + d_cnjg(&z__3, &v2); + z__2.r = sum.r * z__3.r - sum.i * z__3.i, z__2.i = sum.r * + z__3.i + sum.i * z__3.r; + z__1.r = z__[i__5].r - z__2.r, z__1.i = z__[i__5].i - + z__2.i; + z__[i__4].r = z__1.r, z__[i__4].i = z__1.i; +/* L100: */ + } + } + + if (k == m && m > l) { + +/* If the QR step was started at row M > L because two */ +/* consecutive small subdiagonals were found, then extra */ +/* scaling must be performed to ensure that H(M,M-1) remains */ +/* real. */ + + z__1.r = 1. - t1.r, z__1.i = 0. - t1.i; + temp.r = z__1.r, temp.i = z__1.i; + d__1 = z_abs(&temp); + z__1.r = temp.r / d__1, z__1.i = temp.i / d__1; + temp.r = z__1.r, temp.i = z__1.i; + i__3 = m + 1 + m * h_dim1; + i__4 = m + 1 + m * h_dim1; + d_cnjg(&z__2, &temp); + z__1.r = h__[i__4].r * z__2.r - h__[i__4].i * z__2.i, z__1.i = + h__[i__4].r * z__2.i + h__[i__4].i * z__2.r; + h__[i__3].r = z__1.r, h__[i__3].i = z__1.i; + if (m + 2 <= i__) { + i__3 = m + 2 + (m + 1) * h_dim1; + i__4 = m + 2 + (m + 1) * h_dim1; + z__1.r = h__[i__4].r * temp.r - h__[i__4].i * temp.i, + z__1.i = h__[i__4].r * temp.i + h__[i__4].i * + temp.r; + h__[i__3].r = z__1.r, h__[i__3].i = z__1.i; + } + i__3 = i__; + for (j = m; j <= i__3; ++j) { + if (j != m + 1) { + if (i2 > j) { + i__4 = i2 - j; + zscal_(&i__4, &temp, &h__[j + (j + 1) * h_dim1], + ldh); + } + i__4 = j - i1; + d_cnjg(&z__1, &temp); + zscal_(&i__4, &z__1, &h__[i1 + j * h_dim1], &c__1); + if (*wantz) { + d_cnjg(&z__1, &temp); + zscal_(&nz, &z__1, &z__[*iloz + j * z_dim1], & + c__1); + } + } +/* L110: */ + } + } +/* L120: */ + } + +/* Ensure that H(I,I-1) is real. */ + + i__2 = i__ + (i__ - 1) * h_dim1; + temp.r = h__[i__2].r, temp.i = h__[i__2].i; + if (d_imag(&temp) != 0.) { + rtemp = z_abs(&temp); + i__2 = i__ + (i__ - 1) * h_dim1; + h__[i__2].r = rtemp, h__[i__2].i = 0.; + z__1.r = temp.r / rtemp, z__1.i = temp.i / rtemp; + temp.r = z__1.r, temp.i = z__1.i; + if (i2 > i__) { + i__2 = i2 - i__; + d_cnjg(&z__1, &temp); + zscal_(&i__2, &z__1, &h__[i__ + (i__ + 1) * h_dim1], ldh); + } + i__2 = i__ - i1; + zscal_(&i__2, &temp, &h__[i1 + i__ * h_dim1], &c__1); + if (*wantz) { + zscal_(&nz, &temp, &z__[*iloz + i__ * z_dim1], &c__1); + } + } + +/* L130: */ + } + +/* Failure to converge in remaining number of iterations */ + + *info = i__; + return 0; + +L140: + +/* H(I,I-1) is negligible: one eigenvalue has converged. */ + + i__1 = i__; + i__2 = i__ + i__ * h_dim1; + w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i; + +/* return to start of the main loop with new value of I. */ + + i__ = l - 1; + goto L30; + +L150: + return 0; + +/* End of ZLAHQR */ + +} /* zlahqr_ */ + diff --git a/lapack-netlib/SRC/zlahr2.c b/lapack-netlib/SRC/zlahr2.c new file mode 100644 index 000000000..227c30fde --- /dev/null +++ b/lapack-netlib/SRC/zlahr2.c @@ -0,0 +1,783 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAHR2 reduces the specified number of first columns of a general rectangular matrix A so that +elements below the specified subdiagonal are zero, and returns auxiliary matrices which are needed to +apply the transformation to the unreduced part */ +/* of A. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAHR2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY ) */ + +/* INTEGER K, LDA, LDT, LDY, N, NB */ +/* COMPLEX*16 A( LDA, * ), T( LDT, NB ), TAU( NB ), */ +/* $ Y( LDY, NB ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAHR2 reduces the first NB columns of A complex general n-BY-(n-k+1) */ +/* > matrix A so that elements below the k-th subdiagonal are zero. The */ +/* > reduction is performed by an unitary similarity transformation */ +/* > Q**H * A * Q. The routine returns the matrices V and T which determine */ +/* > Q as a block reflector I - V*T*V**H, and also the matrix Y = A * V * T. */ +/* > */ +/* > This is an auxiliary routine called by ZGEHRD. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The offset for the reduction. Elements below the k-th */ +/* > subdiagonal in the first NB columns are reduced to zero. */ +/* > K < N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The number of columns to be reduced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N-K+1) */ +/* > On entry, the n-by-(n-k+1) general matrix A. */ +/* > On exit, the elements on and above the k-th subdiagonal in */ +/* > the first NB columns are overwritten with the corresponding */ +/* > elements of the reduced matrix; the elements below the k-th */ +/* > subdiagonal, with the array TAU, represent the matrix Q as a */ +/* > product of elementary reflectors. The other columns of A are */ +/* > unchanged. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 array, dimension (NB) */ +/* > The scalar factors of the elementary reflectors. See Further */ +/* > Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is COMPLEX*16 array, dimension (LDT,NB) */ +/* > The upper triangular matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Y */ +/* > \verbatim */ +/* > Y is COMPLEX*16 array, dimension (LDY,NB) */ +/* > The n-by-nb matrix Y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDY */ +/* > \verbatim */ +/* > LDY is INTEGER */ +/* > The leading dimension of the array Y. LDY >= N. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix Q is represented as a product of nb elementary reflectors */ +/* > */ +/* > Q = H(1) H(2) . . . H(nb). */ +/* > */ +/* > Each H(i) has the form */ +/* > */ +/* > H(i) = I - tau * v * v**H */ +/* > */ +/* > where tau is a complex scalar, and v is a complex vector with */ +/* > v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in */ +/* > A(i+k+1:n,i), and tau in TAU(i). */ +/* > */ +/* > The elements of the vectors v together form the (n-k+1)-by-nb matrix */ +/* > V which is needed, with T and Y, to apply the transformation to the */ +/* > unreduced part of the matrix, using an update of the form: */ +/* > A := (I - V*T*V**H) * (A - Y*V**H). */ +/* > */ +/* > The contents of A on exit are illustrated by the following example */ +/* > with n = 7, k = 3 and nb = 2: */ +/* > */ +/* > ( a a a a a ) */ +/* > ( a a a a a ) */ +/* > ( a a a a a ) */ +/* > ( h h a a a ) */ +/* > ( v1 h a a a ) */ +/* > ( v1 v2 a a a ) */ +/* > ( v1 v2 a a a ) */ +/* > */ +/* > where a denotes an element of the original matrix A, h denotes a */ +/* > modified element of the upper Hessenberg matrix H, and vi denotes an */ +/* > element of the vector defining H(i). */ +/* > */ +/* > This subroutine is a slight modification of LAPACK-3.0's DLAHRD */ +/* > incorporating improvements proposed by Quintana-Orti and Van de */ +/* > Gejin. Note that the entries of A(1:K,2:NB) differ from those */ +/* > returned by the original LAPACK-3.0's DLAHRD routine. (This */ +/* > subroutine is not backward compatible with LAPACK-3.0's DLAHRD.) */ +/* > \endverbatim */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > Gregorio Quintana-Orti and Robert van de Geijn, "Improving the */ +/* > performance of reduction to Hessenberg form," ACM Transactions on */ +/* > Mathematical Software, 32(2):180-194, June 2006. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlahr2_(integer *n, integer *k, integer *nb, + doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *t, + integer *ldt, doublecomplex *y, integer *ldy) +{ + /* System generated locals */ + integer a_dim1, a_offset, t_dim1, t_offset, y_dim1, y_offset, i__1, i__2, + i__3; + doublecomplex z__1; + + /* Local variables */ + integer i__; + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *), zgemm_(char *, char *, integer *, + integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *), zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *), + zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, + integer *), ztrmm_(char *, char *, char *, char *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *), + zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *), ztrmv_(char *, char *, char *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *); + doublecomplex ei; + extern /* Subroutine */ int zlarfg_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *), zlacgv_(integer *, + doublecomplex *, integer *), zlacpy_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + --tau; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + y -= y_offset; + + /* Function Body */ + if (*n <= 1) { + return 0; + } + + i__1 = *nb; + for (i__ = 1; i__ <= i__1; ++i__) { + if (i__ > 1) { + +/* Update A(K+1:N,I) */ + +/* Update I-th column of A - Y * V**H */ + + i__2 = i__ - 1; + zlacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda); + i__2 = *n - *k; + i__3 = i__ - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("NO TRANSPOSE", &i__2, &i__3, &z__1, &y[*k + 1 + y_dim1], + ldy, &a[*k + i__ - 1 + a_dim1], lda, &c_b2, &a[*k + 1 + + i__ * a_dim1], &c__1); + i__2 = i__ - 1; + zlacgv_(&i__2, &a[*k + i__ - 1 + a_dim1], lda); + +/* Apply I - V * T**H * V**H to this column (call it b) from the */ +/* left, using the last column of T as workspace */ + +/* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows) */ +/* ( V2 ) ( b2 ) */ + +/* where V1 is unit lower triangular */ + +/* w := V1**H * b1 */ + + i__2 = i__ - 1; + zcopy_(&i__2, &a[*k + 1 + i__ * a_dim1], &c__1, &t[*nb * t_dim1 + + 1], &c__1); + i__2 = i__ - 1; + ztrmv_("Lower", "Conjugate transpose", "UNIT", &i__2, &a[*k + 1 + + a_dim1], lda, &t[*nb * t_dim1 + 1], &c__1); + +/* w := w + V2**H * b2 */ + + i__2 = *n - *k - i__ + 1; + i__3 = i__ - 1; + zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + + a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b2, & + t[*nb * t_dim1 + 1], &c__1); + +/* w := T**H * w */ + + i__2 = i__ - 1; + ztrmv_("Upper", "Conjugate transpose", "NON-UNIT", &i__2, &t[ + t_offset], ldt, &t[*nb * t_dim1 + 1], &c__1); + +/* b2 := b2 - V2*w */ + + i__2 = *n - *k - i__ + 1; + i__3 = i__ - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("NO TRANSPOSE", &i__2, &i__3, &z__1, &a[*k + i__ + a_dim1], + lda, &t[*nb * t_dim1 + 1], &c__1, &c_b2, &a[*k + i__ + + i__ * a_dim1], &c__1); + +/* b1 := b1 - V1*w */ + + i__2 = i__ - 1; + ztrmv_("Lower", "NO TRANSPOSE", "UNIT", &i__2, &a[*k + 1 + a_dim1] + , lda, &t[*nb * t_dim1 + 1], &c__1); + i__2 = i__ - 1; + z__1.r = -1., z__1.i = 0.; + zaxpy_(&i__2, &z__1, &t[*nb * t_dim1 + 1], &c__1, &a[*k + 1 + i__ + * a_dim1], &c__1); + + i__2 = *k + i__ - 1 + (i__ - 1) * a_dim1; + a[i__2].r = ei.r, a[i__2].i = ei.i; + } + +/* Generate the elementary reflector H(I) to annihilate */ +/* A(K+I+1:N,I) */ + + i__2 = *n - *k - i__ + 1; +/* Computing MIN */ + i__3 = *k + i__ + 1; + zlarfg_(&i__2, &a[*k + i__ + i__ * a_dim1], &a[f2cmin(i__3,*n) + i__ * + a_dim1], &c__1, &tau[i__]); + i__2 = *k + i__ + i__ * a_dim1; + ei.r = a[i__2].r, ei.i = a[i__2].i; + i__2 = *k + i__ + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + +/* Compute Y(K+1:N,I) */ + + i__2 = *n - *k; + i__3 = *n - *k - i__ + 1; + zgemv_("NO TRANSPOSE", &i__2, &i__3, &c_b2, &a[*k + 1 + (i__ + 1) * + a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &y[* + k + 1 + i__ * y_dim1], &c__1); + i__2 = *n - *k - i__ + 1; + i__3 = i__ - 1; + zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[*k + i__ + + a_dim1], lda, &a[*k + i__ + i__ * a_dim1], &c__1, &c_b1, &t[ + i__ * t_dim1 + 1], &c__1); + i__2 = *n - *k; + i__3 = i__ - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("NO TRANSPOSE", &i__2, &i__3, &z__1, &y[*k + 1 + y_dim1], ldy, + &t[i__ * t_dim1 + 1], &c__1, &c_b2, &y[*k + 1 + i__ * y_dim1], + &c__1); + i__2 = *n - *k; + zscal_(&i__2, &tau[i__], &y[*k + 1 + i__ * y_dim1], &c__1); + +/* Compute T(1:I,I) */ + + i__2 = i__ - 1; + i__3 = i__; + z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; + zscal_(&i__2, &z__1, &t[i__ * t_dim1 + 1], &c__1); + i__2 = i__ - 1; + ztrmv_("Upper", "No Transpose", "NON-UNIT", &i__2, &t[t_offset], ldt, + &t[i__ * t_dim1 + 1], &c__1) + ; + i__2 = i__ + i__ * t_dim1; + i__3 = i__; + t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; + +/* L10: */ + } + i__1 = *k + *nb + *nb * a_dim1; + a[i__1].r = ei.r, a[i__1].i = ei.i; + +/* Compute Y(1:K,1:NB) */ + + zlacpy_("ALL", k, nb, &a[(a_dim1 << 1) + 1], lda, &y[y_offset], ldy); + ztrmm_("RIGHT", "Lower", "NO TRANSPOSE", "UNIT", k, nb, &c_b2, &a[*k + 1 + + a_dim1], lda, &y[y_offset], ldy); + if (*n > *k + *nb) { + i__1 = *n - *k - *nb; + zgemm_("NO TRANSPOSE", "NO TRANSPOSE", k, nb, &i__1, &c_b2, &a[(*nb + + 2) * a_dim1 + 1], lda, &a[*k + 1 + *nb + a_dim1], lda, &c_b2, + &y[y_offset], ldy); + } + ztrmm_("RIGHT", "Upper", "NO TRANSPOSE", "NON-UNIT", k, nb, &c_b2, &t[ + t_offset], ldt, &y[y_offset], ldy); + + return 0; + +/* End of ZLAHR2 */ + +} /* zlahr2_ */ + diff --git a/lapack-netlib/SRC/zlaic1.c b/lapack-netlib/SRC/zlaic1.c new file mode 100644 index 000000000..db0fb05bd --- /dev/null +++ b/lapack-netlib/SRC/zlaic1.c @@ -0,0 +1,880 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAIC1 applies one step of incremental condition estimation. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAIC1 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C ) */ + +/* INTEGER J, JOB */ +/* DOUBLE PRECISION SEST, SESTPR */ +/* COMPLEX*16 C, GAMMA, S */ +/* COMPLEX*16 W( J ), X( J ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAIC1 applies one step of incremental condition estimation in */ +/* > its simplest version: */ +/* > */ +/* > Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j */ +/* > lower triangular matrix L, such that */ +/* > twonorm(L*x) = sest */ +/* > Then ZLAIC1 computes sestpr, s, c such that */ +/* > the vector */ +/* > [ s*x ] */ +/* > xhat = [ c ] */ +/* > is an approximate singular vector of */ +/* > [ L 0 ] */ +/* > Lhat = [ w**H gamma ] */ +/* > in the sense that */ +/* > twonorm(Lhat*xhat) = sestpr. */ +/* > */ +/* > Depending on JOB, an estimate for the largest or smallest singular */ +/* > value is computed. */ +/* > */ +/* > Note that [s c]**H and sestpr**2 is an eigenpair of the system */ +/* > */ +/* > diag(sest*sest, 0) + [alpha gamma] * [ conjg(alpha) ] */ +/* > [ conjg(gamma) ] */ +/* > */ +/* > where alpha = x**H * w. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOB */ +/* > \verbatim */ +/* > JOB is INTEGER */ +/* > = 1: an estimate for the largest singular value is computed. */ +/* > = 2: an estimate for the smallest singular value is computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] J */ +/* > \verbatim */ +/* > J is INTEGER */ +/* > Length of X and W */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (J) */ +/* > The j-vector x. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SEST */ +/* > \verbatim */ +/* > SEST is DOUBLE PRECISION */ +/* > Estimated singular value of j by j matrix L */ +/* > \endverbatim */ +/* > */ +/* > \param[in] W */ +/* > \verbatim */ +/* > W is COMPLEX*16 array, dimension (J) */ +/* > The j-vector w. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GAMMA */ +/* > \verbatim */ +/* > GAMMA is COMPLEX*16 */ +/* > The diagonal element gamma. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SESTPR */ +/* > \verbatim */ +/* > SESTPR is DOUBLE PRECISION */ +/* > Estimated singular value of (j+1) by (j+1) matrix Lhat. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is COMPLEX*16 */ +/* > Sine needed in forming xhat. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] C */ +/* > \verbatim */ +/* > C is COMPLEX*16 */ +/* > Cosine needed in forming xhat. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlaic1_(integer *job, integer *j, doublecomplex *x, + doublereal *sest, doublecomplex *w, doublecomplex *gamma, doublereal * + sestpr, doublecomplex *s, doublecomplex *c__) +{ + /* System generated locals */ + doublereal d__1, d__2; + doublecomplex z__1, z__2, z__3, z__4, z__5, z__6; + + /* Local variables */ + doublecomplex sine; + doublereal test, zeta1, zeta2, b, t; + doublecomplex alpha; + doublereal norma; + extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + doublereal s1, s2; + extern doublereal dlamch_(char *); + doublereal absgam, absalp; + doublecomplex cosine; + doublereal absest, scl, eps, 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 */ + --w; + --x; + + /* Function Body */ + eps = dlamch_("Epsilon"); + zdotc_(&z__1, j, &x[1], &c__1, &w[1], &c__1); + alpha.r = z__1.r, alpha.i = z__1.i; + + absalp = z_abs(&alpha); + absgam = z_abs(gamma); + absest = abs(*sest); + + if (*job == 1) { + +/* Estimating largest singular value */ + +/* special cases */ + + if (*sest == 0.) { + s1 = f2cmax(absgam,absalp); + if (s1 == 0.) { + s->r = 0., s->i = 0.; + c__->r = 1., c__->i = 0.; + *sestpr = 0.; + } else { + z__1.r = alpha.r / s1, z__1.i = alpha.i / s1; + s->r = z__1.r, s->i = z__1.i; + z__1.r = gamma->r / s1, z__1.i = gamma->i / s1; + c__->r = z__1.r, c__->i = z__1.i; + d_cnjg(&z__4, s); + z__3.r = s->r * z__4.r - s->i * z__4.i, z__3.i = s->r * + z__4.i + s->i * z__4.r; + d_cnjg(&z__6, c__); + z__5.r = c__->r * z__6.r - c__->i * z__6.i, z__5.i = c__->r * + z__6.i + c__->i * z__6.r; + z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i; + z_sqrt(&z__1, &z__2); + tmp = z__1.r; + z__1.r = s->r / tmp, z__1.i = s->i / tmp; + s->r = z__1.r, s->i = z__1.i; + z__1.r = c__->r / tmp, z__1.i = c__->i / tmp; + c__->r = z__1.r, c__->i = z__1.i; + *sestpr = s1 * tmp; + } + return 0; + } else if (absgam <= eps * absest) { + s->r = 1., s->i = 0.; + c__->r = 0., c__->i = 0.; + tmp = f2cmax(absest,absalp); + s1 = absest / tmp; + s2 = absalp / tmp; + *sestpr = tmp * sqrt(s1 * s1 + s2 * s2); + return 0; + } else if (absalp <= eps * absest) { + s1 = absgam; + s2 = absest; + if (s1 <= s2) { + s->r = 1., s->i = 0.; + c__->r = 0., c__->i = 0.; + *sestpr = s2; + } else { + s->r = 0., s->i = 0.; + c__->r = 1., c__->i = 0.; + *sestpr = s1; + } + return 0; + } else if (absest <= eps * absalp || absest <= eps * absgam) { + s1 = absgam; + s2 = absalp; + if (s1 <= s2) { + tmp = s1 / s2; + scl = sqrt(tmp * tmp + 1.); + *sestpr = s2 * scl; + z__2.r = alpha.r / s2, z__2.i = alpha.i / s2; + z__1.r = z__2.r / scl, z__1.i = z__2.i / scl; + s->r = z__1.r, s->i = z__1.i; + z__2.r = gamma->r / s2, z__2.i = gamma->i / s2; + z__1.r = z__2.r / scl, z__1.i = z__2.i / scl; + c__->r = z__1.r, c__->i = z__1.i; + } else { + tmp = s2 / s1; + scl = sqrt(tmp * tmp + 1.); + *sestpr = s1 * scl; + z__2.r = alpha.r / s1, z__2.i = alpha.i / s1; + z__1.r = z__2.r / scl, z__1.i = z__2.i / scl; + s->r = z__1.r, s->i = z__1.i; + z__2.r = gamma->r / s1, z__2.i = gamma->i / s1; + z__1.r = z__2.r / scl, z__1.i = z__2.i / scl; + c__->r = z__1.r, c__->i = z__1.i; + } + return 0; + } else { + +/* normal case */ + + zeta1 = absalp / absest; + zeta2 = absgam / absest; + + b = (1. - zeta1 * zeta1 - zeta2 * zeta2) * .5; + d__1 = zeta1 * zeta1; + c__->r = d__1, c__->i = 0.; + if (b > 0.) { + d__1 = b * b; + z__4.r = d__1 + c__->r, z__4.i = c__->i; + z_sqrt(&z__3, &z__4); + z__2.r = b + z__3.r, z__2.i = z__3.i; + z_div(&z__1, c__, &z__2); + t = z__1.r; + } else { + d__1 = b * b; + z__3.r = d__1 + c__->r, z__3.i = c__->i; + z_sqrt(&z__2, &z__3); + z__1.r = z__2.r - b, z__1.i = z__2.i; + t = z__1.r; + } + + z__3.r = alpha.r / absest, z__3.i = alpha.i / absest; + z__2.r = -z__3.r, z__2.i = -z__3.i; + z__1.r = z__2.r / t, z__1.i = z__2.i / t; + sine.r = z__1.r, sine.i = z__1.i; + z__3.r = gamma->r / absest, z__3.i = gamma->i / absest; + z__2.r = -z__3.r, z__2.i = -z__3.i; + d__1 = t + 1.; + z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1; + cosine.r = z__1.r, cosine.i = z__1.i; + d_cnjg(&z__4, &sine); + z__3.r = sine.r * z__4.r - sine.i * z__4.i, z__3.i = sine.r * + z__4.i + sine.i * z__4.r; + d_cnjg(&z__6, &cosine); + z__5.r = cosine.r * z__6.r - cosine.i * z__6.i, z__5.i = cosine.r + * z__6.i + cosine.i * z__6.r; + z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i; + z_sqrt(&z__1, &z__2); + tmp = z__1.r; + z__1.r = sine.r / tmp, z__1.i = sine.i / tmp; + s->r = z__1.r, s->i = z__1.i; + z__1.r = cosine.r / tmp, z__1.i = cosine.i / tmp; + c__->r = z__1.r, c__->i = z__1.i; + *sestpr = sqrt(t + 1.) * absest; + return 0; + } + + } else if (*job == 2) { + +/* Estimating smallest singular value */ + +/* special cases */ + + if (*sest == 0.) { + *sestpr = 0.; + if (f2cmax(absgam,absalp) == 0.) { + sine.r = 1., sine.i = 0.; + cosine.r = 0., cosine.i = 0.; + } else { + d_cnjg(&z__2, gamma); + z__1.r = -z__2.r, z__1.i = -z__2.i; + sine.r = z__1.r, sine.i = z__1.i; + d_cnjg(&z__1, &alpha); + cosine.r = z__1.r, cosine.i = z__1.i; + } +/* Computing MAX */ + d__1 = z_abs(&sine), d__2 = z_abs(&cosine); + s1 = f2cmax(d__1,d__2); + z__1.r = sine.r / s1, z__1.i = sine.i / s1; + s->r = z__1.r, s->i = z__1.i; + z__1.r = cosine.r / s1, z__1.i = cosine.i / s1; + c__->r = z__1.r, c__->i = z__1.i; + d_cnjg(&z__4, s); + z__3.r = s->r * z__4.r - s->i * z__4.i, z__3.i = s->r * z__4.i + + s->i * z__4.r; + d_cnjg(&z__6, c__); + z__5.r = c__->r * z__6.r - c__->i * z__6.i, z__5.i = c__->r * + z__6.i + c__->i * z__6.r; + z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i; + z_sqrt(&z__1, &z__2); + tmp = z__1.r; + z__1.r = s->r / tmp, z__1.i = s->i / tmp; + s->r = z__1.r, s->i = z__1.i; + z__1.r = c__->r / tmp, z__1.i = c__->i / tmp; + c__->r = z__1.r, c__->i = z__1.i; + return 0; + } else if (absgam <= eps * absest) { + s->r = 0., s->i = 0.; + c__->r = 1., c__->i = 0.; + *sestpr = absgam; + return 0; + } else if (absalp <= eps * absest) { + s1 = absgam; + s2 = absest; + if (s1 <= s2) { + s->r = 0., s->i = 0.; + c__->r = 1., c__->i = 0.; + *sestpr = s1; + } else { + s->r = 1., s->i = 0.; + c__->r = 0., c__->i = 0.; + *sestpr = s2; + } + return 0; + } else if (absest <= eps * absalp || absest <= eps * absgam) { + s1 = absgam; + s2 = absalp; + if (s1 <= s2) { + tmp = s1 / s2; + scl = sqrt(tmp * tmp + 1.); + *sestpr = absest * (tmp / scl); + d_cnjg(&z__4, gamma); + z__3.r = z__4.r / s2, z__3.i = z__4.i / s2; + z__2.r = -z__3.r, z__2.i = -z__3.i; + z__1.r = z__2.r / scl, z__1.i = z__2.i / scl; + s->r = z__1.r, s->i = z__1.i; + d_cnjg(&z__3, &alpha); + z__2.r = z__3.r / s2, z__2.i = z__3.i / s2; + z__1.r = z__2.r / scl, z__1.i = z__2.i / scl; + c__->r = z__1.r, c__->i = z__1.i; + } else { + tmp = s2 / s1; + scl = sqrt(tmp * tmp + 1.); + *sestpr = absest / scl; + d_cnjg(&z__4, gamma); + z__3.r = z__4.r / s1, z__3.i = z__4.i / s1; + z__2.r = -z__3.r, z__2.i = -z__3.i; + z__1.r = z__2.r / scl, z__1.i = z__2.i / scl; + s->r = z__1.r, s->i = z__1.i; + d_cnjg(&z__3, &alpha); + z__2.r = z__3.r / s1, z__2.i = z__3.i / s1; + z__1.r = z__2.r / scl, z__1.i = z__2.i / scl; + c__->r = z__1.r, c__->i = z__1.i; + } + return 0; + } else { + +/* normal case */ + + zeta1 = absalp / absest; + zeta2 = absgam / absest; + +/* Computing MAX */ + d__1 = zeta1 * zeta1 + 1. + zeta1 * zeta2, d__2 = zeta1 * zeta2 + + zeta2 * zeta2; + norma = f2cmax(d__1,d__2); + +/* See if root is closer to zero or to ONE */ + + test = (zeta1 - zeta2) * 2. * (zeta1 + zeta2) + 1.; + if (test >= 0.) { + +/* root is close to zero, compute directly */ + + b = (zeta1 * zeta1 + zeta2 * zeta2 + 1.) * .5; + d__1 = zeta2 * zeta2; + c__->r = d__1, c__->i = 0.; + d__2 = b * b; + z__2.r = d__2 - c__->r, z__2.i = -c__->i; + d__1 = b + sqrt(z_abs(&z__2)); + z__1.r = c__->r / d__1, z__1.i = c__->i / d__1; + t = z__1.r; + z__2.r = alpha.r / absest, z__2.i = alpha.i / absest; + d__1 = 1. - t; + z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1; + sine.r = z__1.r, sine.i = z__1.i; + z__3.r = gamma->r / absest, z__3.i = gamma->i / absest; + z__2.r = -z__3.r, z__2.i = -z__3.i; + z__1.r = z__2.r / t, z__1.i = z__2.i / t; + cosine.r = z__1.r, cosine.i = z__1.i; + *sestpr = sqrt(t + eps * 4. * eps * norma) * absest; + } else { + +/* root is closer to ONE, shift by that amount */ + + b = (zeta2 * zeta2 + zeta1 * zeta1 - 1.) * .5; + d__1 = zeta1 * zeta1; + c__->r = d__1, c__->i = 0.; + if (b >= 0.) { + z__2.r = -c__->r, z__2.i = -c__->i; + d__1 = b * b; + z__5.r = d__1 + c__->r, z__5.i = c__->i; + z_sqrt(&z__4, &z__5); + z__3.r = b + z__4.r, z__3.i = z__4.i; + z_div(&z__1, &z__2, &z__3); + t = z__1.r; + } else { + d__1 = b * b; + z__3.r = d__1 + c__->r, z__3.i = c__->i; + z_sqrt(&z__2, &z__3); + z__1.r = b - z__2.r, z__1.i = -z__2.i; + t = z__1.r; + } + z__3.r = alpha.r / absest, z__3.i = alpha.i / absest; + z__2.r = -z__3.r, z__2.i = -z__3.i; + z__1.r = z__2.r / t, z__1.i = z__2.i / t; + sine.r = z__1.r, sine.i = z__1.i; + z__3.r = gamma->r / absest, z__3.i = gamma->i / absest; + z__2.r = -z__3.r, z__2.i = -z__3.i; + d__1 = t + 1.; + z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1; + cosine.r = z__1.r, cosine.i = z__1.i; + *sestpr = sqrt(t + 1. + eps * 4. * eps * norma) * absest; + } + d_cnjg(&z__4, &sine); + z__3.r = sine.r * z__4.r - sine.i * z__4.i, z__3.i = sine.r * + z__4.i + sine.i * z__4.r; + d_cnjg(&z__6, &cosine); + z__5.r = cosine.r * z__6.r - cosine.i * z__6.i, z__5.i = cosine.r + * z__6.i + cosine.i * z__6.r; + z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i; + z_sqrt(&z__1, &z__2); + tmp = z__1.r; + z__1.r = sine.r / tmp, z__1.i = sine.i / tmp; + s->r = z__1.r, s->i = z__1.i; + z__1.r = cosine.r / tmp, z__1.i = cosine.i / tmp; + c__->r = z__1.r, c__->i = z__1.i; + return 0; + + } + } + return 0; + +/* End of ZLAIC1 */ + +} /* zlaic1_ */ + diff --git a/lapack-netlib/SRC/zlals0.c b/lapack-netlib/SRC/zlals0.c new file mode 100644 index 000000000..ad8c80001 --- /dev/null +++ b/lapack-netlib/SRC/zlals0.c @@ -0,0 +1,1045 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLALS0 applies back multiplying factors in solving the least squares problem using divide and c +onquer SVD approach. Used by sgelsd. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLALS0 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX, */ +/* PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, */ +/* POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO ) */ + +/* INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL, */ +/* $ LDGNUM, NL, NR, NRHS, SQRE */ +/* DOUBLE PRECISION C, S */ +/* INTEGER GIVCOL( LDGCOL, * ), PERM( * ) */ +/* DOUBLE PRECISION DIFL( * ), DIFR( LDGNUM, * ), */ +/* $ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ), */ +/* $ RWORK( * ), Z( * ) */ +/* COMPLEX*16 B( LDB, * ), BX( LDBX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLALS0 applies back the multiplying factors of either the left or the */ +/* > right singular vector matrix of a diagonal matrix appended by a row */ +/* > to the right hand side matrix B in solving the least squares problem */ +/* > using the divide-and-conquer SVD approach. */ +/* > */ +/* > For the left singular vector matrix, three types of orthogonal */ +/* > matrices are involved: */ +/* > */ +/* > (1L) Givens rotations: the number of such rotations is GIVPTR; the */ +/* > pairs of columns/rows they were applied to are stored in GIVCOL; */ +/* > and the C- and S-values of these rotations are stored in GIVNUM. */ +/* > */ +/* > (2L) Permutation. The (NL+1)-st row of B is to be moved to the first */ +/* > row, and for J=2:N, PERM(J)-th row of B is to be moved to the */ +/* > J-th row. */ +/* > */ +/* > (3L) The left singular vector matrix of the remaining matrix. */ +/* > */ +/* > For the right singular vector matrix, four types of orthogonal */ +/* > matrices are involved: */ +/* > */ +/* > (1R) The right singular vector matrix of the remaining matrix. */ +/* > */ +/* > (2R) If SQRE = 1, one extra Givens rotation to generate the right */ +/* > null space. */ +/* > */ +/* > (3R) The inverse transformation of (2L). */ +/* > */ +/* > (4R) The inverse transformation of (1L). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ICOMPQ */ +/* > \verbatim */ +/* > ICOMPQ is INTEGER */ +/* > Specifies whether singular vectors are to be computed in */ +/* > factored form: */ +/* > = 0: Left singular vector matrix. */ +/* > = 1: Right singular vector matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NL */ +/* > \verbatim */ +/* > NL is INTEGER */ +/* > The row dimension of the upper block. NL >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NR */ +/* > \verbatim */ +/* > NR is INTEGER */ +/* > The row dimension of the lower block. NR >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SQRE */ +/* > \verbatim */ +/* > SQRE is INTEGER */ +/* > = 0: the lower block is an NR-by-NR square matrix. */ +/* > = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */ +/* > */ +/* > The bidiagonal matrix has row dimension N = NL + NR + 1, */ +/* > and column dimension M = N + SQRE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of columns of B and BX. NRHS must be at least 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension ( LDB, NRHS ) */ +/* > On input, B contains the right hand sides of the least */ +/* > squares problem in rows 1 through M. On output, B contains */ +/* > the solution X in rows 1 through N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B. LDB must be at least */ +/* > f2cmax(1,MAX( M, N ) ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BX */ +/* > \verbatim */ +/* > BX is COMPLEX*16 array, dimension ( LDBX, NRHS ) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDBX */ +/* > \verbatim */ +/* > LDBX is INTEGER */ +/* > The leading dimension of BX. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PERM */ +/* > \verbatim */ +/* > PERM is INTEGER array, dimension ( N ) */ +/* > The permutations (from deflation and sorting) applied */ +/* > to the two blocks. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GIVPTR */ +/* > \verbatim */ +/* > GIVPTR is INTEGER */ +/* > The number of Givens rotations which took place in this */ +/* > subproblem. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GIVCOL */ +/* > \verbatim */ +/* > GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) */ +/* > Each pair of numbers indicates a pair of rows/columns */ +/* > involved in a Givens rotation. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDGCOL */ +/* > \verbatim */ +/* > LDGCOL is INTEGER */ +/* > The leading dimension of GIVCOL, must be at least N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GIVNUM */ +/* > \verbatim */ +/* > GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */ +/* > Each number indicates the C or S value used in the */ +/* > corresponding Givens rotation. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDGNUM */ +/* > \verbatim */ +/* > LDGNUM is INTEGER */ +/* > The leading dimension of arrays DIFR, POLES and */ +/* > GIVNUM, must be at least K. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] POLES */ +/* > \verbatim */ +/* > POLES is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ) */ +/* > On entry, POLES(1:K, 1) contains the new singular */ +/* > values obtained from solving the secular equation, and */ +/* > POLES(1:K, 2) is an array containing the poles in the secular */ +/* > equation. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIFL */ +/* > \verbatim */ +/* > DIFL is DOUBLE PRECISION array, dimension ( K ). */ +/* > On entry, DIFL(I) is the distance between I-th updated */ +/* > (undeflated) singular value and the I-th (undeflated) old */ +/* > singular value. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIFR */ +/* > \verbatim */ +/* > DIFR is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ). */ +/* > On entry, DIFR(I, 1) contains the distances between I-th */ +/* > updated (undeflated) singular value and the I+1-th */ +/* > (undeflated) old singular value. And DIFR(I, 2) is the */ +/* > normalizing factor for the I-th right singular vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION array, dimension ( K ) */ +/* > Contain the components of the deflation-adjusted updating row */ +/* > vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > Contains the dimension of the non-deflated matrix, */ +/* > This is the order of the related secular equation. 1 <= K <=N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION */ +/* > C contains garbage if SQRE =0 and the C-value of a Givens */ +/* > rotation related to the right null space if SQRE = 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is DOUBLE PRECISION */ +/* > S contains garbage if SQRE =0 and the S-value of a Givens */ +/* > rotation related to the right null space if SQRE = 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension */ +/* > ( K*(1+NRHS) + 2*NRHS ) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ming Gu and Ren-Cang Li, Computer Science Division, University of */ +/* > California at Berkeley, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ + +/* ===================================================================== */ +/* Subroutine */ int zlals0_(integer *icompq, integer *nl, integer *nr, + integer *sqre, integer *nrhs, doublecomplex *b, integer *ldb, + doublecomplex *bx, integer *ldbx, integer *perm, integer *givptr, + integer *givcol, integer *ldgcol, doublereal *givnum, integer *ldgnum, + doublereal *poles, doublereal *difl, doublereal *difr, doublereal * + z__, integer *k, doublereal *c__, doublereal *s, doublereal *rwork, + integer *info) +{ + /* System generated locals */ + integer givcol_dim1, givcol_offset, difr_dim1, difr_offset, givnum_dim1, + givnum_offset, poles_dim1, poles_offset, b_dim1, b_offset, + bx_dim1, bx_offset, i__1, i__2, i__3, i__4, i__5; + doublereal d__1; + doublecomplex z__1; + + /* Local variables */ + integer jcol; + doublereal temp; + integer jrow; + extern doublereal dnrm2_(integer *, doublereal *, integer *); + integer i__, j, m, n; + doublereal diflj, difrj, dsigj; + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *), zdrot_(integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublereal *, doublereal *); + extern doublereal dlamc3_(doublereal *, doublereal *); + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + doublereal dj; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal dsigjp; + extern /* Subroutine */ int zdscal_(integer *, doublereal *, + doublecomplex *, integer *), zlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublecomplex * + , integer *, integer *), zlacpy_(char *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *); + integer nlp1; + + +/* -- 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 */ + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + bx_dim1 = *ldbx; + bx_offset = 1 + bx_dim1 * 1; + bx -= bx_offset; + --perm; + givcol_dim1 = *ldgcol; + givcol_offset = 1 + givcol_dim1 * 1; + givcol -= givcol_offset; + difr_dim1 = *ldgnum; + difr_offset = 1 + difr_dim1 * 1; + difr -= difr_offset; + poles_dim1 = *ldgnum; + poles_offset = 1 + poles_dim1 * 1; + poles -= poles_offset; + givnum_dim1 = *ldgnum; + givnum_offset = 1 + givnum_dim1 * 1; + givnum -= givnum_offset; + --difl; + --z__; + --rwork; + + /* Function Body */ + *info = 0; + n = *nl + *nr + 1; + + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*nl < 1) { + *info = -2; + } else if (*nr < 1) { + *info = -3; + } else if (*sqre < 0 || *sqre > 1) { + *info = -4; + } else if (*nrhs < 1) { + *info = -5; + } else if (*ldb < n) { + *info = -7; + } else if (*ldbx < n) { + *info = -9; + } else if (*givptr < 0) { + *info = -11; + } else if (*ldgcol < n) { + *info = -13; + } else if (*ldgnum < n) { + *info = -15; + //} else if (*k < 1) { + } else if (*k < 0) { + *info = -20; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLALS0", &i__1, (ftnlen)6); + return 0; + } + + m = n + *sqre; + nlp1 = *nl + 1; + + if (*icompq == 0) { + +/* Apply back orthogonal transformations from the left. */ + +/* Step (1L): apply back the Givens rotations performed. */ + + i__1 = *givptr; + for (i__ = 1; i__ <= i__1; ++i__) { + zdrot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, & + b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ + + (givnum_dim1 << 1)], &givnum[i__ + givnum_dim1]); +/* L10: */ + } + +/* Step (2L): permute rows of B. */ + + zcopy_(nrhs, &b[nlp1 + b_dim1], ldb, &bx[bx_dim1 + 1], ldbx); + i__1 = n; + for (i__ = 2; i__ <= i__1; ++i__) { + zcopy_(nrhs, &b[perm[i__] + b_dim1], ldb, &bx[i__ + bx_dim1], + ldbx); +/* L20: */ + } + +/* Step (3L): apply the inverse of the left singular vector */ +/* matrix to BX. */ + + if (*k == 1) { + zcopy_(nrhs, &bx[bx_offset], ldbx, &b[b_offset], ldb); + if (z__[1] < 0.) { + zdscal_(nrhs, &c_b5, &b[b_offset], ldb); + } + } else { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + diflj = difl[j]; + dj = poles[j + poles_dim1]; + dsigj = -poles[j + (poles_dim1 << 1)]; + if (j < *k) { + difrj = -difr[j + difr_dim1]; + dsigjp = -poles[j + 1 + (poles_dim1 << 1)]; + } + if (z__[j] == 0. || poles[j + (poles_dim1 << 1)] == 0.) { + rwork[j] = 0.; + } else { + rwork[j] = -poles[j + (poles_dim1 << 1)] * z__[j] / diflj + / (poles[j + (poles_dim1 << 1)] + dj); + } + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] == + 0.) { + rwork[i__] = 0.; + } else { + rwork[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] + / (dlamc3_(&poles[i__ + (poles_dim1 << 1)], & + dsigj) - diflj) / (poles[i__ + (poles_dim1 << + 1)] + dj); + } +/* L30: */ + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + if (z__[i__] == 0. || poles[i__ + (poles_dim1 << 1)] == + 0.) { + rwork[i__] = 0.; + } else { + rwork[i__] = poles[i__ + (poles_dim1 << 1)] * z__[i__] + / (dlamc3_(&poles[i__ + (poles_dim1 << 1)], & + dsigjp) + difrj) / (poles[i__ + (poles_dim1 << + 1)] + dj); + } +/* L40: */ + } + rwork[1] = -1.; + temp = dnrm2_(k, &rwork[1], &c__1); + +/* Since B and BX are complex, the following call to DGEMV */ +/* is performed in two steps (real and imaginary parts). */ + +/* CALL DGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO, */ +/* $ B( J, 1 ), LDB ) */ + + i__ = *k + (*nrhs << 1); + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + i__3 = *k; + for (jrow = 1; jrow <= i__3; ++jrow) { + ++i__; + i__4 = jrow + jcol * bx_dim1; + rwork[i__] = bx[i__4].r; +/* L50: */ + } +/* L60: */ + } + dgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k, + &rwork[1], &c__1, &c_b15, &rwork[*k + 1], &c__1); + i__ = *k + (*nrhs << 1); + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + i__3 = *k; + for (jrow = 1; jrow <= i__3; ++jrow) { + ++i__; + rwork[i__] = d_imag(&bx[jrow + jcol * bx_dim1]); +/* L70: */ + } +/* L80: */ + } + dgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k, + &rwork[1], &c__1, &c_b15, &rwork[*k + 1 + *nrhs], & + c__1); + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + i__3 = j + jcol * b_dim1; + i__4 = jcol + *k; + i__5 = jcol + *k + *nrhs; + z__1.r = rwork[i__4], z__1.i = rwork[i__5]; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L90: */ + } + zlascl_("G", &c__0, &c__0, &temp, &c_b13, &c__1, nrhs, &b[j + + b_dim1], ldb, info); +/* L100: */ + } + } + +/* Move the deflated rows of BX to B also. */ + + if (*k < f2cmax(m,n)) { + i__1 = n - *k; + zlacpy_("A", &i__1, nrhs, &bx[*k + 1 + bx_dim1], ldbx, &b[*k + 1 + + b_dim1], ldb); + } + } else { + +/* Apply back the right orthogonal transformations. */ + +/* Step (1R): apply back the new right singular vector matrix */ +/* to B. */ + + if (*k == 1) { + zcopy_(nrhs, &b[b_offset], ldb, &bx[bx_offset], ldbx); + } else { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dsigj = poles[j + (poles_dim1 << 1)]; + if (z__[j] == 0.) { + rwork[j] = 0.; + } else { + rwork[j] = -z__[j] / difl[j] / (dsigj + poles[j + + poles_dim1]) / difr[j + (difr_dim1 << 1)]; + } + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + if (z__[j] == 0.) { + rwork[i__] = 0.; + } else { + d__1 = -poles[i__ + 1 + (poles_dim1 << 1)]; + rwork[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difr[ + i__ + difr_dim1]) / (dsigj + poles[i__ + + poles_dim1]) / difr[i__ + (difr_dim1 << 1)]; + } +/* L110: */ + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + if (z__[j] == 0.) { + rwork[i__] = 0.; + } else { + d__1 = -poles[i__ + (poles_dim1 << 1)]; + rwork[i__] = z__[j] / (dlamc3_(&dsigj, &d__1) - difl[ + i__]) / (dsigj + poles[i__ + poles_dim1]) / + difr[i__ + (difr_dim1 << 1)]; + } +/* L120: */ + } + +/* Since B and BX are complex, the following call to DGEMV */ +/* is performed in two steps (real and imaginary parts). */ + +/* CALL DGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO, */ +/* $ BX( J, 1 ), LDBX ) */ + + i__ = *k + (*nrhs << 1); + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + i__3 = *k; + for (jrow = 1; jrow <= i__3; ++jrow) { + ++i__; + i__4 = jrow + jcol * b_dim1; + rwork[i__] = b[i__4].r; +/* L130: */ + } +/* L140: */ + } + dgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k, + &rwork[1], &c__1, &c_b15, &rwork[*k + 1], &c__1); + i__ = *k + (*nrhs << 1); + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + i__3 = *k; + for (jrow = 1; jrow <= i__3; ++jrow) { + ++i__; + rwork[i__] = d_imag(&b[jrow + jcol * b_dim1]); +/* L150: */ + } +/* L160: */ + } + dgemv_("T", k, nrhs, &c_b13, &rwork[*k + 1 + (*nrhs << 1)], k, + &rwork[1], &c__1, &c_b15, &rwork[*k + 1 + *nrhs], & + c__1); + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + i__3 = j + jcol * bx_dim1; + i__4 = jcol + *k; + i__5 = jcol + *k + *nrhs; + z__1.r = rwork[i__4], z__1.i = rwork[i__5]; + bx[i__3].r = z__1.r, bx[i__3].i = z__1.i; +/* L170: */ + } +/* L180: */ + } + } + +/* Step (2R): if SQRE = 1, apply back the rotation that is */ +/* related to the right null space of the subproblem. */ + + if (*sqre == 1) { + zcopy_(nrhs, &b[m + b_dim1], ldb, &bx[m + bx_dim1], ldbx); + zdrot_(nrhs, &bx[bx_dim1 + 1], ldbx, &bx[m + bx_dim1], ldbx, c__, + s); + } + if (*k < f2cmax(m,n)) { + i__1 = n - *k; + zlacpy_("A", &i__1, nrhs, &b[*k + 1 + b_dim1], ldb, &bx[*k + 1 + + bx_dim1], ldbx); + } + +/* Step (3R): permute rows of B. */ + + zcopy_(nrhs, &bx[bx_dim1 + 1], ldbx, &b[nlp1 + b_dim1], ldb); + if (*sqre == 1) { + zcopy_(nrhs, &bx[m + bx_dim1], ldbx, &b[m + b_dim1], ldb); + } + i__1 = n; + for (i__ = 2; i__ <= i__1; ++i__) { + zcopy_(nrhs, &bx[i__ + bx_dim1], ldbx, &b[perm[i__] + b_dim1], + ldb); +/* L190: */ + } + +/* Step (4R): apply back the Givens rotations performed. */ + + for (i__ = *givptr; i__ >= 1; --i__) { + d__1 = -givnum[i__ + givnum_dim1]; + zdrot_(nrhs, &b[givcol[i__ + (givcol_dim1 << 1)] + b_dim1], ldb, & + b[givcol[i__ + givcol_dim1] + b_dim1], ldb, &givnum[i__ + + (givnum_dim1 << 1)], &d__1); +/* L200: */ + } + } + + return 0; + +/* End of ZLALS0 */ + +} /* zlals0_ */ + diff --git a/lapack-netlib/SRC/zlalsa.c b/lapack-netlib/SRC/zlalsa.c new file mode 100644 index 000000000..14b5d7a9a --- /dev/null +++ b/lapack-netlib/SRC/zlalsa.c @@ -0,0 +1,1154 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLALSA computes the SVD of the coefficient matrix in compact form. Used by sgelsd. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLALSA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLALSA( ICOMPQ, SMLSIZ, N, NRHS, B, LDB, BX, LDBX, U, */ +/* LDU, VT, K, DIFL, DIFR, Z, POLES, GIVPTR, */ +/* GIVCOL, LDGCOL, PERM, GIVNUM, C, S, RWORK, */ +/* IWORK, INFO ) */ + +/* INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS, */ +/* $ SMLSIZ */ +/* INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), */ +/* $ K( * ), PERM( LDGCOL, * ) */ +/* DOUBLE PRECISION C( * ), DIFL( LDU, * ), DIFR( LDU, * ), */ +/* $ GIVNUM( LDU, * ), POLES( LDU, * ), RWORK( * ), */ +/* $ S( * ), U( LDU, * ), VT( LDU, * ), Z( LDU, * ) */ +/* COMPLEX*16 B( LDB, * ), BX( LDBX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLALSA is an itermediate step in solving the least squares problem */ +/* > by computing the SVD of the coefficient matrix in compact form (The */ +/* > singular vectors are computed as products of simple orthorgonal */ +/* > matrices.). */ +/* > */ +/* > If ICOMPQ = 0, ZLALSA applies the inverse of the left singular vector */ +/* > matrix of an upper bidiagonal matrix to the right hand side; and if */ +/* > ICOMPQ = 1, ZLALSA applies the right singular vector matrix to the */ +/* > right hand side. The singular vector matrices were generated in */ +/* > compact form by ZLALSA. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ICOMPQ */ +/* > \verbatim */ +/* > ICOMPQ is INTEGER */ +/* > Specifies whether the left or the right singular vector */ +/* > matrix is involved. */ +/* > = 0: Left singular vector matrix */ +/* > = 1: Right singular vector matrix */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SMLSIZ */ +/* > \verbatim */ +/* > SMLSIZ is INTEGER */ +/* > The maximum size of the subproblems at the bottom of the */ +/* > computation tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The row and column dimensions of the upper bidiagonal matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of columns of B and BX. NRHS must be at least 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension ( LDB, NRHS ) */ +/* > On input, B contains the right hand sides of the least */ +/* > squares problem in rows 1 through M. */ +/* > On output, B contains the solution X in rows 1 through N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B in the calling subprogram. */ +/* > LDB must be at least f2cmax(1,MAX( M, N ) ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BX */ +/* > \verbatim */ +/* > BX is COMPLEX*16 array, dimension ( LDBX, NRHS ) */ +/* > On exit, the result of applying the left or right singular */ +/* > vector matrix to B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDBX */ +/* > \verbatim */ +/* > LDBX is INTEGER */ +/* > The leading dimension of BX. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] U */ +/* > \verbatim */ +/* > U is DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ). */ +/* > On entry, U contains the left singular vector matrices of all */ +/* > subproblems at the bottom level. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER, LDU = > N. */ +/* > The leading dimension of arrays U, VT, DIFL, DIFR, */ +/* > POLES, GIVNUM, and Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VT */ +/* > \verbatim */ +/* > VT is DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ). */ +/* > On entry, VT**H contains the right singular vector matrices of */ +/* > all subproblems at the bottom level. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER array, dimension ( N ). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIFL */ +/* > \verbatim */ +/* > DIFL is DOUBLE PRECISION array, dimension ( LDU, NLVL ). */ +/* > where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIFR */ +/* > \verbatim */ +/* > DIFR is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). */ +/* > On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record */ +/* > distances between singular values on the I-th level and */ +/* > singular values on the (I -1)-th level, and DIFR(*, 2 * I) */ +/* > record the normalizing factors of the right singular vectors */ +/* > matrices of subproblems on I-th level. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION array, dimension ( LDU, NLVL ). */ +/* > On entry, Z(1, I) contains the components of the deflation- */ +/* > adjusted updating row vector for subproblems on the I-th */ +/* > level. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] POLES */ +/* > \verbatim */ +/* > POLES is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). */ +/* > On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old */ +/* > singular values involved in the secular equations on the I-th */ +/* > level. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GIVPTR */ +/* > \verbatim */ +/* > GIVPTR is INTEGER array, dimension ( N ). */ +/* > On entry, GIVPTR( I ) records the number of Givens */ +/* > rotations performed on the I-th problem on the computation */ +/* > tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GIVCOL */ +/* > \verbatim */ +/* > GIVCOL is INTEGER array, dimension ( LDGCOL, 2 * NLVL ). */ +/* > On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the */ +/* > locations of Givens rotations performed on the I-th level on */ +/* > the computation tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDGCOL */ +/* > \verbatim */ +/* > LDGCOL is INTEGER, LDGCOL = > N. */ +/* > The leading dimension of arrays GIVCOL and PERM. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PERM */ +/* > \verbatim */ +/* > PERM is INTEGER array, dimension ( LDGCOL, NLVL ). */ +/* > On entry, PERM(*, I) records permutations done on the I-th */ +/* > level of the computation tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GIVNUM */ +/* > \verbatim */ +/* > GIVNUM is DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ). */ +/* > On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S- */ +/* > values of Givens rotations performed on the I-th level on the */ +/* > computation tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension ( N ). */ +/* > On entry, if the I-th subproblem is not square, */ +/* > C( I ) contains the C-value of a Givens rotation related to */ +/* > the right null space of the I-th subproblem. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is DOUBLE PRECISION array, dimension ( N ). */ +/* > On entry, if the I-th subproblem is not square, */ +/* > S( I ) contains the S-value of a Givens rotation related to */ +/* > the right null space of the I-th subproblem. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension at least */ +/* > MAX( (SMLSZ+1)*NRHS*3, N*(1+NRHS) + 2*NRHS ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup complex16OTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ming Gu and Ren-Cang Li, Computer Science Division, University of */ +/* > California at Berkeley, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ + +/* ===================================================================== */ +/* Subroutine */ int zlalsa_(integer *icompq, integer *smlsiz, integer *n, + integer *nrhs, doublecomplex *b, integer *ldb, doublecomplex *bx, + integer *ldbx, doublereal *u, integer *ldu, doublereal *vt, integer * + k, doublereal *difl, doublereal *difr, doublereal *z__, doublereal * + poles, integer *givptr, integer *givcol, integer *ldgcol, integer * + perm, doublereal *givnum, doublereal *c__, doublereal *s, doublereal * + rwork, integer *iwork, integer *info) +{ + /* System generated locals */ + integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, difl_dim1, + difl_offset, difr_dim1, difr_offset, givnum_dim1, givnum_offset, + poles_dim1, poles_offset, u_dim1, u_offset, vt_dim1, vt_offset, + z_dim1, z_offset, b_dim1, b_offset, bx_dim1, bx_offset, i__1, + i__2, i__3, i__4, i__5, i__6; + doublecomplex z__1; + + /* Local variables */ + integer jcol, nlvl, sqre, jrow, i__, j, jimag; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + integer jreal, inode, ndiml, ndimr, i1; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zlals0_(integer *, integer *, + integer *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, integer *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, integer *); + integer ic, lf, nd, ll, nl, nr; + extern /* Subroutine */ int dlasdt_(integer *, integer *, integer *, + integer *, integer *, integer *, integer *), xerbla_(char *, + integer *, ftnlen); + integer im1, nlf, nrf, lvl, ndb1, nlp1, lvl2, nrp1; + + +/* -- 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 */ + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + bx_dim1 = *ldbx; + bx_offset = 1 + bx_dim1 * 1; + bx -= bx_offset; + givnum_dim1 = *ldu; + givnum_offset = 1 + givnum_dim1 * 1; + givnum -= givnum_offset; + poles_dim1 = *ldu; + poles_offset = 1 + poles_dim1 * 1; + poles -= poles_offset; + z_dim1 = *ldu; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + difr_dim1 = *ldu; + difr_offset = 1 + difr_dim1 * 1; + difr -= difr_offset; + difl_dim1 = *ldu; + difl_offset = 1 + difl_dim1 * 1; + difl -= difl_offset; + vt_dim1 = *ldu; + vt_offset = 1 + vt_dim1 * 1; + vt -= vt_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + --k; + --givptr; + perm_dim1 = *ldgcol; + perm_offset = 1 + perm_dim1 * 1; + perm -= perm_offset; + givcol_dim1 = *ldgcol; + givcol_offset = 1 + givcol_dim1 * 1; + givcol -= givcol_offset; + --c__; + --s; + --rwork; + --iwork; + + /* Function Body */ + *info = 0; + + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*smlsiz < 3) { + *info = -2; + } else if (*n < *smlsiz) { + *info = -3; + } else if (*nrhs < 1) { + *info = -4; + } else if (*ldb < *n) { + *info = -6; + } else if (*ldbx < *n) { + *info = -8; + } else if (*ldu < *n) { + *info = -10; + } else if (*ldgcol < *n) { + *info = -19; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLALSA", &i__1, (ftnlen)6); + return 0; + } + +/* Book-keeping and setting up the computation tree. */ + + inode = 1; + ndiml = inode + *n; + ndimr = ndiml + *n; + + dlasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], + smlsiz); + +/* The following code applies back the left singular vector factors. */ +/* For applying back the right singular vector factors, go to 170. */ + + if (*icompq == 1) { + goto L170; + } + +/* The nodes on the bottom level of the tree were solved */ +/* by DLASDQ. The corresponding left and right singular vector */ +/* matrices are in explicit form. First apply back the left */ +/* singular vector matrices. */ + + ndb1 = (nd + 1) / 2; + i__1 = nd; + for (i__ = ndb1; i__ <= i__1; ++i__) { + +/* IC : center row of each node */ +/* NL : number of rows of left subproblem */ +/* NR : number of rows of right subproblem */ +/* NLF: starting row of the left subproblem */ +/* NRF: starting row of the right subproblem */ + + i1 = i__ - 1; + ic = iwork[inode + i1]; + nl = iwork[ndiml + i1]; + nr = iwork[ndimr + i1]; + nlf = ic - nl; + nrf = ic + 1; + +/* Since B and BX are complex, the following call to DGEMM */ +/* is performed in two steps (real and imaginary parts). */ + +/* CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU, */ +/* $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX ) */ + + j = nl * *nrhs << 1; + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + i__3 = nlf + nl - 1; + for (jrow = nlf; jrow <= i__3; ++jrow) { + ++j; + i__4 = jrow + jcol * b_dim1; + rwork[j] = b[i__4].r; +/* L10: */ + } +/* L20: */ + } + dgemm_("T", "N", &nl, nrhs, &nl, &c_b9, &u[nlf + u_dim1], ldu, &rwork[ + (nl * *nrhs << 1) + 1], &nl, &c_b10, &rwork[1], &nl); + j = nl * *nrhs << 1; + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + i__3 = nlf + nl - 1; + for (jrow = nlf; jrow <= i__3; ++jrow) { + ++j; + rwork[j] = d_imag(&b[jrow + jcol * b_dim1]); +/* L30: */ + } +/* L40: */ + } + dgemm_("T", "N", &nl, nrhs, &nl, &c_b9, &u[nlf + u_dim1], ldu, &rwork[ + (nl * *nrhs << 1) + 1], &nl, &c_b10, &rwork[nl * *nrhs + 1], & + nl); + jreal = 0; + jimag = nl * *nrhs; + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + i__3 = nlf + nl - 1; + for (jrow = nlf; jrow <= i__3; ++jrow) { + ++jreal; + ++jimag; + i__4 = jrow + jcol * bx_dim1; + i__5 = jreal; + i__6 = jimag; + z__1.r = rwork[i__5], z__1.i = rwork[i__6]; + bx[i__4].r = z__1.r, bx[i__4].i = z__1.i; +/* L50: */ + } +/* L60: */ + } + +/* Since B and BX are complex, the following call to DGEMM */ +/* is performed in two steps (real and imaginary parts). */ + +/* CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU, */ +/* $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX ) */ + + j = nr * *nrhs << 1; + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + i__3 = nrf + nr - 1; + for (jrow = nrf; jrow <= i__3; ++jrow) { + ++j; + i__4 = jrow + jcol * b_dim1; + rwork[j] = b[i__4].r; +/* L70: */ + } +/* L80: */ + } + dgemm_("T", "N", &nr, nrhs, &nr, &c_b9, &u[nrf + u_dim1], ldu, &rwork[ + (nr * *nrhs << 1) + 1], &nr, &c_b10, &rwork[1], &nr); + j = nr * *nrhs << 1; + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + i__3 = nrf + nr - 1; + for (jrow = nrf; jrow <= i__3; ++jrow) { + ++j; + rwork[j] = d_imag(&b[jrow + jcol * b_dim1]); +/* L90: */ + } +/* L100: */ + } + dgemm_("T", "N", &nr, nrhs, &nr, &c_b9, &u[nrf + u_dim1], ldu, &rwork[ + (nr * *nrhs << 1) + 1], &nr, &c_b10, &rwork[nr * *nrhs + 1], & + nr); + jreal = 0; + jimag = nr * *nrhs; + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + i__3 = nrf + nr - 1; + for (jrow = nrf; jrow <= i__3; ++jrow) { + ++jreal; + ++jimag; + i__4 = jrow + jcol * bx_dim1; + i__5 = jreal; + i__6 = jimag; + z__1.r = rwork[i__5], z__1.i = rwork[i__6]; + bx[i__4].r = z__1.r, bx[i__4].i = z__1.i; +/* L110: */ + } +/* L120: */ + } + +/* L130: */ + } + +/* Next copy the rows of B that correspond to unchanged rows */ +/* in the bidiagonal matrix to BX. */ + + i__1 = nd; + for (i__ = 1; i__ <= i__1; ++i__) { + ic = iwork[inode + i__ - 1]; + zcopy_(nrhs, &b[ic + b_dim1], ldb, &bx[ic + bx_dim1], ldbx); +/* L140: */ + } + +/* Finally go through the left singular vector matrices of all */ +/* the other subproblems bottom-up on the tree. */ + + j = pow_ii(&c__2, &nlvl); + sqre = 0; + + for (lvl = nlvl; lvl >= 1; --lvl) { + lvl2 = (lvl << 1) - 1; + +/* find the first node LF and last node LL on */ +/* the current level LVL */ + + if (lvl == 1) { + lf = 1; + ll = 1; + } else { + i__1 = lvl - 1; + lf = pow_ii(&c__2, &i__1); + ll = (lf << 1) - 1; + } + i__1 = ll; + for (i__ = lf; i__ <= i__1; ++i__) { + im1 = i__ - 1; + ic = iwork[inode + im1]; + nl = iwork[ndiml + im1]; + nr = iwork[ndimr + im1]; + nlf = ic - nl; + nrf = ic + 1; + --j; + zlals0_(icompq, &nl, &nr, &sqre, nrhs, &bx[nlf + bx_dim1], ldbx, & + b[nlf + b_dim1], ldb, &perm[nlf + lvl * perm_dim1], & + givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, & + givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 * + poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf + + lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[ + j], &s[j], &rwork[1], info); +/* L150: */ + } +/* L160: */ + } + goto L330; + +/* ICOMPQ = 1: applying back the right singular vector factors. */ + +L170: + +/* First now go through the right singular vector matrices of all */ +/* the tree nodes top-down. */ + + j = 0; + i__1 = nlvl; + for (lvl = 1; lvl <= i__1; ++lvl) { + lvl2 = (lvl << 1) - 1; + +/* Find the first node LF and last node LL on */ +/* the current level LVL. */ + + if (lvl == 1) { + lf = 1; + ll = 1; + } else { + i__2 = lvl - 1; + lf = pow_ii(&c__2, &i__2); + ll = (lf << 1) - 1; + } + i__2 = lf; + for (i__ = ll; i__ >= i__2; --i__) { + im1 = i__ - 1; + ic = iwork[inode + im1]; + nl = iwork[ndiml + im1]; + nr = iwork[ndimr + im1]; + nlf = ic - nl; + nrf = ic + 1; + if (i__ == ll) { + sqre = 0; + } else { + sqre = 1; + } + ++j; + zlals0_(icompq, &nl, &nr, &sqre, nrhs, &b[nlf + b_dim1], ldb, &bx[ + nlf + bx_dim1], ldbx, &perm[nlf + lvl * perm_dim1], & + givptr[j], &givcol[nlf + lvl2 * givcol_dim1], ldgcol, & + givnum[nlf + lvl2 * givnum_dim1], ldu, &poles[nlf + lvl2 * + poles_dim1], &difl[nlf + lvl * difl_dim1], &difr[nlf + + lvl2 * difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[ + j], &s[j], &rwork[1], info); +/* L180: */ + } +/* L190: */ + } + +/* The nodes on the bottom level of the tree were solved */ +/* by DLASDQ. The corresponding right singular vector */ +/* matrices are in explicit form. Apply them back. */ + + ndb1 = (nd + 1) / 2; + i__1 = nd; + for (i__ = ndb1; i__ <= i__1; ++i__) { + i1 = i__ - 1; + ic = iwork[inode + i1]; + nl = iwork[ndiml + i1]; + nr = iwork[ndimr + i1]; + nlp1 = nl + 1; + if (i__ == nd) { + nrp1 = nr; + } else { + nrp1 = nr + 1; + } + nlf = ic - nl; + nrf = ic + 1; + +/* Since B and BX are complex, the following call to DGEMM is */ +/* performed in two steps (real and imaginary parts). */ + +/* CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU, */ +/* $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX ) */ + + j = nlp1 * *nrhs << 1; + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + i__3 = nlf + nlp1 - 1; + for (jrow = nlf; jrow <= i__3; ++jrow) { + ++j; + i__4 = jrow + jcol * b_dim1; + rwork[j] = b[i__4].r; +/* L200: */ + } +/* L210: */ + } + dgemm_("T", "N", &nlp1, nrhs, &nlp1, &c_b9, &vt[nlf + vt_dim1], ldu, & + rwork[(nlp1 * *nrhs << 1) + 1], &nlp1, &c_b10, &rwork[1], & + nlp1); + j = nlp1 * *nrhs << 1; + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + i__3 = nlf + nlp1 - 1; + for (jrow = nlf; jrow <= i__3; ++jrow) { + ++j; + rwork[j] = d_imag(&b[jrow + jcol * b_dim1]); +/* L220: */ + } +/* L230: */ + } + dgemm_("T", "N", &nlp1, nrhs, &nlp1, &c_b9, &vt[nlf + vt_dim1], ldu, & + rwork[(nlp1 * *nrhs << 1) + 1], &nlp1, &c_b10, &rwork[nlp1 * * + nrhs + 1], &nlp1); + jreal = 0; + jimag = nlp1 * *nrhs; + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + i__3 = nlf + nlp1 - 1; + for (jrow = nlf; jrow <= i__3; ++jrow) { + ++jreal; + ++jimag; + i__4 = jrow + jcol * bx_dim1; + i__5 = jreal; + i__6 = jimag; + z__1.r = rwork[i__5], z__1.i = rwork[i__6]; + bx[i__4].r = z__1.r, bx[i__4].i = z__1.i; +/* L240: */ + } +/* L250: */ + } + +/* Since B and BX are complex, the following call to DGEMM is */ +/* performed in two steps (real and imaginary parts). */ + +/* CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU, */ +/* $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX ) */ + + j = nrp1 * *nrhs << 1; + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + i__3 = nrf + nrp1 - 1; + for (jrow = nrf; jrow <= i__3; ++jrow) { + ++j; + i__4 = jrow + jcol * b_dim1; + rwork[j] = b[i__4].r; +/* L260: */ + } +/* L270: */ + } + dgemm_("T", "N", &nrp1, nrhs, &nrp1, &c_b9, &vt[nrf + vt_dim1], ldu, & + rwork[(nrp1 * *nrhs << 1) + 1], &nrp1, &c_b10, &rwork[1], & + nrp1); + j = nrp1 * *nrhs << 1; + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + i__3 = nrf + nrp1 - 1; + for (jrow = nrf; jrow <= i__3; ++jrow) { + ++j; + rwork[j] = d_imag(&b[jrow + jcol * b_dim1]); +/* L280: */ + } +/* L290: */ + } + dgemm_("T", "N", &nrp1, nrhs, &nrp1, &c_b9, &vt[nrf + vt_dim1], ldu, & + rwork[(nrp1 * *nrhs << 1) + 1], &nrp1, &c_b10, &rwork[nrp1 * * + nrhs + 1], &nrp1); + jreal = 0; + jimag = nrp1 * *nrhs; + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + i__3 = nrf + nrp1 - 1; + for (jrow = nrf; jrow <= i__3; ++jrow) { + ++jreal; + ++jimag; + i__4 = jrow + jcol * bx_dim1; + i__5 = jreal; + i__6 = jimag; + z__1.r = rwork[i__5], z__1.i = rwork[i__6]; + bx[i__4].r = z__1.r, bx[i__4].i = z__1.i; +/* L300: */ + } +/* L310: */ + } + +/* L320: */ + } + +L330: + + return 0; + +/* End of ZLALSA */ + +} /* zlalsa_ */ + diff --git a/lapack-netlib/SRC/zlalsd.c b/lapack-netlib/SRC/zlalsd.c new file mode 100644 index 000000000..4a2ce0e6f --- /dev/null +++ b/lapack-netlib/SRC/zlalsd.c @@ -0,0 +1,1209 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLALSD uses the singular value decomposition of A to solve the least squares problem. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLALSD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND, */ +/* RANK, WORK, RWORK, IWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ */ +/* DOUBLE PRECISION RCOND */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION D( * ), E( * ), RWORK( * ) */ +/* COMPLEX*16 B( LDB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLALSD uses the singular value decomposition of A to solve the least */ +/* > squares problem of finding X to minimize the Euclidean norm of each */ +/* > column of A*X-B, where A is N-by-N upper bidiagonal, and X and B */ +/* > are N-by-NRHS. The solution X overwrites B. */ +/* > */ +/* > The singular values of A smaller than RCOND times the largest */ +/* > singular value are treated as zero in solving the least squares */ +/* > problem; in this case a minimum norm solution is returned. */ +/* > The actual singular values are returned in D in ascending order. */ +/* > */ +/* > 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 XMP, Cray YMP, 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] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': D and E define an upper bidiagonal matrix. */ +/* > = 'L': D and E define a lower bidiagonal matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SMLSIZ */ +/* > \verbatim */ +/* > SMLSIZ is INTEGER */ +/* > The maximum size of the subproblems at the bottom of the */ +/* > computation tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The dimension of the bidiagonal matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of columns of B. NRHS must be at least 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > On entry D contains the main diagonal of the bidiagonal */ +/* > matrix. On exit, if INFO = 0, D contains its singular values. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > Contains the super-diagonal entries of the bidiagonal matrix. */ +/* > On exit, E has been destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > On input, B contains the right hand sides of the least */ +/* > squares problem. On output, B contains the solution X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of B in the calling subprogram. */ +/* > LDB must be at least f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > The singular values of A less than or equal to RCOND times */ +/* > the largest singular value are treated as zero in solving */ +/* > the least squares problem. If RCOND is negative, */ +/* > machine precision is used instead. */ +/* > For example, if diag(S)*X=B were the least squares problem, */ +/* > where diag(S) is a diagonal matrix of singular values, the */ +/* > solution would be X(i) = B(i) / S(i) if S(i) is greater than */ +/* > RCOND*f2cmax(S), and X(i) = 0 if S(i) is less than or equal to */ +/* > RCOND*f2cmax(S). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RANK */ +/* > \verbatim */ +/* > RANK is INTEGER */ +/* > The number of singular values of A greater than RCOND times */ +/* > the largest singular value. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (N * NRHS) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension at least */ +/* > (9*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS + */ +/* > MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS ), */ +/* > where */ +/* > NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension at least */ +/* > (3*N*NLVL + 11*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: The algorithm failed to compute a singular value 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 June 2017 */ + +/* > \ingroup complex16OTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ming Gu and Ren-Cang Li, Computer Science Division, University of */ +/* > California at Berkeley, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ + +/* ===================================================================== */ +/* Subroutine */ int zlalsd_(char *uplo, integer *smlsiz, integer *n, integer + *nrhs, doublereal *d__, doublereal *e, doublecomplex *b, integer *ldb, + doublereal *rcond, integer *rank, doublecomplex *work, doublereal * + rwork, integer *iwork, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2, i__3, i__4, i__5, i__6; + doublereal d__1; + doublecomplex z__1; + + /* Local variables */ + integer difl, difr; + doublereal rcnd; + integer jcol, irwb, perm, nsub, nlvl, sqre, bxst, jrow, irwu, c__, i__, j, + k; + doublereal r__; + integer s, u, jimag; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + integer z__, jreal, irwib, poles, sizei, irwrb, nsize; + extern /* Subroutine */ int zdrot_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublereal *, doublereal *), zcopy_( + integer *, doublecomplex *, integer *, doublecomplex *, integer *) + ; + integer irwvt, icmpq1, icmpq2; + doublereal cs; + extern doublereal dlamch_(char *); + extern /* Subroutine */ int dlasda_(integer *, integer *, integer *, + integer *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, integer *, integer *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + integer *); + integer bx; + doublereal sn; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *); + extern integer idamax_(integer *, doublereal *, integer *); + integer st; + extern /* Subroutine */ int dlasdq_(char *, integer *, integer *, integer + *, integer *, integer *, doublereal *, doublereal *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *); + integer vt; + extern /* Subroutine */ int dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *), + dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *), xerbla_(char *, integer *, ftnlen); + integer givcol; + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *); + extern /* Subroutine */ int zlalsa_(integer *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *, integer *, + integer *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, integer *), zlascl_(char *, integer *, + integer *, doublereal *, doublereal *, integer *, integer *, + doublecomplex *, integer *, integer *), dlasrt_(char *, + integer *, doublereal *, integer *), zlacpy_(char *, + integer *, integer *, doublecomplex *, integer *, doublecomplex *, + integer *), zlaset_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *); + doublereal orgnrm; + integer givnum, givptr, nm1, nrwork, irwwrk, smlszp, st1; + doublereal eps; + integer iwk; + doublereal tol; + + +/* -- 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 */ + --d__; + --e; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --work; + --rwork; + --iwork; + + /* Function Body */ + *info = 0; + + if (*n < 0) { + *info = -3; + } else if (*nrhs < 1) { + *info = -4; + } else if (*ldb < 1 || *ldb < *n) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLALSD", &i__1, (ftnlen)6); + return 0; + } + + eps = dlamch_("Epsilon"); + +/* Set up the tolerance. */ + + if (*rcond <= 0. || *rcond >= 1.) { + rcnd = eps; + } else { + rcnd = *rcond; + } + + *rank = 0; + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } else if (*n == 1) { + if (d__[1] == 0.) { + zlaset_("A", &c__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb); + } else { + *rank = 1; + zlascl_("G", &c__0, &c__0, &d__[1], &c_b10, &c__1, nrhs, &b[ + b_offset], ldb, info); + d__[1] = abs(d__[1]); + } + return 0; + } + +/* Rotate the matrix if it is lower bidiagonal. */ + + if (*(unsigned char *)uplo == 'L') { + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + dlartg_(&d__[i__], &e[i__], &cs, &sn, &r__); + d__[i__] = r__; + e[i__] = sn * d__[i__ + 1]; + d__[i__ + 1] = cs * d__[i__ + 1]; + if (*nrhs == 1) { + zdrot_(&c__1, &b[i__ + b_dim1], &c__1, &b[i__ + 1 + b_dim1], & + c__1, &cs, &sn); + } else { + rwork[(i__ << 1) - 1] = cs; + rwork[i__ * 2] = sn; + } +/* L10: */ + } + if (*nrhs > 1) { + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n - 1; + for (j = 1; j <= i__2; ++j) { + cs = rwork[(j << 1) - 1]; + sn = rwork[j * 2]; + zdrot_(&c__1, &b[j + i__ * b_dim1], &c__1, &b[j + 1 + i__ + * b_dim1], &c__1, &cs, &sn); +/* L20: */ + } +/* L30: */ + } + } + } + +/* Scale. */ + + nm1 = *n - 1; + orgnrm = dlanst_("M", n, &d__[1], &e[1]); + if (orgnrm == 0.) { + zlaset_("A", n, nrhs, &c_b1, &c_b1, &b[b_offset], ldb); + return 0; + } + + dlascl_("G", &c__0, &c__0, &orgnrm, &c_b10, n, &c__1, &d__[1], n, info); + dlascl_("G", &c__0, &c__0, &orgnrm, &c_b10, &nm1, &c__1, &e[1], &nm1, + info); + +/* If N is smaller than the minimum divide size SMLSIZ, then solve */ +/* the problem with another solver. */ + + if (*n <= *smlsiz) { + irwu = 1; + irwvt = irwu + *n * *n; + irwwrk = irwvt + *n * *n; + irwrb = irwwrk; + irwib = irwrb + *n * *nrhs; + irwb = irwib + *n * *nrhs; + dlaset_("A", n, n, &c_b35, &c_b10, &rwork[irwu], n); + dlaset_("A", n, n, &c_b35, &c_b10, &rwork[irwvt], n); + dlasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &rwork[irwvt], n, + &rwork[irwu], n, &rwork[irwwrk], &c__1, &rwork[irwwrk], info); + if (*info != 0) { + return 0; + } + +/* In the real version, B is passed to DLASDQ and multiplied */ +/* internally by Q**H. Here B is complex and that product is */ +/* computed below in two steps (real and imaginary parts). */ + + j = irwb - 1; + i__1 = *nrhs; + for (jcol = 1; jcol <= i__1; ++jcol) { + i__2 = *n; + for (jrow = 1; jrow <= i__2; ++jrow) { + ++j; + i__3 = jrow + jcol * b_dim1; + rwork[j] = b[i__3].r; +/* L40: */ + } +/* L50: */ + } + dgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwu], n, &rwork[irwb], n, + &c_b35, &rwork[irwrb], n); + j = irwb - 1; + i__1 = *nrhs; + for (jcol = 1; jcol <= i__1; ++jcol) { + i__2 = *n; + for (jrow = 1; jrow <= i__2; ++jrow) { + ++j; + rwork[j] = d_imag(&b[jrow + jcol * b_dim1]); +/* L60: */ + } +/* L70: */ + } + dgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwu], n, &rwork[irwb], n, + &c_b35, &rwork[irwib], n); + jreal = irwrb - 1; + jimag = irwib - 1; + i__1 = *nrhs; + for (jcol = 1; jcol <= i__1; ++jcol) { + i__2 = *n; + for (jrow = 1; jrow <= i__2; ++jrow) { + ++jreal; + ++jimag; + i__3 = jrow + jcol * b_dim1; + i__4 = jreal; + i__5 = jimag; + z__1.r = rwork[i__4], z__1.i = rwork[i__5]; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L80: */ + } +/* L90: */ + } + + tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1)); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (d__[i__] <= tol) { + zlaset_("A", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1], ldb); + } else { + zlascl_("G", &c__0, &c__0, &d__[i__], &c_b10, &c__1, nrhs, &b[ + i__ + b_dim1], ldb, info); + ++(*rank); + } +/* L100: */ + } + +/* Since B is complex, the following call to DGEMM is performed */ +/* in two steps (real and imaginary parts). That is for V * B */ +/* (in the real version of the code V**H is stored in WORK). */ + +/* CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO, */ +/* $ WORK( NWORK ), N ) */ + + j = irwb - 1; + i__1 = *nrhs; + for (jcol = 1; jcol <= i__1; ++jcol) { + i__2 = *n; + for (jrow = 1; jrow <= i__2; ++jrow) { + ++j; + i__3 = jrow + jcol * b_dim1; + rwork[j] = b[i__3].r; +/* L110: */ + } +/* L120: */ + } + dgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwvt], n, &rwork[irwb], + n, &c_b35, &rwork[irwrb], n); + j = irwb - 1; + i__1 = *nrhs; + for (jcol = 1; jcol <= i__1; ++jcol) { + i__2 = *n; + for (jrow = 1; jrow <= i__2; ++jrow) { + ++j; + rwork[j] = d_imag(&b[jrow + jcol * b_dim1]); +/* L130: */ + } +/* L140: */ + } + dgemm_("T", "N", n, nrhs, n, &c_b10, &rwork[irwvt], n, &rwork[irwb], + n, &c_b35, &rwork[irwib], n); + jreal = irwrb - 1; + jimag = irwib - 1; + i__1 = *nrhs; + for (jcol = 1; jcol <= i__1; ++jcol) { + i__2 = *n; + for (jrow = 1; jrow <= i__2; ++jrow) { + ++jreal; + ++jimag; + i__3 = jrow + jcol * b_dim1; + i__4 = jreal; + i__5 = jimag; + z__1.r = rwork[i__4], z__1.i = rwork[i__5]; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L150: */ + } +/* L160: */ + } + +/* Unscale. */ + + dlascl_("G", &c__0, &c__0, &c_b10, &orgnrm, n, &c__1, &d__[1], n, + info); + dlasrt_("D", n, &d__[1], info); + zlascl_("G", &c__0, &c__0, &orgnrm, &c_b10, n, nrhs, &b[b_offset], + ldb, info); + + return 0; + } + +/* Book-keeping and setting up some constants. */ + + nlvl = (integer) (log((doublereal) (*n) / (doublereal) (*smlsiz + 1)) / + log(2.)) + 1; + + smlszp = *smlsiz + 1; + + u = 1; + vt = *smlsiz * *n + 1; + difl = vt + smlszp * *n; + difr = difl + nlvl * *n; + z__ = difr + (nlvl * *n << 1); + c__ = z__ + nlvl * *n; + s = c__ + *n; + poles = s + *n; + givnum = poles + (nlvl << 1) * *n; + nrwork = givnum + (nlvl << 1) * *n; + bx = 1; + + irwrb = nrwork; + irwib = irwrb + *smlsiz * *nrhs; + irwb = irwib + *smlsiz * *nrhs; + + sizei = *n + 1; + k = sizei + *n; + givptr = k + *n; + perm = givptr + *n; + givcol = perm + nlvl * *n; + iwk = givcol + (nlvl * *n << 1); + + st = 1; + sqre = 0; + icmpq1 = 1; + icmpq2 = 0; + nsub = 0; + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = d__[i__], abs(d__1)) < eps) { + d__[i__] = d_sign(&eps, &d__[i__]); + } +/* L170: */ + } + + i__1 = nm1; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((d__1 = e[i__], abs(d__1)) < eps || i__ == nm1) { + ++nsub; + iwork[nsub] = st; + +/* Subproblem found. First determine its size and then */ +/* apply divide and conquer on it. */ + + if (i__ < nm1) { + +/* A subproblem with E(I) small for I < NM1. */ + + nsize = i__ - st + 1; + iwork[sizei + nsub - 1] = nsize; + } else if ((d__1 = e[i__], abs(d__1)) >= eps) { + +/* A subproblem with E(NM1) not too small but I = NM1. */ + + nsize = *n - st + 1; + iwork[sizei + nsub - 1] = nsize; + } else { + +/* A subproblem with E(NM1) small. This implies an */ +/* 1-by-1 subproblem at D(N), which is not solved */ +/* explicitly. */ + + nsize = i__ - st + 1; + iwork[sizei + nsub - 1] = nsize; + ++nsub; + iwork[nsub] = *n; + iwork[sizei + nsub - 1] = 1; + zcopy_(nrhs, &b[*n + b_dim1], ldb, &work[bx + nm1], n); + } + st1 = st - 1; + if (nsize == 1) { + +/* This is a 1-by-1 subproblem and is not solved */ +/* explicitly. */ + + zcopy_(nrhs, &b[st + b_dim1], ldb, &work[bx + st1], n); + } else if (nsize <= *smlsiz) { + +/* This is a small subproblem and is solved by DLASDQ. */ + + dlaset_("A", &nsize, &nsize, &c_b35, &c_b10, &rwork[vt + st1], + n); + dlaset_("A", &nsize, &nsize, &c_b35, &c_b10, &rwork[u + st1], + n); + dlasdq_("U", &c__0, &nsize, &nsize, &nsize, &c__0, &d__[st], & + e[st], &rwork[vt + st1], n, &rwork[u + st1], n, & + rwork[nrwork], &c__1, &rwork[nrwork], info) + ; + if (*info != 0) { + return 0; + } + +/* In the real version, B is passed to DLASDQ and multiplied */ +/* internally by Q**H. Here B is complex and that product is */ +/* computed below in two steps (real and imaginary parts). */ + + j = irwb - 1; + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + i__3 = st + nsize - 1; + for (jrow = st; jrow <= i__3; ++jrow) { + ++j; + i__4 = jrow + jcol * b_dim1; + rwork[j] = b[i__4].r; +/* L180: */ + } +/* L190: */ + } + dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[u + st1] + , n, &rwork[irwb], &nsize, &c_b35, &rwork[irwrb], & + nsize); + j = irwb - 1; + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + i__3 = st + nsize - 1; + for (jrow = st; jrow <= i__3; ++jrow) { + ++j; + rwork[j] = d_imag(&b[jrow + jcol * b_dim1]); +/* L200: */ + } +/* L210: */ + } + dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[u + st1] + , n, &rwork[irwb], &nsize, &c_b35, &rwork[irwib], & + nsize); + jreal = irwrb - 1; + jimag = irwib - 1; + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + i__3 = st + nsize - 1; + for (jrow = st; jrow <= i__3; ++jrow) { + ++jreal; + ++jimag; + i__4 = jrow + jcol * b_dim1; + i__5 = jreal; + i__6 = jimag; + z__1.r = rwork[i__5], z__1.i = rwork[i__6]; + b[i__4].r = z__1.r, b[i__4].i = z__1.i; +/* L220: */ + } +/* L230: */ + } + + zlacpy_("A", &nsize, nrhs, &b[st + b_dim1], ldb, &work[bx + + st1], n); + } else { + +/* A large problem. Solve it using divide and conquer. */ + + dlasda_(&icmpq1, smlsiz, &nsize, &sqre, &d__[st], &e[st], & + rwork[u + st1], n, &rwork[vt + st1], &iwork[k + st1], + &rwork[difl + st1], &rwork[difr + st1], &rwork[z__ + + st1], &rwork[poles + st1], &iwork[givptr + st1], & + iwork[givcol + st1], n, &iwork[perm + st1], &rwork[ + givnum + st1], &rwork[c__ + st1], &rwork[s + st1], & + rwork[nrwork], &iwork[iwk], info); + if (*info != 0) { + return 0; + } + bxst = bx + st1; + zlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &b[st + b_dim1], ldb, & + work[bxst], n, &rwork[u + st1], n, &rwork[vt + st1], & + iwork[k + st1], &rwork[difl + st1], &rwork[difr + st1] + , &rwork[z__ + st1], &rwork[poles + st1], &iwork[ + givptr + st1], &iwork[givcol + st1], n, &iwork[perm + + st1], &rwork[givnum + st1], &rwork[c__ + st1], &rwork[ + s + st1], &rwork[nrwork], &iwork[iwk], info); + if (*info != 0) { + return 0; + } + } + st = i__ + 1; + } +/* L240: */ + } + +/* Apply the singular values and treat the tiny ones as zero. */ + + tol = rcnd * (d__1 = d__[idamax_(n, &d__[1], &c__1)], abs(d__1)); + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Some of the elements in D can be negative because 1-by-1 */ +/* subproblems were not solved explicitly. */ + + if ((d__1 = d__[i__], abs(d__1)) <= tol) { + zlaset_("A", &c__1, nrhs, &c_b1, &c_b1, &work[bx + i__ - 1], n); + } else { + ++(*rank); + zlascl_("G", &c__0, &c__0, &d__[i__], &c_b10, &c__1, nrhs, &work[ + bx + i__ - 1], n, info); + } + d__[i__] = (d__1 = d__[i__], abs(d__1)); +/* L250: */ + } + +/* Now apply back the right singular vectors. */ + + icmpq2 = 1; + i__1 = nsub; + for (i__ = 1; i__ <= i__1; ++i__) { + st = iwork[i__]; + st1 = st - 1; + nsize = iwork[sizei + i__ - 1]; + bxst = bx + st1; + if (nsize == 1) { + zcopy_(nrhs, &work[bxst], n, &b[st + b_dim1], ldb); + } else if (nsize <= *smlsiz) { + +/* Since B and BX are complex, the following call to DGEMM */ +/* is performed in two steps (real and imaginary parts). */ + +/* CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE, */ +/* $ RWORK( VT+ST1 ), N, RWORK( BXST ), N, ZERO, */ +/* $ B( ST, 1 ), LDB ) */ + + j = bxst - *n - 1; + jreal = irwb - 1; + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + j += *n; + i__3 = nsize; + for (jrow = 1; jrow <= i__3; ++jrow) { + ++jreal; + i__4 = j + jrow; + rwork[jreal] = work[i__4].r; +/* L260: */ + } +/* L270: */ + } + dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[vt + st1], + n, &rwork[irwb], &nsize, &c_b35, &rwork[irwrb], &nsize); + j = bxst - *n - 1; + jimag = irwb - 1; + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + j += *n; + i__3 = nsize; + for (jrow = 1; jrow <= i__3; ++jrow) { + ++jimag; + rwork[jimag] = d_imag(&work[j + jrow]); +/* L280: */ + } +/* L290: */ + } + dgemm_("T", "N", &nsize, nrhs, &nsize, &c_b10, &rwork[vt + st1], + n, &rwork[irwb], &nsize, &c_b35, &rwork[irwib], &nsize); + jreal = irwrb - 1; + jimag = irwib - 1; + i__2 = *nrhs; + for (jcol = 1; jcol <= i__2; ++jcol) { + i__3 = st + nsize - 1; + for (jrow = st; jrow <= i__3; ++jrow) { + ++jreal; + ++jimag; + i__4 = jrow + jcol * b_dim1; + i__5 = jreal; + i__6 = jimag; + z__1.r = rwork[i__5], z__1.i = rwork[i__6]; + b[i__4].r = z__1.r, b[i__4].i = z__1.i; +/* L300: */ + } +/* L310: */ + } + } else { + zlalsa_(&icmpq2, smlsiz, &nsize, nrhs, &work[bxst], n, &b[st + + b_dim1], ldb, &rwork[u + st1], n, &rwork[vt + st1], & + iwork[k + st1], &rwork[difl + st1], &rwork[difr + st1], & + rwork[z__ + st1], &rwork[poles + st1], &iwork[givptr + + st1], &iwork[givcol + st1], n, &iwork[perm + st1], &rwork[ + givnum + st1], &rwork[c__ + st1], &rwork[s + st1], &rwork[ + nrwork], &iwork[iwk], info); + if (*info != 0) { + return 0; + } + } +/* L320: */ + } + +/* Unscale and sort the singular values. */ + + dlascl_("G", &c__0, &c__0, &c_b10, &orgnrm, n, &c__1, &d__[1], n, info); + dlasrt_("D", n, &d__[1], info); + zlascl_("G", &c__0, &c__0, &orgnrm, &c_b10, n, nrhs, &b[b_offset], ldb, + info); + + return 0; + +/* End of ZLALSD */ + +} /* zlalsd_ */ + diff --git a/lapack-netlib/SRC/zlamswlq.c b/lapack-netlib/SRC/zlamswlq.c new file mode 100644 index 000000000..f1349fb03 --- /dev/null +++ b/lapack-netlib/SRC/zlamswlq.c @@ -0,0 +1,846 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAMSWLQ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAMSWLQ( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, */ +/* $ LDT, C, LDC, WORK, LWORK, INFO ) */ + + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC */ +/* COMPLEX*16 A( LDA, * ), WORK( * ), C(LDC, * ), */ +/* $ T( LDT, * ) */ +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAMQRTS overwrites the general real M-by-N matrix C with */ +/* > */ +/* > */ +/* > SIDE = 'L' SIDE = 'R' */ +/* > TRANS = 'N': Q * C C * Q */ +/* > TRANS = 'C': Q**H * C C * Q**H */ +/* > where Q is a real orthogonal matrix defined as the product of blocked */ +/* > elementary reflectors computed by short wide LQ */ +/* > factorization (ZLASWLQ) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**H from the Left; */ +/* > = 'R': apply Q or Q**H from the Right. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': No transpose, apply Q; */ +/* > = 'C': Conjugate Transpose, apply Q**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. M >=0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. N >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > M >= K >= 0; */ +/* > */ +/* > \endverbatim */ +/* > \param[in] MB */ +/* > \verbatim */ +/* > MB is INTEGER */ +/* > The row block size to be used in the blocked QR. */ +/* > M >= MB >= 1 */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The column block size to be used in the blocked QR. */ +/* > NB > M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The block size to be used in the blocked QR. */ +/* > MB > M. */ +/* > */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension */ +/* > (LDA,M) if SIDE = 'L', */ +/* > (LDA,N) if SIDE = 'R' */ +/* > The i-th row must contain the vector which defines the blocked */ +/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* > ZLASWLQ in the first k rows of its array argument A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > If SIDE = 'L', LDA >= f2cmax(1,M); */ +/* > if SIDE = 'R', LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is COMPLEX*16 array, dimension */ +/* > ( M * Number of blocks(CEIL(N-K/NB-K)), */ +/* > The blocked upper triangular block reflectors stored in compact form */ +/* > as a sequence of upper triangular blocks. See below */ +/* > for further details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= MB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX*16 array, dimension (LDC,N) */ +/* > On entry, the M-by-N matrix C. */ +/* > On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > If SIDE = 'L', LWORK >= f2cmax(1,NB) * MB; */ +/* > if SIDE = 'R', LWORK >= f2cmax(1,M) * MB. */ +/* > 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. */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations, */ +/* > representing Q as a product of other orthogonal matrices */ +/* > Q = Q(1) * Q(2) * . . . * Q(k) */ +/* > where each Q(i) zeros out upper diagonal entries of a block of NB rows of A: */ +/* > Q(1) zeros out the upper diagonal entries of rows 1:NB of A */ +/* > Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A */ +/* > Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A */ +/* > . . . */ +/* > */ +/* > Q(1) is computed by GELQT, which represents Q(1) by Householder vectors */ +/* > stored under the diagonal of rows 1:MB of A, and by upper triangular */ +/* > block reflectors, stored in array T(1:LDT,1:N). */ +/* > For more information see Further Details in GELQT. */ +/* > */ +/* > Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors */ +/* > stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular */ +/* > block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M). */ +/* > The last Q(k) may use fewer rows. */ +/* > For more information see Further Details in TPQRT. */ +/* > */ +/* > For more details of the overall algorithm, see the description of */ +/* > Sequential TSQR in Section 2.2 of [1]. */ +/* > */ +/* > [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations, */ +/* > J. Demmel, L. Grigori, M. Hoemmen, J. Langou, */ +/* > SIAM J. Sci. Comput, vol. 34, no. 1, 2012 */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlamswlq_(char *side, char *trans, integer *m, integer * + n, integer *k, integer *mb, integer *nb, doublecomplex *a, integer * + lda, doublecomplex *t, integer *ldt, doublecomplex *c__, integer *ldc, + doublecomplex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, t_dim1, t_offset, i__1, i__2, + i__3; + + /* Local variables */ + logical left, tran; + integer i__; + extern logical lsame_(char *, char *); + logical right; + integer ii, kk, lw; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical notran, lquery; + integer ctr; + extern /* Subroutine */ int zgemlqt_(char *, char *, integer *, integer *, + integer *, integer *, doublecomplex *, integer *, doublecomplex * + , integer *, doublecomplex *, integer *, doublecomplex *, integer + *), ztpmlqt_(char *, char *, integer *, integer *, + integer *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, 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 2017 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + lquery = *lwork < 0; + notran = lsame_(trans, "N"); + tran = lsame_(trans, "C"); + left = lsame_(side, "L"); + right = lsame_(side, "R"); + if (left) { + lw = *n * *mb; + } else { + lw = *m * *mb; + } + + *info = 0; + if (! left && ! right) { + *info = -1; + } else if (! tran && ! notran) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0) { + *info = -5; + } else if (*lda < f2cmax(1,*k)) { + *info = -9; + } else if (*ldt < f2cmax(1,*mb)) { + *info = -11; + } else if (*ldc < f2cmax(1,*m)) { + *info = -13; + } else if (*lwork < f2cmax(1,lw) && ! lquery) { + *info = -15; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLAMSWLQ", &i__1, (ftnlen)8); + work[1].r = (doublereal) lw, work[1].i = 0.; + return 0; + } else if (lquery) { + work[1].r = (doublereal) lw, work[1].i = 0.; + return 0; + } + +/* Quick return if possible */ + +/* Computing MIN */ + i__1 = f2cmin(*m,*n); + if (f2cmin(i__1,*k) == 0) { + return 0; + } + +/* Computing MAX */ + i__1 = f2cmax(*m,*n); + if (*nb <= *k || *nb >= f2cmax(i__1,*k)) { + zgemlqt_(side, trans, m, n, k, mb, &a[a_offset], lda, &t[t_offset], + ldt, &c__[c_offset], ldc, &work[1], info); + return 0; + } + + if (left && tran) { + +/* Multiply Q to the last block of C */ + + kk = (*m - *k) % (*nb - *k); + ctr = (*m - *k) / (*nb - *k); + + if (kk > 0) { + ii = *m - kk + 1; + ztpmlqt_("L", "C", &kk, n, k, &c__0, mb, &a[ii * a_dim1 + 1], lda, + &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], + ldc, &c__[ii + c_dim1], ldc, &work[1], info); + } else { + ii = *m + 1; + } + + i__1 = *nb + 1; + i__2 = -(*nb - *k); + for (i__ = ii - (*nb - *k); i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ + += i__2) { + +/* Multiply Q to the current block of C (1:M,I:I+NB) */ + + --ctr; + i__3 = *nb - *k; + ztpmlqt_("L", "C", &i__3, n, k, &c__0, mb, &a[i__ * a_dim1 + 1], + lda, &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + + 1], ldc, &c__[i__ + c_dim1], ldc, &work[1], info); + } + +/* Multiply Q to the first block of C (1:M,1:NB) */ + + zgemlqt_("L", "C", nb, n, k, mb, &a[a_dim1 + 1], lda, &t[t_offset], + ldt, &c__[c_dim1 + 1], ldc, &work[1], info); + + } else if (left && notran) { + +/* Multiply Q to the first block of C */ + + kk = (*m - *k) % (*nb - *k); + ii = *m - kk + 1; + ctr = 1; + zgemlqt_("L", "N", nb, n, k, mb, &a[a_dim1 + 1], lda, &t[t_offset], + ldt, &c__[c_dim1 + 1], ldc, &work[1], info); + + i__2 = ii - *nb + *k; + i__1 = *nb - *k; + for (i__ = *nb + 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) + { + +/* Multiply Q to the current block of C (I:I+NB,1:N) */ + + i__3 = *nb - *k; + ztpmlqt_("L", "N", &i__3, n, k, &c__0, mb, &a[i__ * a_dim1 + 1], + lda, &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + + 1], ldc, &c__[i__ + c_dim1], ldc, &work[1], info); + ++ctr; + + } + if (ii <= *m) { + +/* Multiply Q to the last block of C */ + + ztpmlqt_("L", "N", &kk, n, k, &c__0, mb, &a[ii * a_dim1 + 1], lda, + &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], + ldc, &c__[ii + c_dim1], ldc, &work[1], info); + + } + + } else if (right && notran) { + +/* Multiply Q to the last block of C */ + + kk = (*n - *k) % (*nb - *k); + ctr = (*n - *k) / (*nb - *k); + if (kk > 0) { + ii = *n - kk + 1; + ztpmlqt_("R", "N", m, &kk, k, &c__0, mb, &a[ii * a_dim1 + 1], lda, + &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], + ldc, &c__[ii * c_dim1 + 1], ldc, &work[1], info); + } else { + ii = *n + 1; + } + + i__1 = *nb + 1; + i__2 = -(*nb - *k); + for (i__ = ii - (*nb - *k); i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ + += i__2) { + +/* Multiply Q to the current block of C (1:M,I:I+MB) */ + + --ctr; + i__3 = *nb - *k; + ztpmlqt_("R", "N", m, &i__3, k, &c__0, mb, &a[i__ * a_dim1 + 1], + lda, &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + + 1], ldc, &c__[i__ * c_dim1 + 1], ldc, &work[1], info); + } + +/* Multiply Q to the first block of C (1:M,1:MB) */ + + zgemlqt_("R", "N", m, nb, k, mb, &a[a_dim1 + 1], lda, &t[t_offset], + ldt, &c__[c_dim1 + 1], ldc, &work[1], info); + + } else if (right && tran) { + +/* Multiply Q to the first block of C */ + + kk = (*n - *k) % (*nb - *k); + ii = *n - kk + 1; + zgemlqt_("R", "C", m, nb, k, mb, &a[a_dim1 + 1], lda, &t[t_offset], + ldt, &c__[c_dim1 + 1], ldc, &work[1], info); + ctr = 1; + + i__2 = ii - *nb + *k; + i__1 = *nb - *k; + for (i__ = *nb + 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) + { + +/* Multiply Q to the current block of C (1:M,I:I+MB) */ + + i__3 = *nb - *k; + ztpmlqt_("R", "C", m, &i__3, k, &c__0, mb, &a[i__ * a_dim1 + 1], + lda, &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + + 1], ldc, &c__[i__ * c_dim1 + 1], ldc, &work[1], info); + ++ctr; + + } + if (ii <= *n) { + +/* Multiply Q to the last block of C */ + + ztpmlqt_("R", "C", m, &kk, k, &c__0, mb, &a[ii * a_dim1 + 1], lda, + &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], + ldc, &c__[ii * c_dim1 + 1], ldc, &work[1], info); + + } + + } + + work[1].r = (doublereal) lw, work[1].i = 0.; + return 0; + +/* End of ZLAMSWLQ */ + +} /* zlamswlq_ */ + diff --git a/lapack-netlib/SRC/zlamtsqr.c b/lapack-netlib/SRC/zlamtsqr.c new file mode 100644 index 000000000..341a4241c --- /dev/null +++ b/lapack-netlib/SRC/zlamtsqr.c @@ -0,0 +1,843 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAMTSQR */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAMTSQR( SIDE, TRANS, M, N, K, MB, NB, A, LDA, T, */ +/* $ LDT, C, LDC, WORK, LWORK, INFO ) */ + + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, LDA, M, N, K, MB, NB, LDT, LWORK, LDC */ +/* COMPLEX*16 A( LDA, * ), WORK( * ), C(LDC, * ), */ +/* $ T( LDT, * ) */ +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAMTSQR overwrites the general complex M-by-N matrix C with */ +/* > */ +/* > */ +/* > SIDE = 'L' SIDE = 'R' */ +/* > TRANS = 'N': Q * C C * Q */ +/* > TRANS = 'C': Q**H * C C * Q**H */ +/* > where Q is a real orthogonal matrix defined as the product */ +/* > of blocked elementary reflectors computed by tall skinny */ +/* > QR factorization (ZLATSQR) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**H from the Left; */ +/* > = 'R': apply Q or Q**H from the Right. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': No transpose, apply Q; */ +/* > = 'C': Conjugate Transpose, apply Q**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >=0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. M >= N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > N >= K >= 0; */ +/* > */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MB */ +/* > \verbatim */ +/* > MB is INTEGER */ +/* > The block size to be used in the blocked QR. */ +/* > MB > N. (must be the same as DLATSQR) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The column block size to be used in the blocked QR. */ +/* > N >= NB >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,K) */ +/* > The i-th column must contain the vector which defines the */ +/* > blockedelementary reflector H(i), for i = 1,2,...,k, as */ +/* > returned by DLATSQR in the first k columns of */ +/* > its array argument A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > If SIDE = 'L', LDA >= f2cmax(1,M); */ +/* > if SIDE = 'R', LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is COMPLEX*16 array, dimension */ +/* > ( N * Number of blocks(CEIL(M-K/MB-K)), */ +/* > The blocked upper triangular block reflectors stored in compact form */ +/* > as a sequence of upper triangular blocks. See below */ +/* > for further details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX*16 array, dimension (LDC,N) */ +/* > On entry, the M-by-N matrix C. */ +/* > On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > */ +/* > \endverbatim */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > */ +/* > If SIDE = 'L', LWORK >= f2cmax(1,N)*NB; */ +/* > if SIDE = 'R', LWORK >= f2cmax(1,MB)*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 */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations, */ +/* > representing Q as a product of other orthogonal matrices */ +/* > Q = Q(1) * Q(2) * . . . * Q(k) */ +/* > where each Q(i) zeros out subdiagonal entries of a block of MB rows of A: */ +/* > Q(1) zeros out the subdiagonal entries of rows 1:MB of A */ +/* > Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A */ +/* > Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A */ +/* > . . . */ +/* > */ +/* > Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors */ +/* > stored under the diagonal of rows 1:MB of A, and by upper triangular */ +/* > block reflectors, stored in array T(1:LDT,1:N). */ +/* > For more information see Further Details in GEQRT. */ +/* > */ +/* > Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors */ +/* > stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular */ +/* > block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N). */ +/* > The last Q(k) may use fewer rows. */ +/* > For more information see Further Details in TPQRT. */ +/* > */ +/* > For more details of the overall algorithm, see the description of */ +/* > Sequential TSQR in Section 2.2 of [1]. */ +/* > */ +/* > [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations, */ +/* > J. Demmel, L. Grigori, M. Hoemmen, J. Langou, */ +/* > SIAM J. Sci. Comput, vol. 34, no. 1, 2012 */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlamtsqr_(char *side, char *trans, integer *m, integer * + n, integer *k, integer *mb, integer *nb, doublecomplex *a, integer * + lda, doublecomplex *t, integer *ldt, doublecomplex *c__, integer *ldc, + doublecomplex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, t_dim1, t_offset, i__1, i__2, + i__3; + + /* Local variables */ + extern /* Subroutine */ int ztpmqrt_(char *, char *, integer *, integer *, + integer *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + logical left, tran; + integer i__; + extern logical lsame_(char *, char *); + logical right; + integer ii, kk, lw; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical notran, lquery; + integer ctr; + extern /* Subroutine */ int zgemqrt_(char *, char *, integer *, integer *, + integer *, integer *, doublecomplex *, integer *, doublecomplex * + , integer *, doublecomplex *, integer *, doublecomplex *, 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 2017 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + lquery = *lwork < 0; + notran = lsame_(trans, "N"); + tran = lsame_(trans, "C"); + left = lsame_(side, "L"); + right = lsame_(side, "R"); + if (left) { + lw = *n * *nb; + } else { + lw = *m * *nb; + } + + *info = 0; + if (! left && ! right) { + *info = -1; + } else if (! tran && ! notran) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0) { + *info = -5; + } else if (*lda < f2cmax(1,*k)) { + *info = -9; + } else if (*ldt < f2cmax(1,*nb)) { + *info = -11; + } else if (*ldc < f2cmax(1,*m)) { + *info = -13; + } else if (*lwork < f2cmax(1,lw) && ! lquery) { + *info = -15; + } + +/* Determine the block size if it is tall skinny or short and wide */ + + if (*info == 0) { + work[1].r = (doublereal) lw, work[1].i = 0.; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLAMTSQR", &i__1, (ftnlen)8); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + +/* Computing MIN */ + i__1 = f2cmin(*m,*n); + if (f2cmin(i__1,*k) == 0) { + return 0; + } + +/* Computing MAX */ + i__1 = f2cmax(*m,*n); + if (*mb <= *k || *mb >= f2cmax(i__1,*k)) { + zgemqrt_(side, trans, m, n, k, nb, &a[a_offset], lda, &t[t_offset], + ldt, &c__[c_offset], ldc, &work[1], info); + return 0; + } + + if (left && notran) { + +/* Multiply Q to the last block of C */ + + kk = (*m - *k) % (*mb - *k); + ctr = (*m - *k) / (*mb - *k); + if (kk > 0) { + ii = *m - kk + 1; + ztpmqrt_("L", "N", &kk, n, k, &c__0, nb, &a[ii + a_dim1], lda, &t[ + (ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], ldc, + &c__[ii + c_dim1], ldc, &work[1], info); + } else { + ii = *m + 1; + } + + i__1 = *mb + 1; + i__2 = -(*mb - *k); + for (i__ = ii - (*mb - *k); i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ + += i__2) { + +/* Multiply Q to the current block of C (I:I+MB,1:N) */ + + --ctr; + i__3 = *mb - *k; + ztpmqrt_("L", "N", &i__3, n, k, &c__0, nb, &a[i__ + a_dim1], lda, + &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], + ldc, &c__[i__ + c_dim1], ldc, &work[1], info); + } + +/* Multiply Q to the first block of C (1:MB,1:N) */ + + zgemqrt_("L", "N", mb, n, k, nb, &a[a_dim1 + 1], lda, &t[t_offset], + ldt, &c__[c_dim1 + 1], ldc, &work[1], info); + + } else if (left && tran) { + +/* Multiply Q to the first block of C */ + + kk = (*m - *k) % (*mb - *k); + ii = *m - kk + 1; + ctr = 1; + zgemqrt_("L", "C", mb, n, k, nb, &a[a_dim1 + 1], lda, &t[t_offset], + ldt, &c__[c_dim1 + 1], ldc, &work[1], info); + + i__2 = ii - *mb + *k; + i__1 = *mb - *k; + for (i__ = *mb + 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) + { + +/* Multiply Q to the current block of C (I:I+MB,1:N) */ + + i__3 = *mb - *k; + ztpmqrt_("L", "C", &i__3, n, k, &c__0, nb, &a[i__ + a_dim1], lda, + &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], + ldc, &c__[i__ + c_dim1], ldc, &work[1], info); + ++ctr; + + } + if (ii <= *m) { + +/* Multiply Q to the last block of C */ + + ztpmqrt_("L", "C", &kk, n, k, &c__0, nb, &a[ii + a_dim1], lda, &t[ + (ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], ldc, + &c__[ii + c_dim1], ldc, &work[1], info); + + } + + } else if (right && tran) { + +/* Multiply Q to the last block of C */ + + kk = (*n - *k) % (*mb - *k); + ctr = (*n - *k) / (*mb - *k); + if (kk > 0) { + ii = *n - kk + 1; + ztpmqrt_("R", "C", m, &kk, k, &c__0, nb, &a[ii + a_dim1], lda, &t[ + (ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], ldc, + &c__[ii * c_dim1 + 1], ldc, &work[1], info); + } else { + ii = *n + 1; + } + + i__1 = *mb + 1; + i__2 = -(*mb - *k); + for (i__ = ii - (*mb - *k); i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ + += i__2) { + +/* Multiply Q to the current block of C (1:M,I:I+MB) */ + + --ctr; + i__3 = *mb - *k; + ztpmqrt_("R", "C", m, &i__3, k, &c__0, nb, &a[i__ + a_dim1], lda, + &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], + ldc, &c__[i__ * c_dim1 + 1], ldc, &work[1], info); + } + +/* Multiply Q to the first block of C (1:M,1:MB) */ + + zgemqrt_("R", "C", m, mb, k, nb, &a[a_dim1 + 1], lda, &t[t_offset], + ldt, &c__[c_dim1 + 1], ldc, &work[1], info); + + } else if (right && notran) { + +/* Multiply Q to the first block of C */ + + kk = (*n - *k) % (*mb - *k); + ii = *n - kk + 1; + ctr = 1; + zgemqrt_("R", "N", m, mb, k, nb, &a[a_dim1 + 1], lda, &t[t_offset], + ldt, &c__[c_dim1 + 1], ldc, &work[1], info); + + i__2 = ii - *mb + *k; + i__1 = *mb - *k; + for (i__ = *mb + 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) + { + +/* Multiply Q to the current block of C (1:M,I:I+MB) */ + + i__3 = *mb - *k; + ztpmqrt_("R", "N", m, &i__3, k, &c__0, nb, &a[i__ + a_dim1], lda, + &t[(ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], + ldc, &c__[i__ * c_dim1 + 1], ldc, &work[1], info); + ++ctr; + + } + if (ii <= *n) { + +/* Multiply Q to the last block of C */ + + ztpmqrt_("R", "N", m, &kk, k, &c__0, nb, &a[ii + a_dim1], lda, &t[ + (ctr * *k + 1) * t_dim1 + 1], ldt, &c__[c_dim1 + 1], ldc, + &c__[ii * c_dim1 + 1], ldc, &work[1], info); + + } + + } + + work[1].r = (doublereal) lw, work[1].i = 0.; + return 0; + +/* End of ZLAMTSQR */ + +} /* zlamtsqr_ */ + diff --git a/lapack-netlib/SRC/zlangb.c b/lapack-netlib/SRC/zlangb.c new file mode 100644 index 000000000..6af5f4c80 --- /dev/null +++ b/lapack-netlib/SRC/zlangb.c @@ -0,0 +1,664 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute +value of any element of general band matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLANGB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLANGB( NORM, N, KL, KU, AB, LDAB, */ +/* WORK ) */ + +/* CHARACTER NORM */ +/* INTEGER KL, KU, LDAB, N */ +/* DOUBLE PRECISION WORK( * ) */ +/* COMPLEX*16 AB( LDAB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLANGB returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of an */ +/* > n by n band matrix A, with kl sub-diagonals and ku super-diagonals. */ +/* > \endverbatim */ +/* > */ +/* > \return ZLANGB */ +/* > \verbatim */ +/* > */ +/* > ZLANGB = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in ZLANGB as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, ZLANGB is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of sub-diagonals of the matrix A. KL >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of super-diagonals of the matrix A. KU >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is COMPLEX*16 array, dimension (LDAB,N) */ +/* > The band matrix A, stored in rows 1 to KL+KU+1. The j-th */ +/* > column of A is stored in the j-th column of the array AB as */ +/* > follows: */ +/* > AB(ku+1+i-j,j) = A(i,j) for f2cmax(1,j-ku)<=i<=f2cmin(n,j+kl). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ +/* > where LWORK >= N when NORM = 'I'; otherwise, WORK is not */ +/* > referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GBauxiliary */ + +/* ===================================================================== */ +doublereal zlangb_(char *norm, integer *n, integer *kl, integer *ku, + doublecomplex *ab, integer *ldab, doublereal *work) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6; + doublereal ret_val; + + /* Local variables */ + doublereal temp; + extern /* Subroutine */ int dcombssq_(doublereal *, doublereal *); + integer i__, j, k, l; + extern logical lsame_(char *, char *); + doublereal value; + extern logical disnan_(doublereal *); + doublereal colssq[2]; + extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *, + doublereal *, doublereal *); + doublereal sum, ssq[2]; + + +/* -- 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 */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --work; + + /* Function Body */ + if (*n == 0) { + value = 0.; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + value = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = *ku + 2 - j; +/* Computing MIN */ + i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1; + i__3 = f2cmin(i__4,i__5); + for (i__ = f2cmax(i__2,1); i__ <= i__3; ++i__) { + temp = z_abs(&ab[i__ + j * ab_dim1]); + if (value < temp || disnan_(&temp)) { + value = temp; + } +/* L10: */ + } +/* L20: */ + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + value = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; +/* Computing MAX */ + i__3 = *ku + 2 - j; +/* Computing MIN */ + i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1; + i__2 = f2cmin(i__4,i__5); + for (i__ = f2cmax(i__3,1); i__ <= i__2; ++i__) { + sum += z_abs(&ab[i__ + j * ab_dim1]); +/* L30: */ + } + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L40: */ + } + } else if (lsame_(norm, "I")) { + +/* Find normI(A). */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L50: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + k = *ku + 1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *ku; +/* Computing MIN */ + i__5 = *n, i__6 = j + *kl; + i__4 = f2cmin(i__5,i__6); + for (i__ = f2cmax(i__2,i__3); i__ <= i__4; ++i__) { + work[i__] += z_abs(&ab[k + i__ + j * ab_dim1]); +/* L60: */ + } +/* L70: */ + } + value = 0.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || disnan_(&temp)) { + value = temp; + } +/* L80: */ + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ +/* SSQ(1) is scale */ +/* SSQ(2) is sum-of-squares */ +/* For better accuracy, sum each column separately. */ + + ssq[0] = 0.; + ssq[1] = 1.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__4 = 1, i__2 = j - *ku; + l = f2cmax(i__4,i__2); + k = *ku + 1 - j + l; + colssq[0] = 0.; + colssq[1] = 1.; +/* Computing MIN */ + i__2 = *n, i__3 = j + *kl; + i__4 = f2cmin(i__2,i__3) - l + 1; + zlassq_(&i__4, &ab[k + j * ab_dim1], &c__1, colssq, &colssq[1]); + dcombssq_(ssq, colssq); +/* L90: */ + } + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of ZLANGB */ + +} /* zlangb_ */ + diff --git a/lapack-netlib/SRC/zlange.c b/lapack-netlib/SRC/zlange.c new file mode 100644 index 000000000..00577b081 --- /dev/null +++ b/lapack-netlib/SRC/zlange.c @@ -0,0 +1,635 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute +value of any element of a general rectangular matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLANGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLANGE( NORM, M, N, A, LDA, WORK ) */ + +/* CHARACTER NORM */ +/* INTEGER LDA, M, N */ +/* DOUBLE PRECISION WORK( * ) */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLANGE returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of a */ +/* > complex matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \return ZLANGE */ +/* > \verbatim */ +/* > */ +/* > ZLANGE = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in ZLANGE as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. When M = 0, */ +/* > ZLANGE is set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. When N = 0, */ +/* > ZLANGE is set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > The m by n matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(M,1). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ +/* > where LWORK >= M when NORM = 'I'; otherwise, WORK is not */ +/* > referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GEauxiliary */ + +/* ===================================================================== */ +doublereal zlange_(char *norm, integer *m, integer *n, doublecomplex *a, + integer *lda, doublereal *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublereal ret_val; + + /* Local variables */ + doublereal temp; + extern /* Subroutine */ int dcombssq_(doublereal *, doublereal *); + integer i__, j; + extern logical lsame_(char *, char *); + doublereal value; + extern logical disnan_(doublereal *); + doublereal colssq[2]; + extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *, + doublereal *, doublereal *); + doublereal sum, ssq[2]; + + +/* -- 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; + --work; + + /* Function Body */ + if (f2cmin(*m,*n) == 0) { + value = 0.; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + value = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = z_abs(&a[i__ + j * a_dim1]); + if (value < temp || disnan_(&temp)) { + value = temp; + } +/* L10: */ + } +/* L20: */ + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + value = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + sum += z_abs(&a[i__ + j * a_dim1]); +/* L30: */ + } + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L40: */ + } + } else if (lsame_(norm, "I")) { + +/* Find normI(A). */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L50: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] += z_abs(&a[i__ + j * a_dim1]); +/* L60: */ + } +/* L70: */ + } + value = 0.; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || disnan_(&temp)) { + value = temp; + } +/* L80: */ + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ +/* SSQ(1) is scale */ +/* SSQ(2) is sum-of-squares */ +/* For better accuracy, sum each column separately. */ + + ssq[0] = 0.; + ssq[1] = 1.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; + zlassq_(m, &a[j * a_dim1 + 1], &c__1, colssq, &colssq[1]); + dcombssq_(ssq, colssq); +/* L90: */ + } + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of ZLANGE */ + +} /* zlange_ */ + diff --git a/lapack-netlib/SRC/zlangt.c b/lapack-netlib/SRC/zlangt.c new file mode 100644 index 000000000..feb69273d --- /dev/null +++ b/lapack-netlib/SRC/zlangt.c @@ -0,0 +1,623 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLANGT returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute +value of any element of a general tridiagonal matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLANGT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLANGT( NORM, N, DL, D, DU ) */ + +/* CHARACTER NORM */ +/* INTEGER N */ +/* COMPLEX*16 D( * ), DL( * ), DU( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLANGT returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of a */ +/* > complex tridiagonal matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \return ZLANGT */ +/* > \verbatim */ +/* > */ +/* > ZLANGT = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in ZLANGT as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, ZLANGT is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DL */ +/* > \verbatim */ +/* > DL is COMPLEX*16 array, dimension (N-1) */ +/* > The (n-1) sub-diagonal elements of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is COMPLEX*16 array, dimension (N) */ +/* > The diagonal elements of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DU */ +/* > \verbatim */ +/* > DU is COMPLEX*16 array, dimension (N-1) */ +/* > The (n-1) super-diagonal elements of A. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +doublereal zlangt_(char *norm, integer *n, doublecomplex *dl, doublecomplex * + d__, doublecomplex *du) +{ + /* System generated locals */ + integer i__1; + doublereal ret_val, d__1; + + /* Local variables */ + doublereal temp; + integer i__; + doublereal scale; + extern logical lsame_(char *, char *); + doublereal anorm; + extern logical disnan_(doublereal *); + extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *, + doublereal *, doublereal *); + doublereal sum; + + +/* -- 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 */ + --du; + --d__; + --dl; + + /* Function Body */ + if (*n <= 0) { + anorm = 0.; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + anorm = z_abs(&d__[*n]); + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + d__1 = z_abs(&dl[i__]); + if (anorm < z_abs(&dl[i__]) || disnan_(&d__1)) { + anorm = z_abs(&dl[i__]); + } + d__1 = z_abs(&d__[i__]); + if (anorm < z_abs(&d__[i__]) || disnan_(&d__1)) { + anorm = z_abs(&d__[i__]); + } + d__1 = z_abs(&du[i__]); + if (anorm < z_abs(&du[i__]) || disnan_(&d__1)) { + anorm = z_abs(&du[i__]); + } +/* L10: */ + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + if (*n == 1) { + anorm = z_abs(&d__[1]); + } else { + anorm = z_abs(&d__[1]) + z_abs(&dl[1]); + temp = z_abs(&d__[*n]) + z_abs(&du[*n - 1]); + if (anorm < temp || disnan_(&temp)) { + anorm = temp; + } + i__1 = *n - 1; + for (i__ = 2; i__ <= i__1; ++i__) { + temp = z_abs(&d__[i__]) + z_abs(&dl[i__]) + z_abs(&du[i__ - 1] + ); + if (anorm < temp || disnan_(&temp)) { + anorm = temp; + } +/* L20: */ + } + } + } else if (lsame_(norm, "I")) { + +/* Find normI(A). */ + + if (*n == 1) { + anorm = z_abs(&d__[1]); + } else { + anorm = z_abs(&d__[1]) + z_abs(&du[1]); + temp = z_abs(&d__[*n]) + z_abs(&dl[*n - 1]); + if (anorm < temp || disnan_(&temp)) { + anorm = temp; + } + i__1 = *n - 1; + for (i__ = 2; i__ <= i__1; ++i__) { + temp = z_abs(&d__[i__]) + z_abs(&du[i__]) + z_abs(&dl[i__ - 1] + ); + if (anorm < temp || disnan_(&temp)) { + anorm = temp; + } +/* L30: */ + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ + + scale = 0.; + sum = 1.; + zlassq_(n, &d__[1], &c__1, &scale, &sum); + if (*n > 1) { + i__1 = *n - 1; + zlassq_(&i__1, &dl[1], &c__1, &scale, &sum); + i__1 = *n - 1; + zlassq_(&i__1, &du[1], &c__1, &scale, &sum); + } + anorm = scale * sqrt(sum); + } + + ret_val = anorm; + return ret_val; + +/* End of ZLANGT */ + +} /* zlangt_ */ + diff --git a/lapack-netlib/SRC/zlanhb.c b/lapack-netlib/SRC/zlanhb.c new file mode 100644 index 000000000..a8e79573e --- /dev/null +++ b/lapack-netlib/SRC/zlanhb.c @@ -0,0 +1,747 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLANHB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the ele +ment of largest absolute value of a Hermitian band matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLANHB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLANHB( NORM, UPLO, N, K, AB, LDAB, */ +/* WORK ) */ + +/* CHARACTER NORM, UPLO */ +/* INTEGER K, LDAB, N */ +/* DOUBLE PRECISION WORK( * ) */ +/* COMPLEX*16 AB( LDAB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLANHB returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of an */ +/* > n by n hermitian band matrix A, with k super-diagonals. */ +/* > \endverbatim */ +/* > */ +/* > \return ZLANHB */ +/* > \verbatim */ +/* > */ +/* > ZLANHB = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in ZLANHB as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > band matrix A is supplied. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, ZLANHB is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of super-diagonals or sub-diagonals of the */ +/* > band matrix A. K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is COMPLEX*16 array, dimension (LDAB,N) */ +/* > The upper or lower triangle of the hermitian band matrix A, */ +/* > stored in the first K+1 rows of AB. The j-th column of A is */ +/* > stored in the j-th column of the array AB as follows: */ +/* > if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for f2cmax(1,j-k)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+k). */ +/* > Note that the imaginary parts of the diagonal elements need */ +/* > not be set and are assumed to be zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= K+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ +/* > where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */ +/* > WORK is not referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +doublereal zlanhb_(char *norm, char *uplo, integer *n, integer *k, + doublecomplex *ab, integer *ldab, doublereal *work) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; + doublereal ret_val, d__1; + + /* Local variables */ + doublereal absa; + extern /* Subroutine */ int dcombssq_(doublereal *, doublereal *); + integer i__, j, l; + extern logical lsame_(char *, char *); + doublereal value; + extern logical disnan_(doublereal *); + doublereal colssq[2]; + extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *, + doublereal *, doublereal *); + doublereal sum, ssq[2]; + + +/* -- 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 */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --work; + + /* Function Body */ + if (*n == 0) { + value = 0.; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + value = 0.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = *k + 2 - j; + i__3 = *k; + for (i__ = f2cmax(i__2,1); i__ <= i__3; ++i__) { + sum = z_abs(&ab[i__ + j * ab_dim1]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L10: */ + } + i__3 = *k + 1 + j * ab_dim1; + sum = (d__1 = ab[i__3].r, abs(d__1)); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__3 = j * ab_dim1 + 1; + sum = (d__1 = ab[i__3].r, abs(d__1)); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* Computing MIN */ + i__2 = *n + 1 - j, i__4 = *k + 1; + i__3 = f2cmin(i__2,i__4); + for (i__ = 2; i__ <= i__3; ++i__) { + sum = z_abs(&ab[i__ + j * ab_dim1]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L30: */ + } +/* L40: */ + } + } + } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { + +/* Find normI(A) ( = norm1(A), since A is hermitian). */ + + value = 0.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + l = *k + 1 - j; +/* Computing MAX */ + i__3 = 1, i__2 = j - *k; + i__4 = j - 1; + for (i__ = f2cmax(i__3,i__2); i__ <= i__4; ++i__) { + absa = z_abs(&ab[l + i__ + j * ab_dim1]); + sum += absa; + work[i__] += absa; +/* L50: */ + } + i__4 = *k + 1 + j * ab_dim1; + work[j] = sum + (d__1 = ab[i__4].r, abs(d__1)); +/* L60: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L70: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L80: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__4 = j * ab_dim1 + 1; + sum = work[j] + (d__1 = ab[i__4].r, abs(d__1)); + l = 1 - j; +/* Computing MIN */ + i__3 = *n, i__2 = j + *k; + i__4 = f2cmin(i__3,i__2); + for (i__ = j + 1; i__ <= i__4; ++i__) { + absa = z_abs(&ab[l + i__ + j * ab_dim1]); + sum += absa; + work[i__] += absa; +/* L90: */ + } + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L100: */ + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ +/* SSQ(1) is scale */ +/* SSQ(2) is sum-of-squares */ +/* For better accuracy, sum each column separately. */ + + ssq[0] = 0.; + ssq[1] = 1.; + +/* Sum off-diagonals */ + + if (*k > 0) { + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; +/* Computing MIN */ + i__3 = j - 1; + i__4 = f2cmin(i__3,*k); +/* Computing MAX */ + i__2 = *k + 2 - j; + zlassq_(&i__4, &ab[f2cmax(i__2,1) + j * ab_dim1], &c__1, + colssq, &colssq[1]); + dcombssq_(ssq, colssq); +/* L110: */ + } + l = *k + 1; + } else { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; +/* Computing MIN */ + i__3 = *n - j; + i__4 = f2cmin(i__3,*k); + zlassq_(&i__4, &ab[j * ab_dim1 + 2], &c__1, colssq, & + colssq[1]); + dcombssq_(ssq, colssq); +/* L120: */ + } + l = 1; + } + ssq[1] *= 2; + } else { + l = 1; + } + +/* Sum diagonal */ + + colssq[0] = 0.; + colssq[1] = 1.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__4 = l + j * ab_dim1; + if (ab[i__4].r != 0.) { + i__4 = l + j * ab_dim1; + absa = (d__1 = ab[i__4].r, abs(d__1)); + if (colssq[0] < absa) { +/* Computing 2nd power */ + d__1 = colssq[0] / absa; + colssq[1] = colssq[1] * (d__1 * d__1) + 1.; + colssq[0] = absa; + } else { +/* Computing 2nd power */ + d__1 = absa / colssq[0]; + colssq[1] += d__1 * d__1; + } + } +/* L130: */ + } + dcombssq_(ssq, colssq); + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of ZLANHB */ + +} /* zlanhb_ */ + diff --git a/lapack-netlib/SRC/zlanhe.c b/lapack-netlib/SRC/zlanhe.c new file mode 100644 index 000000000..09d944b3d --- /dev/null +++ b/lapack-netlib/SRC/zlanhe.c @@ -0,0 +1,714 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLANHE returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the ele +ment of largest absolute value of a complex Hermitian matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLANHE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLANHE( NORM, UPLO, N, A, LDA, WORK ) */ + +/* CHARACTER NORM, UPLO */ +/* INTEGER LDA, N */ +/* DOUBLE PRECISION WORK( * ) */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLANHE returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of a */ +/* > complex hermitian matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \return ZLANHE */ +/* > \verbatim */ +/* > */ +/* > ZLANHE = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in ZLANHE as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > hermitian matrix A is to be referenced. */ +/* > = 'U': Upper triangular part of A is referenced */ +/* > = 'L': Lower triangular part of A is referenced */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, ZLANHE is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > The hermitian 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. Note that the imaginary parts of the diagonal */ +/* > elements need not be set and are assumed to be zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(N,1). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ +/* > where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */ +/* > WORK is not referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16HEauxiliary */ + +/* ===================================================================== */ +doublereal zlanhe_(char *norm, char *uplo, integer *n, doublecomplex *a, + integer *lda, doublereal *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublereal ret_val, d__1; + + /* Local variables */ + doublereal absa; + extern /* Subroutine */ int dcombssq_(doublereal *, doublereal *); + integer i__, j; + extern logical lsame_(char *, char *); + doublereal value; + extern logical disnan_(doublereal *); + doublereal colssq[2]; + extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *, + doublereal *, doublereal *); + doublereal sum, ssq[2]; + + +/* -- 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; + --work; + + /* Function Body */ + if (*n == 0) { + value = 0.; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + value = 0.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + sum = z_abs(&a[i__ + j * a_dim1]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L10: */ + } + i__2 = j + j * a_dim1; + sum = (d__1 = a[i__2].r, abs(d__1)); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + j * a_dim1; + sum = (d__1 = a[i__2].r, abs(d__1)); + if (value < sum || disnan_(&sum)) { + value = sum; + } + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + sum = z_abs(&a[i__ + j * a_dim1]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L30: */ + } +/* L40: */ + } + } + } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { + +/* Find normI(A) ( = norm1(A), since A is hermitian). */ + + value = 0.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + absa = z_abs(&a[i__ + j * a_dim1]); + sum += absa; + work[i__] += absa; +/* L50: */ + } + i__2 = j + j * a_dim1; + work[j] = sum + (d__1 = a[i__2].r, abs(d__1)); +/* L60: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L70: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L80: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j + j * a_dim1; + sum = work[j] + (d__1 = a[i__2].r, abs(d__1)); + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + absa = z_abs(&a[i__ + j * a_dim1]); + sum += absa; + work[i__] += absa; +/* L90: */ + } + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L100: */ + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ +/* SSQ(1) is scale */ +/* SSQ(2) is sum-of-squares */ +/* For better accuracy, sum each column separately. */ + + ssq[0] = 0.; + ssq[1] = 1.; + +/* Sum off-diagonals */ + + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; + i__2 = j - 1; + zlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, colssq, &colssq[1]); + dcombssq_(ssq, colssq); +/* L110: */ + } + } else { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; + i__2 = *n - j; + zlassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, colssq, &colssq[ + 1]); + dcombssq_(ssq, colssq); +/* L120: */ + } + } + ssq[1] *= 2; + +/* Sum diagonal */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + if (a[i__2].r != 0.) { + i__2 = i__ + i__ * a_dim1; + absa = (d__1 = a[i__2].r, abs(d__1)); + if (ssq[0] < absa) { +/* Computing 2nd power */ + d__1 = ssq[0] / absa; + ssq[1] = ssq[1] * (d__1 * d__1) + 1.; + ssq[0] = absa; + } else { +/* Computing 2nd power */ + d__1 = absa / ssq[0]; + ssq[1] += d__1 * d__1; + } + } +/* L130: */ + } + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of ZLANHE */ + +} /* zlanhe_ */ + diff --git a/lapack-netlib/SRC/zlanhf.c b/lapack-netlib/SRC/zlanhf.c new file mode 100644 index 000000000..522a38eee --- /dev/null +++ b/lapack-netlib/SRC/zlanhf.c @@ -0,0 +1,2333 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLANHF returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the ele +ment of largest absolute value of a Hermitian matrix in RFP format. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLANHF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLANHF( NORM, TRANSR, UPLO, N, A, WORK ) */ + +/* CHARACTER NORM, TRANSR, UPLO */ +/* INTEGER N */ +/* DOUBLE PRECISION WORK( 0: * ) */ +/* COMPLEX*16 A( 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLANHF returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of a */ +/* > complex Hermitian matrix A in RFP format. */ +/* > \endverbatim */ +/* > */ +/* > \return ZLANHF */ +/* > \verbatim */ +/* > */ +/* > ZLANHF = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER */ +/* > Specifies the value to be returned in ZLANHF as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER */ +/* > Specifies whether the RFP format of A is normal or */ +/* > conjugate-transposed format. */ +/* > = 'N': RFP format is Normal */ +/* > = 'C': RFP format is Conjugate-transposed */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER */ +/* > On entry, UPLO specifies whether the RFP matrix A came from */ +/* > an upper or lower triangular matrix as follows: */ +/* > */ +/* > UPLO = 'U' or 'u' RFP A came from an upper triangular */ +/* > matrix */ +/* > */ +/* > UPLO = 'L' or 'l' RFP A came from a lower triangular */ +/* > matrix */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, ZLANHF is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension ( N*(N+1)/2 ); */ +/* > On entry, the matrix A in RFP Format. */ +/* > RFP Format is described by TRANSR, UPLO and N as follows: */ +/* > If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even; */ +/* > K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If */ +/* > TRANSR = 'C' then RFP is the Conjugate-transpose of RFP A */ +/* > as defined when TRANSR = 'N'. The contents of RFP A are */ +/* > defined by UPLO as follows: If UPLO = 'U' the RFP A */ +/* > contains the ( N*(N+1)/2 ) elements of upper packed A */ +/* > either in normal or conjugate-transpose Format. If */ +/* > UPLO = 'L' the RFP A contains the ( N*(N+1) /2 ) elements */ +/* > of lower packed A either in normal or conjugate-transpose */ +/* > Format. The LDA of RFP A is (N+1)/2 when TRANSR = 'C'. When */ +/* > TRANSR is 'N' the LDA is N+1 when N is even and is N when */ +/* > is odd. See the Note below for more details. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (LWORK), */ +/* > where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */ +/* > WORK is not referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > We first consider Standard Packed Format when N is even. */ +/* > We give an example where N = 6. */ +/* > */ +/* > AP is Upper AP is Lower */ +/* > */ +/* > 00 01 02 03 04 05 00 */ +/* > 11 12 13 14 15 10 11 */ +/* > 22 23 24 25 20 21 22 */ +/* > 33 34 35 30 31 32 33 */ +/* > 44 45 40 41 42 43 44 */ +/* > 55 50 51 52 53 54 55 */ +/* > */ +/* > */ +/* > Let TRANSR = 'N'. RFP holds AP as follows: */ +/* > For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ +/* > three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ +/* > conjugate-transpose of the first three columns of AP upper. */ +/* > For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ +/* > three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ +/* > conjugate-transpose of the last three columns of AP lower. */ +/* > To denote conjugate we place -- above the element. This covers the */ +/* > case N even and TRANSR = 'N'. */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > -- -- -- */ +/* > 03 04 05 33 43 53 */ +/* > -- -- */ +/* > 13 14 15 00 44 54 */ +/* > -- */ +/* > 23 24 25 10 11 55 */ +/* > */ +/* > 33 34 35 20 21 22 */ +/* > -- */ +/* > 00 44 45 30 31 32 */ +/* > -- -- */ +/* > 01 11 55 40 41 42 */ +/* > -- -- -- */ +/* > 02 12 22 50 51 52 */ +/* > */ +/* > Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */ +/* > transpose of RFP A above. One therefore gets: */ +/* > */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > -- -- -- -- -- -- -- -- -- -- */ +/* > 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ +/* > -- -- -- -- -- -- -- -- -- -- */ +/* > 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ +/* > -- -- -- -- -- -- -- -- -- -- */ +/* > 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ +/* > */ +/* > */ +/* > We next consider Standard Packed Format when N is odd. */ +/* > We give an example where N = 5. */ +/* > */ +/* > AP is Upper AP is Lower */ +/* > */ +/* > 00 01 02 03 04 00 */ +/* > 11 12 13 14 10 11 */ +/* > 22 23 24 20 21 22 */ +/* > 33 34 30 31 32 33 */ +/* > 44 40 41 42 43 44 */ +/* > */ +/* > */ +/* > Let TRANSR = 'N'. RFP holds AP as follows: */ +/* > For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ +/* > three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ +/* > conjugate-transpose of the first two columns of AP upper. */ +/* > For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ +/* > three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ +/* > conjugate-transpose of the last two columns of AP lower. */ +/* > To denote conjugate we place -- above the element. This covers the */ +/* > case N odd and TRANSR = 'N'. */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > -- -- */ +/* > 02 03 04 00 33 43 */ +/* > -- */ +/* > 12 13 14 10 11 44 */ +/* > */ +/* > 22 23 24 20 21 22 */ +/* > -- */ +/* > 00 33 34 30 31 32 */ +/* > -- -- */ +/* > 01 11 44 40 41 42 */ +/* > */ +/* > Now let TRANSR = 'C'. RFP A in both UPLO cases is just the conjugate- */ +/* > transpose of RFP A above. One therefore gets: */ +/* > */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > -- -- -- -- -- -- -- -- -- */ +/* > 02 12 22 00 01 00 10 20 30 40 50 */ +/* > -- -- -- -- -- -- -- -- -- */ +/* > 03 13 23 33 11 33 11 21 31 41 51 */ +/* > -- -- -- -- -- -- -- -- -- */ +/* > 04 14 24 34 44 43 44 22 32 42 52 */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +doublereal zlanhf_(char *norm, char *transr, char *uplo, integer *n, + doublecomplex *a, doublereal *work) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal ret_val, d__1; + + /* Local variables */ + doublereal temp; + integer i__, j, k, l; + doublereal s, scale; + extern logical lsame_(char *, char *); + doublereal value; + integer n1; + doublereal aa; + extern logical disnan_(doublereal *); + extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *, + doublereal *, doublereal *); + integer lda, ifm, noe, ilu; + + +/* -- 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 */ + + +/* ===================================================================== */ + + + if (*n == 0) { + ret_val = 0.; + return ret_val; + } else if (*n == 1) { + ret_val = (d__1 = a[0].r, abs(d__1)); + return ret_val; + } + +/* set noe = 1 if n is odd. if n is even set noe=0 */ + + noe = 1; + if (*n % 2 == 0) { + noe = 0; + } + +/* set ifm = 0 when form='C' or 'c' and 1 otherwise */ + + ifm = 1; + if (lsame_(transr, "C")) { + ifm = 0; + } + +/* set ilu = 0 when uplo='U or 'u' and 1 otherwise */ + + ilu = 1; + if (lsame_(uplo, "U")) { + ilu = 0; + } + +/* set lda = (n+1)/2 when ifm = 0 */ +/* set lda = n when ifm = 1 and noe = 1 */ +/* set lda = n+1 when ifm = 1 and noe = 0 */ + + if (ifm == 1) { + if (noe == 1) { + lda = *n; + } else { +/* noe=0 */ + lda = *n + 1; + } + } else { +/* ifm=0 */ + lda = (*n + 1) / 2; + } + + if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + k = (*n + 1) / 2; + value = 0.; + if (noe == 1) { +/* n is odd & n = k + k - 1 */ + if (ifm == 1) { +/* A is n by k */ + if (ilu == 1) { +/* uplo ='L' */ + j = 0; +/* -> L(0,0) */ + i__1 = j + j * lda; + temp = (d__1 = a[i__1].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 2; + for (i__ = 0; i__ <= i__2; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + i__ = j - 1; +/* L(k+j,k+j) */ + i__2 = i__ + j * lda; + temp = (d__1 = a[i__2].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__ = j; +/* -> L(j,j) */ + i__2 = i__ + j * lda; + temp = (d__1 = a[i__2].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__2 = *n - 1; + for (i__ = j + 1; i__ <= i__2; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } + } else { +/* uplo = 'U' */ + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = k + j - 2; + for (i__ = 0; i__ <= i__2; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + i__ = k + j - 1; +/* -> U(i,i) */ + i__2 = i__ + j * lda; + temp = (d__1 = a[i__2].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + ++i__; +/* =k+j; i -> U(j,j) */ + i__2 = i__ + j * lda; + temp = (d__1 = a[i__2].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__2 = *n - 1; + for (i__ = k + j + 1; i__ <= i__2; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } + i__1 = *n - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } +/* j=k-1 */ + } +/* i=n-1 -> U(n-1,n-1) */ + i__1 = i__ + j * lda; + temp = (d__1 = a[i__1].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } else { +/* xpose case; A is k by n */ + if (ilu == 1) { +/* uplo ='L' */ + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + i__ = j; +/* L(i,i) */ + i__2 = i__ + j * lda; + temp = (d__1 = a[i__2].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__ = j + 1; +/* L(j+k,j+k) */ + i__2 = i__ + j * lda; + temp = (d__1 = a[i__2].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__2 = k - 1; + for (i__ = j + 2; i__ <= i__2; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } + j = k - 1; + i__1 = k - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + i__ = k - 1; +/* -> L(i,i) is at A(i,j) */ + i__1 = i__ + j * lda; + temp = (d__1 = a[i__1].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__1 = *n - 1; + for (j = k; j <= i__1; ++j) { + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } + } else { +/* uplo = 'U' */ + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } + j = k - 1; +/* -> U(j,j) is at A(0,j) */ + i__1 = j * lda; + temp = (d__1 = a[i__1].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__1 = k - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + i__1 = *n - 1; + for (j = k; j <= i__1; ++j) { + i__2 = j - k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + i__ = j - k; +/* -> U(i,i) at A(i,j) */ + i__2 = i__ + j * lda; + temp = (d__1 = a[i__2].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__ = j - k + 1; +/* U(j,j) */ + i__2 = i__ + j * lda; + temp = (d__1 = a[i__2].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__2 = k - 1; + for (i__ = j - k + 2; i__ <= i__2; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } + } + } + } else { +/* n is even & k = n/2 */ + if (ifm == 1) { +/* A is n+1 by k */ + if (ilu == 1) { +/* uplo ='L' */ + j = 0; +/* -> L(k,k) & j=1 -> L(0,0) */ + i__1 = j + j * lda; + temp = (d__1 = a[i__1].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__1 = j + 1 + j * lda; + temp = (d__1 = a[i__1].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + i__ = j; +/* L(k+j,k+j) */ + i__2 = i__ + j * lda; + temp = (d__1 = a[i__2].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__ = j + 1; +/* -> L(j,j) */ + i__2 = i__ + j * lda; + temp = (d__1 = a[i__2].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__2 = *n; + for (i__ = j + 2; i__ <= i__2; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } + } else { +/* uplo = 'U' */ + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = k + j - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + i__ = k + j; +/* -> U(i,i) */ + i__2 = i__ + j * lda; + temp = (d__1 = a[i__2].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + ++i__; +/* =k+j+1; i -> U(j,j) */ + i__2 = i__ + j * lda; + temp = (d__1 = a[i__2].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__2 = *n; + for (i__ = k + j + 2; i__ <= i__2; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } + i__1 = *n - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } +/* j=k-1 */ + } +/* i=n-1 -> U(n-1,n-1) */ + i__1 = i__ + j * lda; + temp = (d__1 = a[i__1].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__ = *n; +/* -> U(k-1,k-1) */ + i__1 = i__ + j * lda; + temp = (d__1 = a[i__1].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } else { +/* xpose case; A is k by n+1 */ + if (ilu == 1) { +/* uplo ='L' */ + j = 0; +/* -> L(k,k) at A(0,0) */ + i__1 = j + j * lda; + temp = (d__1 = a[i__1].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__1 = k - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 2; + for (i__ = 0; i__ <= i__2; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + i__ = j - 1; +/* L(i,i) */ + i__2 = i__ + j * lda; + temp = (d__1 = a[i__2].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__ = j; +/* L(j+k,j+k) */ + i__2 = i__ + j * lda; + temp = (d__1 = a[i__2].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__2 = k - 1; + for (i__ = j + 1; i__ <= i__2; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } + j = k; + i__1 = k - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + i__ = k - 1; +/* -> L(i,i) is at A(i,j) */ + i__1 = i__ + j * lda; + temp = (d__1 = a[i__1].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } + } else { +/* uplo = 'U' */ + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } + j = k; +/* -> U(j,j) is at A(0,j) */ + i__1 = j * lda; + temp = (d__1 = a[i__1].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__1 = k - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + i__1 = *n - 1; + for (j = k + 1; j <= i__1; ++j) { + i__2 = j - k - 2; + for (i__ = 0; i__ <= i__2; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + i__ = j - k - 1; +/* -> U(i,i) at A(i,j) */ + i__2 = i__ + j * lda; + temp = (d__1 = a[i__2].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__ = j - k; +/* U(j,j) */ + i__2 = i__ + j * lda; + temp = (d__1 = a[i__2].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + i__2 = k - 1; + for (i__ = j - k + 1; i__ <= i__2; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } + j = *n; + i__1 = k - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + temp = z_abs(&a[i__ + j * lda]); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + i__ = k - 1; +/* U(k,k) at A(i,j) */ + i__1 = i__ + j * lda; + temp = (d__1 = a[i__1].r, abs(d__1)); + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } + } + } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { + +/* Find normI(A) ( = norm1(A), since A is Hermitian). */ + + if (ifm == 1) { +/* A is 'N' */ + k = *n / 2; + if (noe == 1) { +/* n is odd & A is n by (n+1)/2 */ + if (ilu == 0) { +/* uplo = 'U' */ + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + i__1 = k; + for (j = 0; j <= i__1; ++j) { + s = 0.; + i__2 = k + j - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = z_abs(&a[i__ + j * lda]); +/* -> A(i,j+k) */ + s += aa; + work[i__] += aa; + } + i__2 = i__ + j * lda; + aa = (d__1 = a[i__2].r, abs(d__1)); +/* -> A(j+k,j+k) */ + work[j + k] = s + aa; + if (i__ == k + k) { + goto L10; + } + ++i__; + i__2 = i__ + j * lda; + aa = (d__1 = a[i__2].r, abs(d__1)); +/* -> A(j,j) */ + work[j] += aa; + s = 0.; + i__2 = k - 1; + for (l = j + 1; l <= i__2; ++l) { + ++i__; + aa = z_abs(&a[i__ + j * lda]); +/* -> A(l,j) */ + s += aa; + work[l] += aa; + } + work[j] += s; + } +L10: + value = work[0]; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } else { +/* ilu = 1 & uplo = 'L' */ + ++k; +/* k=(n+1)/2 for n odd and ilu=1 */ + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + for (j = k - 1; j >= 0; --j) { + s = 0.; + i__1 = j - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + aa = z_abs(&a[i__ + j * lda]); +/* -> A(j+k,i+k) */ + s += aa; + work[i__ + k] += aa; + } + if (j > 0) { + i__1 = i__ + j * lda; + aa = (d__1 = a[i__1].r, abs(d__1)); +/* -> A(j+k,j+k) */ + s += aa; + work[i__ + k] += s; +/* i=j */ + ++i__; + } + i__1 = i__ + j * lda; + aa = (d__1 = a[i__1].r, abs(d__1)); +/* -> A(j,j) */ + work[j] = aa; + s = 0.; + i__1 = *n - 1; + for (l = j + 1; l <= i__1; ++l) { + ++i__; + aa = z_abs(&a[i__ + j * lda]); +/* -> A(l,j) */ + s += aa; + work[l] += aa; + } + work[j] += s; + } + value = work[0]; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } + } else { +/* n is even & A is n+1 by k = n/2 */ + if (ilu == 0) { +/* uplo = 'U' */ + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + s = 0.; + i__2 = k + j - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = z_abs(&a[i__ + j * lda]); +/* -> A(i,j+k) */ + s += aa; + work[i__] += aa; + } + i__2 = i__ + j * lda; + aa = (d__1 = a[i__2].r, abs(d__1)); +/* -> A(j+k,j+k) */ + work[j + k] = s + aa; + ++i__; + i__2 = i__ + j * lda; + aa = (d__1 = a[i__2].r, abs(d__1)); +/* -> A(j,j) */ + work[j] += aa; + s = 0.; + i__2 = k - 1; + for (l = j + 1; l <= i__2; ++l) { + ++i__; + aa = z_abs(&a[i__ + j * lda]); +/* -> A(l,j) */ + s += aa; + work[l] += aa; + } + work[j] += s; + } + value = work[0]; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } else { +/* ilu = 1 & uplo = 'L' */ + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + for (j = k - 1; j >= 0; --j) { + s = 0.; + i__1 = j - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + aa = z_abs(&a[i__ + j * lda]); +/* -> A(j+k,i+k) */ + s += aa; + work[i__ + k] += aa; + } + i__1 = i__ + j * lda; + aa = (d__1 = a[i__1].r, abs(d__1)); +/* -> A(j+k,j+k) */ + s += aa; + work[i__ + k] += s; +/* i=j */ + ++i__; + i__1 = i__ + j * lda; + aa = (d__1 = a[i__1].r, abs(d__1)); +/* -> A(j,j) */ + work[j] = aa; + s = 0.; + i__1 = *n - 1; + for (l = j + 1; l <= i__1; ++l) { + ++i__; + aa = z_abs(&a[i__ + j * lda]); +/* -> A(l,j) */ + s += aa; + work[l] += aa; + } + work[j] += s; + } + value = work[0]; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } + } + } else { +/* ifm=0 */ + k = *n / 2; + if (noe == 1) { +/* n is odd & A is (n+1)/2 by n */ + if (ilu == 0) { +/* uplo = 'U' */ + n1 = k; +/* n/2 */ + ++k; +/* k is the row size and lda */ + i__1 = *n - 1; + for (i__ = n1; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + s = 0.; + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = z_abs(&a[i__ + j * lda]); +/* A(j,n1+i) */ + work[i__ + n1] += aa; + s += aa; + } + work[j] = s; + } +/* j=n1=k-1 is special */ + i__1 = j * lda; + s = (d__1 = a[i__1].r, abs(d__1)); +/* A(k-1,k-1) */ + i__1 = k - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + aa = z_abs(&a[i__ + j * lda]); +/* A(k-1,i+n1) */ + work[i__ + n1] += aa; + s += aa; + } + work[j] += s; + i__1 = *n - 1; + for (j = k; j <= i__1; ++j) { + s = 0.; + i__2 = j - k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = z_abs(&a[i__ + j * lda]); +/* A(i,j-k) */ + work[i__] += aa; + s += aa; + } +/* i=j-k */ + i__2 = i__ + j * lda; + aa = (d__1 = a[i__2].r, abs(d__1)); +/* A(j-k,j-k) */ + s += aa; + work[j - k] += s; + ++i__; + i__2 = i__ + j * lda; + s = (d__1 = a[i__2].r, abs(d__1)); +/* A(j,j) */ + i__2 = *n - 1; + for (l = j + 1; l <= i__2; ++l) { + ++i__; + aa = z_abs(&a[i__ + j * lda]); +/* A(j,l) */ + work[l] += aa; + s += aa; + } + work[j] += s; + } + value = work[0]; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } else { +/* ilu=1 & uplo = 'L' */ + ++k; +/* k=(n+1)/2 for n odd and ilu=1 */ + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { +/* process */ + s = 0.; + i__2 = j - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = z_abs(&a[i__ + j * lda]); +/* A(j,i) */ + work[i__] += aa; + s += aa; + } + i__2 = i__ + j * lda; + aa = (d__1 = a[i__2].r, abs(d__1)); +/* i=j so process of A(j,j) */ + s += aa; + work[j] = s; +/* is initialised here */ + ++i__; +/* i=j process A(j+k,j+k) */ + i__2 = i__ + j * lda; + aa = (d__1 = a[i__2].r, abs(d__1)); + s = aa; + i__2 = *n - 1; + for (l = k + j + 1; l <= i__2; ++l) { + ++i__; + aa = z_abs(&a[i__ + j * lda]); +/* A(l,k+j) */ + s += aa; + work[l] += aa; + } + work[k + j] += s; + } +/* j=k-1 is special :process col A(k-1,0:k-1) */ + s = 0.; + i__1 = k - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + aa = z_abs(&a[i__ + j * lda]); +/* A(k,i) */ + work[i__] += aa; + s += aa; + } +/* i=k-1 */ + i__1 = i__ + j * lda; + aa = (d__1 = a[i__1].r, abs(d__1)); +/* A(k-1,k-1) */ + s += aa; + work[i__] = s; +/* done with col j=k+1 */ + i__1 = *n - 1; + for (j = k; j <= i__1; ++j) { +/* process col j of A = A(j,0:k-1) */ + s = 0.; + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = z_abs(&a[i__ + j * lda]); +/* A(j,i) */ + work[i__] += aa; + s += aa; + } + work[j] += s; + } + value = work[0]; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } + } else { +/* n is even & A is k=n/2 by n+1 */ + if (ilu == 0) { +/* uplo = 'U' */ + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + s = 0.; + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = z_abs(&a[i__ + j * lda]); +/* A(j,i+k) */ + work[i__ + k] += aa; + s += aa; + } + work[j] = s; + } +/* j=k */ + i__1 = j * lda; + aa = (d__1 = a[i__1].r, abs(d__1)); +/* A(k,k) */ + s = aa; + i__1 = k - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + aa = z_abs(&a[i__ + j * lda]); +/* A(k,k+i) */ + work[i__ + k] += aa; + s += aa; + } + work[j] += s; + i__1 = *n - 1; + for (j = k + 1; j <= i__1; ++j) { + s = 0.; + i__2 = j - 2 - k; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = z_abs(&a[i__ + j * lda]); +/* A(i,j-k-1) */ + work[i__] += aa; + s += aa; + } +/* i=j-1-k */ + i__2 = i__ + j * lda; + aa = (d__1 = a[i__2].r, abs(d__1)); +/* A(j-k-1,j-k-1) */ + s += aa; + work[j - k - 1] += s; + ++i__; + i__2 = i__ + j * lda; + aa = (d__1 = a[i__2].r, abs(d__1)); +/* A(j,j) */ + s = aa; + i__2 = *n - 1; + for (l = j + 1; l <= i__2; ++l) { + ++i__; + aa = z_abs(&a[i__ + j * lda]); +/* A(j,l) */ + work[l] += aa; + s += aa; + } + work[j] += s; + } +/* j=n */ + s = 0.; + i__1 = k - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + aa = z_abs(&a[i__ + j * lda]); +/* A(i,k-1) */ + work[i__] += aa; + s += aa; + } +/* i=k-1 */ + i__1 = i__ + j * lda; + aa = (d__1 = a[i__1].r, abs(d__1)); +/* A(k-1,k-1) */ + s += aa; + work[i__] += s; + value = work[0]; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } else { +/* ilu=1 & uplo = 'L' */ + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + work[i__] = 0.; + } +/* j=0 is special :process col A(k:n-1,k) */ + s = (d__1 = a[0].r, abs(d__1)); +/* A(k,k) */ + i__1 = k - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + aa = z_abs(&a[i__]); +/* A(k+i,k) */ + work[i__ + k] += aa; + s += aa; + } + work[k] += s; + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { +/* process */ + s = 0.; + i__2 = j - 2; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = z_abs(&a[i__ + j * lda]); +/* A(j-1,i) */ + work[i__] += aa; + s += aa; + } + i__2 = i__ + j * lda; + aa = (d__1 = a[i__2].r, abs(d__1)); +/* i=j-1 so process of A(j-1,j-1) */ + s += aa; + work[j - 1] = s; +/* is initialised here */ + ++i__; +/* i=j process A(j+k,j+k) */ + i__2 = i__ + j * lda; + aa = (d__1 = a[i__2].r, abs(d__1)); + s = aa; + i__2 = *n - 1; + for (l = k + j + 1; l <= i__2; ++l) { + ++i__; + aa = z_abs(&a[i__ + j * lda]); +/* A(l,k+j) */ + s += aa; + work[l] += aa; + } + work[k + j] += s; + } +/* j=k is special :process col A(k,0:k-1) */ + s = 0.; + i__1 = k - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + aa = z_abs(&a[i__ + j * lda]); +/* A(k,i) */ + work[i__] += aa; + s += aa; + } + +/* i=k-1 */ + i__1 = i__ + j * lda; + aa = (d__1 = a[i__1].r, abs(d__1)); +/* A(k-1,k-1) */ + s += aa; + work[i__] = s; +/* done with col j=k+1 */ + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + +/* process col j-1 of A = A(j-1,0:k-1) */ + s = 0.; + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + aa = z_abs(&a[i__ + j * lda]); +/* A(j-1,i) */ + work[i__] += aa; + s += aa; + } + work[j - 1] += s; + } + value = work[0]; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = work[i__]; + if (value < temp || disnan_(&temp)) { + value = temp; + } + } + } + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ + + k = (*n + 1) / 2; + scale = 0.; + s = 1.; + if (noe == 1) { +/* n is odd */ + if (ifm == 1) { +/* A is normal & A is n by k */ + if (ilu == 0) { +/* A is upper */ + i__1 = k - 3; + for (j = 0; j <= i__1; ++j) { + i__2 = k - j - 2; + zlassq_(&i__2, &a[k + j + 1 + j * lda], &c__1, &scale, + &s); +/* L at A(k,0) */ + } + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = k + j - 1; + zlassq_(&i__2, &a[j * lda], &c__1, &scale, &s); +/* trap U at A(0,0) */ + } + s += s; +/* double s for the off diagonal elements */ + l = k - 1; +/* -> U(k,k) at A(k-1,0) */ + i__1 = k - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = l; + aa = a[i__2].r; +/* U(k+i,k+i) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + i__2 = l + 1; + aa = a[i__2].r; +/* U(i,i) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + l = l + lda + 1; + } + i__1 = l; + aa = a[i__1].r; +/* U(n-1,n-1) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + } else { +/* ilu=1 & A is lower */ + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - j - 1; + zlassq_(&i__2, &a[j + 1 + j * lda], &c__1, &scale, &s) + ; +/* trap L at A(0,0) */ + } + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + zlassq_(&j, &a[(j + 1) * lda], &c__1, &scale, &s); +/* U at A(0,1) */ + } + s += s; +/* double s for the off diagonal elements */ + aa = a[0].r; +/* L(0,0) at A(0,0) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + l = lda; +/* -> L(k,k) at A(0,1) */ + i__1 = k - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = l; + aa = a[i__2].r; +/* L(k-1+i,k-1+i) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + i__2 = l + 1; + aa = a[i__2].r; +/* L(i,i) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + l = l + lda + 1; + } + } + } else { +/* A is xpose & A is k by n */ + if (ilu == 0) { +/* A**H is upper */ + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + zlassq_(&j, &a[(k + j) * lda], &c__1, &scale, &s); +/* U at A(0,k) */ + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + zlassq_(&k, &a[j * lda], &c__1, &scale, &s); +/* k by k-1 rect. at A(0,0) */ + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = k - j - 1; + zlassq_(&i__2, &a[j + 1 + (j + k - 1) * lda], &c__1, & + scale, &s); +/* L at A(0,k-1) */ + } + s += s; +/* double s for the off diagonal elements */ + l = k * lda - lda; +/* -> U(k-1,k-1) at A(0,k-1) */ + i__1 = l; + aa = a[i__1].r; +/* U(k-1,k-1) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + l += lda; +/* -> U(0,0) at A(0,k) */ + i__1 = *n - 1; + for (j = k; j <= i__1; ++j) { + i__2 = l; + aa = a[i__2].r; +/* -> U(j-k,j-k) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + i__2 = l + 1; + aa = a[i__2].r; +/* -> U(j,j) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + l = l + lda + 1; + } + } else { +/* A**H is lower */ + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + zlassq_(&j, &a[j * lda], &c__1, &scale, &s); +/* U at A(0,0) */ + } + i__1 = *n - 1; + for (j = k; j <= i__1; ++j) { + zlassq_(&k, &a[j * lda], &c__1, &scale, &s); +/* k by k-1 rect. at A(0,k) */ + } + i__1 = k - 3; + for (j = 0; j <= i__1; ++j) { + i__2 = k - j - 2; + zlassq_(&i__2, &a[j + 2 + j * lda], &c__1, &scale, &s) + ; +/* L at A(1,0) */ + } + s += s; +/* double s for the off diagonal elements */ + l = 0; +/* -> L(0,0) at A(0,0) */ + i__1 = k - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = l; + aa = a[i__2].r; +/* L(i,i) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + i__2 = l + 1; + aa = a[i__2].r; +/* L(k+i,k+i) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + l = l + lda + 1; + } +/* L-> k-1 + (k-1)*lda or L(k-1,k-1) at A(k-1,k-1) */ + i__1 = l; + aa = a[i__1].r; +/* L(k-1,k-1) at A(k-1,k-1) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + } + } + } else { +/* n is even */ + if (ifm == 1) { +/* A is normal */ + if (ilu == 0) { +/* A is upper */ + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = k - j - 1; + zlassq_(&i__2, &a[k + j + 2 + j * lda], &c__1, &scale, + &s); +/* L at A(k+1,0) */ + } + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = k + j; + zlassq_(&i__2, &a[j * lda], &c__1, &scale, &s); +/* trap U at A(0,0) */ + } + s += s; +/* double s for the off diagonal elements */ + l = k; +/* -> U(k,k) at A(k,0) */ + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = l; + aa = a[i__2].r; +/* U(k+i,k+i) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + i__2 = l + 1; + aa = a[i__2].r; +/* U(i,i) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + l = l + lda + 1; + } + } else { +/* ilu=1 & A is lower */ + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - j - 1; + zlassq_(&i__2, &a[j + 2 + j * lda], &c__1, &scale, &s) + ; +/* trap L at A(1,0) */ + } + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + zlassq_(&j, &a[j * lda], &c__1, &scale, &s); +/* U at A(0,0) */ + } + s += s; +/* double s for the off diagonal elements */ + l = 0; +/* -> L(k,k) at A(0,0) */ + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = l; + aa = a[i__2].r; +/* L(k-1+i,k-1+i) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + i__2 = l + 1; + aa = a[i__2].r; +/* L(i,i) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + l = l + lda + 1; + } + } + } else { +/* A is xpose */ + if (ilu == 0) { +/* A**H is upper */ + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + zlassq_(&j, &a[(k + 1 + j) * lda], &c__1, &scale, &s); +/* U at A(0,k+1) */ + } + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + zlassq_(&k, &a[j * lda], &c__1, &scale, &s); +/* k by k rect. at A(0,0) */ + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = k - j - 1; + zlassq_(&i__2, &a[j + 1 + (j + k) * lda], &c__1, & + scale, &s); +/* L at A(0,k) */ + } + s += s; +/* double s for the off diagonal elements */ + l = k * lda; +/* -> U(k,k) at A(0,k) */ + i__1 = l; + aa = a[i__1].r; +/* U(k,k) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + l += lda; +/* -> U(0,0) at A(0,k+1) */ + i__1 = *n - 1; + for (j = k + 1; j <= i__1; ++j) { + i__2 = l; + aa = a[i__2].r; +/* -> U(j-k-1,j-k-1) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + i__2 = l + 1; + aa = a[i__2].r; +/* -> U(j,j) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + l = l + lda + 1; + } +/* L=k-1+n*lda */ +/* -> U(k-1,k-1) at A(k-1,n) */ + i__1 = l; + aa = a[i__1].r; +/* U(k,k) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + } else { +/* A**H is lower */ + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + zlassq_(&j, &a[(j + 1) * lda], &c__1, &scale, &s); +/* U at A(0,1) */ + } + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + zlassq_(&k, &a[j * lda], &c__1, &scale, &s); +/* k by k rect. at A(0,k+1) */ + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = k - j - 1; + zlassq_(&i__2, &a[j + 1 + j * lda], &c__1, &scale, &s) + ; +/* L at A(0,0) */ + } + s += s; +/* double s for the off diagonal elements */ + l = 0; +/* -> L(k,k) at A(0,0) */ + i__1 = l; + aa = a[i__1].r; +/* L(k,k) at A(0,0) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + l = lda; +/* -> L(0,0) at A(0,1) */ + i__1 = k - 2; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = l; + aa = a[i__2].r; +/* L(i,i) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + i__2 = l + 1; + aa = a[i__2].r; +/* L(k+i+1,k+i+1) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + l = l + lda + 1; + } +/* L-> k - 1 + k*lda or L(k-1,k-1) at A(k-1,k) */ + i__1 = l; + aa = a[i__1].r; +/* L(k-1,k-1) at A(k-1,k) */ + if (aa != 0.) { + if (scale < aa) { +/* Computing 2nd power */ + d__1 = scale / aa; + s = s * (d__1 * d__1) + 1.; + scale = aa; + } else { +/* Computing 2nd power */ + d__1 = aa / scale; + s += d__1 * d__1; + } + } + } + } + } + value = scale * sqrt(s); + } + + ret_val = value; + return ret_val; + +/* End of ZLANHF */ + +} /* zlanhf_ */ + diff --git a/lapack-netlib/SRC/zlanhp.c b/lapack-netlib/SRC/zlanhp.c new file mode 100644 index 000000000..7d4a6caf1 --- /dev/null +++ b/lapack-netlib/SRC/zlanhp.c @@ -0,0 +1,725 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLANHP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the ele +ment of largest absolute value of a complex Hermitian matrix supplied in packed form. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLANHP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLANHP( NORM, UPLO, N, AP, WORK ) */ + +/* CHARACTER NORM, UPLO */ +/* INTEGER N */ +/* DOUBLE PRECISION WORK( * ) */ +/* COMPLEX*16 AP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLANHP returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of a */ +/* > complex hermitian matrix A, supplied in packed form. */ +/* > \endverbatim */ +/* > */ +/* > \return ZLANHP */ +/* > \verbatim */ +/* > */ +/* > ZLANHP = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in ZLANHP as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > hermitian matrix A is supplied. */ +/* > = 'U': Upper triangular part of A is supplied */ +/* > = 'L': Lower triangular part of A is supplied */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, ZLANHP is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > The upper or lower triangle of the hermitian 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. */ +/* > Note that the imaginary parts of the diagonal elements need */ +/* > not be set and are assumed to be zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ +/* > where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */ +/* > WORK is not referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +doublereal zlanhp_(char *norm, char *uplo, integer *n, doublecomplex *ap, + doublereal *work) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal ret_val, d__1; + + /* Local variables */ + doublereal absa; + extern /* Subroutine */ int dcombssq_(doublereal *, doublereal *); + integer i__, j, k; + extern logical lsame_(char *, char *); + doublereal value; + extern logical disnan_(doublereal *); + doublereal colssq[2]; + extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *, + doublereal *, doublereal *); + doublereal sum, ssq[2]; + + +/* -- 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 */ + --work; + --ap; + + /* Function Body */ + if (*n == 0) { + value = 0.; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + value = 0.; + if (lsame_(uplo, "U")) { + k = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k + j - 1; + for (i__ = k + 1; i__ <= i__2; ++i__) { + sum = z_abs(&ap[i__]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L10: */ + } + k += j; + i__2 = k; + sum = (d__1 = ap[i__2].r, abs(d__1)); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L20: */ + } + } else { + k = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k; + sum = (d__1 = ap[i__2].r, abs(d__1)); + if (value < sum || disnan_(&sum)) { + value = sum; + } + i__2 = k + *n - j; + for (i__ = k + 1; i__ <= i__2; ++i__) { + sum = z_abs(&ap[i__]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L30: */ + } + k = k + *n - j + 1; +/* L40: */ + } + } + } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { + +/* Find normI(A) ( = norm1(A), since A is hermitian). */ + + value = 0.; + k = 1; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + absa = z_abs(&ap[k]); + sum += absa; + work[i__] += absa; + ++k; +/* L50: */ + } + i__2 = k; + work[j] = sum + (d__1 = ap[i__2].r, abs(d__1)); + ++k; +/* L60: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L70: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L80: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k; + sum = work[j] + (d__1 = ap[i__2].r, abs(d__1)); + ++k; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + absa = z_abs(&ap[k]); + sum += absa; + work[i__] += absa; + ++k; +/* L90: */ + } + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L100: */ + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ +/* SSQ(1) is scale */ +/* SSQ(2) is sum-of-squares */ +/* For better accuracy, sum each column separately. */ + + ssq[0] = 0.; + ssq[1] = 1.; + +/* Sum off-diagonals */ + + k = 2; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; + i__2 = j - 1; + zlassq_(&i__2, &ap[k], &c__1, colssq, &colssq[1]); + dcombssq_(ssq, colssq); + k += j; +/* L110: */ + } + } else { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; + i__2 = *n - j; + zlassq_(&i__2, &ap[k], &c__1, colssq, &colssq[1]); + dcombssq_(ssq, colssq); + k = k + *n - j + 1; +/* L120: */ + } + } + ssq[1] *= 2; + +/* Sum diagonal */ + + k = 1; + colssq[0] = 0.; + colssq[1] = 1.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = k; + if (ap[i__2].r != 0.) { + i__2 = k; + absa = (d__1 = ap[i__2].r, abs(d__1)); + if (colssq[0] < absa) { +/* Computing 2nd power */ + d__1 = colssq[0] / absa; + colssq[1] = colssq[1] * (d__1 * d__1) + 1.; + colssq[0] = absa; + } else { +/* Computing 2nd power */ + d__1 = absa / colssq[0]; + colssq[1] += d__1 * d__1; + } + } + if (lsame_(uplo, "U")) { + k = k + i__ + 1; + } else { + k = k + *n - i__ + 1; + } +/* L130: */ + } + dcombssq_(ssq, colssq); + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of ZLANHP */ + +} /* zlanhp_ */ + diff --git a/lapack-netlib/SRC/zlanhs.c b/lapack-netlib/SRC/zlanhs.c new file mode 100644 index 000000000..9ef045484 --- /dev/null +++ b/lapack-netlib/SRC/zlanhs.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 +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLANHS returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute +value of any element of an upper Hessenberg matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLANHS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLANHS( NORM, N, A, LDA, WORK ) */ + +/* CHARACTER NORM */ +/* INTEGER LDA, N */ +/* DOUBLE PRECISION WORK( * ) */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLANHS returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of a */ +/* > Hessenberg matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \return ZLANHS */ +/* > \verbatim */ +/* > */ +/* > ZLANHS = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in ZLANHS as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, ZLANHS is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > The n by n upper Hessenberg matrix A; the part of A below the */ +/* > first sub-diagonal is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(N,1). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ +/* > where LWORK >= N when NORM = 'I'; otherwise, WORK is not */ +/* > referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +doublereal zlanhs_(char *norm, integer *n, doublecomplex *a, integer *lda, + doublereal *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + doublereal ret_val; + + /* Local variables */ + extern /* Subroutine */ int dcombssq_(doublereal *, doublereal *); + integer i__, j; + extern logical lsame_(char *, char *); + doublereal value; + extern logical disnan_(doublereal *); + doublereal colssq[2]; + extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *, + doublereal *, doublereal *); + doublereal sum, ssq[2]; + + +/* -- 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; + --work; + + /* Function Body */ + if (*n == 0) { + value = 0.; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + value = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = *n, i__4 = j + 1; + i__2 = f2cmin(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + sum = z_abs(&a[i__ + j * a_dim1]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L10: */ + } +/* L20: */ + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + value = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; +/* Computing MIN */ + i__3 = *n, i__4 = j + 1; + i__2 = f2cmin(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + sum += z_abs(&a[i__ + j * a_dim1]); +/* L30: */ + } + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L40: */ + } + } else if (lsame_(norm, "I")) { + +/* Find normI(A). */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L50: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = *n, i__4 = j + 1; + i__2 = f2cmin(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] += z_abs(&a[i__ + j * a_dim1]); +/* L60: */ + } +/* L70: */ + } + value = 0.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L80: */ + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ +/* SSQ(1) is scale */ +/* SSQ(2) is sum-of-squares */ +/* For better accuracy, sum each column separately. */ + + ssq[0] = 0.; + ssq[1] = 1.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; +/* Computing MIN */ + i__3 = *n, i__4 = j + 1; + i__2 = f2cmin(i__3,i__4); + zlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, colssq, &colssq[1]); + dcombssq_(ssq, colssq); +/* L90: */ + } + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of ZLANHS */ + +} /* zlanhs_ */ + diff --git a/lapack-netlib/SRC/zlanht.c b/lapack-netlib/SRC/zlanht.c new file mode 100644 index 000000000..97a4a5d82 --- /dev/null +++ b/lapack-netlib/SRC/zlanht.c @@ -0,0 +1,589 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLANHT returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the ele +ment of largest absolute value of a complex Hermitian tridiagonal matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLANHT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLANHT( NORM, N, D, E ) */ + +/* CHARACTER NORM */ +/* INTEGER N */ +/* DOUBLE PRECISION D( * ) */ +/* COMPLEX*16 E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLANHT returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of a */ +/* > complex Hermitian tridiagonal matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \return ZLANHT */ +/* > \verbatim */ +/* > */ +/* > ZLANHT = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in ZLANHT as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, ZLANHT is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The diagonal elements of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is COMPLEX*16 array, dimension (N-1) */ +/* > The (n-1) sub-diagonal or super-diagonal elements of A. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +doublereal zlanht_(char *norm, integer *n, doublereal *d__, doublecomplex *e) +{ + /* System generated locals */ + integer i__1; + doublereal ret_val, d__1; + + /* Local variables */ + integer i__; + doublereal scale; + extern logical lsame_(char *, char *); + doublereal anorm; + extern logical disnan_(doublereal *); + extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, + doublereal *, doublereal *), zlassq_(integer *, doublecomplex *, + integer *, doublereal *, doublereal *); + doublereal sum; + + +/* -- 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 */ + --e; + --d__; + + /* Function Body */ + if (*n <= 0) { + anorm = 0.; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + anorm = (d__1 = d__[*n], abs(d__1)); + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = (d__1 = d__[i__], abs(d__1)); + if (anorm < sum || disnan_(&sum)) { + anorm = sum; + } + sum = z_abs(&e[i__]); + if (anorm < sum || disnan_(&sum)) { + anorm = sum; + } +/* L10: */ + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1' || lsame_(norm, "I")) { + +/* Find norm1(A). */ + + if (*n == 1) { + anorm = abs(d__[1]); + } else { + anorm = abs(d__[1]) + z_abs(&e[1]); + sum = z_abs(&e[*n - 1]) + (d__1 = d__[*n], abs(d__1)); + if (anorm < sum || disnan_(&sum)) { + anorm = sum; + } + i__1 = *n - 1; + for (i__ = 2; i__ <= i__1; ++i__) { + sum = (d__1 = d__[i__], abs(d__1)) + z_abs(&e[i__]) + z_abs(& + e[i__ - 1]); + if (anorm < sum || disnan_(&sum)) { + anorm = sum; + } +/* L20: */ + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ + + scale = 0.; + sum = 1.; + if (*n > 1) { + i__1 = *n - 1; + zlassq_(&i__1, &e[1], &c__1, &scale, &sum); + sum *= 2; + } + dlassq_(n, &d__[1], &c__1, &scale, &sum); + anorm = scale * sqrt(sum); + } + + ret_val = anorm; + return ret_val; + +/* End of ZLANHT */ + +} /* zlanht_ */ + diff --git a/lapack-netlib/SRC/zlansb.c b/lapack-netlib/SRC/zlansb.c new file mode 100644 index 000000000..686ffeae7 --- /dev/null +++ b/lapack-netlib/SRC/zlansb.c @@ -0,0 +1,715 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLANSB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the ele +ment of largest absolute value of a symmetric band matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLANSB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLANSB( NORM, UPLO, N, K, AB, LDAB, */ +/* WORK ) */ + +/* CHARACTER NORM, UPLO */ +/* INTEGER K, LDAB, N */ +/* DOUBLE PRECISION WORK( * ) */ +/* COMPLEX*16 AB( LDAB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLANSB returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of an */ +/* > n by n symmetric band matrix A, with k super-diagonals. */ +/* > \endverbatim */ +/* > */ +/* > \return ZLANSB */ +/* > \verbatim */ +/* > */ +/* > ZLANSB = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in ZLANSB as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > band matrix A is supplied. */ +/* > = 'U': Upper triangular part is supplied */ +/* > = 'L': Lower triangular part is supplied */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, ZLANSB is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of super-diagonals or sub-diagonals of the */ +/* > band matrix A. K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is COMPLEX*16 array, dimension (LDAB,N) */ +/* > The upper or lower triangle of the symmetric band matrix A, */ +/* > stored in the first K+1 rows of AB. The j-th column of A is */ +/* > stored in the j-th column of the array AB as follows: */ +/* > if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for f2cmax(1,j-k)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+k). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= K+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ +/* > where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */ +/* > WORK is not referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +doublereal zlansb_(char *norm, char *uplo, integer *n, integer *k, + doublecomplex *ab, integer *ldab, doublereal *work) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; + doublereal ret_val; + + /* Local variables */ + doublereal absa; + extern /* Subroutine */ int dcombssq_(doublereal *, doublereal *); + integer i__, j, l; + extern logical lsame_(char *, char *); + doublereal value; + extern logical disnan_(doublereal *); + doublereal colssq[2]; + extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *, + doublereal *, doublereal *); + doublereal sum, ssq[2]; + + +/* -- 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 */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --work; + + /* Function Body */ + if (*n == 0) { + value = 0.; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + value = 0.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = *k + 2 - j; + i__3 = *k + 1; + for (i__ = f2cmax(i__2,1); i__ <= i__3; ++i__) { + sum = z_abs(&ab[i__ + j * ab_dim1]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = *n + 1 - j, i__4 = *k + 1; + i__3 = f2cmin(i__2,i__4); + for (i__ = 1; i__ <= i__3; ++i__) { + sum = z_abs(&ab[i__ + j * ab_dim1]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L30: */ + } +/* L40: */ + } + } + } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { + +/* Find normI(A) ( = norm1(A), since A is symmetric). */ + + value = 0.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + l = *k + 1 - j; +/* Computing MAX */ + i__3 = 1, i__2 = j - *k; + i__4 = j - 1; + for (i__ = f2cmax(i__3,i__2); i__ <= i__4; ++i__) { + absa = z_abs(&ab[l + i__ + j * ab_dim1]); + sum += absa; + work[i__] += absa; +/* L50: */ + } + work[j] = sum + z_abs(&ab[*k + 1 + j * ab_dim1]); +/* L60: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L70: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L80: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = work[j] + z_abs(&ab[j * ab_dim1 + 1]); + l = 1 - j; +/* Computing MIN */ + i__3 = *n, i__2 = j + *k; + i__4 = f2cmin(i__3,i__2); + for (i__ = j + 1; i__ <= i__4; ++i__) { + absa = z_abs(&ab[l + i__ + j * ab_dim1]); + sum += absa; + work[i__] += absa; +/* L90: */ + } + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L100: */ + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ +/* SSQ(1) is scale */ +/* SSQ(2) is sum-of-squares */ +/* For better accuracy, sum each column separately. */ + + ssq[0] = 0.; + ssq[1] = 1.; + +/* Sum off-diagonals */ + + if (*k > 0) { + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; +/* Computing MIN */ + i__3 = j - 1; + i__4 = f2cmin(i__3,*k); +/* Computing MAX */ + i__2 = *k + 2 - j; + zlassq_(&i__4, &ab[f2cmax(i__2,1) + j * ab_dim1], &c__1, + colssq, &colssq[1]); + dcombssq_(ssq, colssq); +/* L110: */ + } + l = *k + 1; + } else { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; +/* Computing MIN */ + i__3 = *n - j; + i__4 = f2cmin(i__3,*k); + zlassq_(&i__4, &ab[j * ab_dim1 + 2], &c__1, colssq, & + colssq[1]); + dcombssq_(ssq, colssq); +/* L120: */ + } + l = 1; + } + ssq[1] *= 2; + } else { + l = 1; + } + +/* Sum diagonal */ + + colssq[0] = 0.; + colssq[1] = 1.; + zlassq_(n, &ab[l + ab_dim1], ldab, colssq, &colssq[1]); + dcombssq_(ssq, colssq); + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of ZLANSB */ + +} /* zlansb_ */ + diff --git a/lapack-netlib/SRC/zlansp.c b/lapack-netlib/SRC/zlansp.c new file mode 100644 index 000000000..4a767b7b2 --- /dev/null +++ b/lapack-netlib/SRC/zlansp.c @@ -0,0 +1,724 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLANSP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the ele +ment of largest absolute value of a symmetric matrix supplied in packed form. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLANSP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLANSP( NORM, UPLO, N, AP, WORK ) */ + +/* CHARACTER NORM, UPLO */ +/* INTEGER N */ +/* DOUBLE PRECISION WORK( * ) */ +/* COMPLEX*16 AP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLANSP returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of a */ +/* > complex symmetric matrix A, supplied in packed form. */ +/* > \endverbatim */ +/* > */ +/* > \return ZLANSP */ +/* > \verbatim */ +/* > */ +/* > ZLANSP = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in ZLANSP as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is supplied. */ +/* > = 'U': Upper triangular part of A is supplied */ +/* > = 'L': Lower triangular part of A is supplied */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, ZLANSP is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is COMPLEX*16 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)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ +/* > where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */ +/* > WORK is not referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +doublereal zlansp_(char *norm, char *uplo, integer *n, doublecomplex *ap, + doublereal *work) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal ret_val, d__1; + + /* Local variables */ + doublereal absa; + extern /* Subroutine */ int dcombssq_(doublereal *, doublereal *); + integer i__, j, k; + extern logical lsame_(char *, char *); + doublereal value; + extern logical disnan_(doublereal *); + doublereal colssq[2]; + extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *, + doublereal *, doublereal *); + doublereal sum, ssq[2]; + + +/* -- 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 */ + --work; + --ap; + + /* Function Body */ + if (*n == 0) { + value = 0.; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + value = 0.; + if (lsame_(uplo, "U")) { + k = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k + j - 1; + for (i__ = k; i__ <= i__2; ++i__) { + sum = z_abs(&ap[i__]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L10: */ + } + k += j; +/* L20: */ + } + } else { + k = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k + *n - j; + for (i__ = k; i__ <= i__2; ++i__) { + sum = z_abs(&ap[i__]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L30: */ + } + k = k + *n - j + 1; +/* L40: */ + } + } + } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { + +/* Find normI(A) ( = norm1(A), since A is symmetric). */ + + value = 0.; + k = 1; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + absa = z_abs(&ap[k]); + sum += absa; + work[i__] += absa; + ++k; +/* L50: */ + } + work[j] = sum + z_abs(&ap[k]); + ++k; +/* L60: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L70: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L80: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = work[j] + z_abs(&ap[k]); + ++k; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + absa = z_abs(&ap[k]); + sum += absa; + work[i__] += absa; + ++k; +/* L90: */ + } + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L100: */ + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ +/* SSQ(1) is scale */ +/* SSQ(2) is sum-of-squares */ +/* For better accuracy, sum each column separately. */ + + ssq[0] = 0.; + ssq[1] = 1.; + +/* Sum off-diagonals */ + + k = 2; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; + i__2 = j - 1; + zlassq_(&i__2, &ap[k], &c__1, colssq, &colssq[1]); + dcombssq_(ssq, colssq); + k += j; +/* L110: */ + } + } else { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; + i__2 = *n - j; + zlassq_(&i__2, &ap[k], &c__1, colssq, &colssq[1]); + dcombssq_(ssq, colssq); + k = k + *n - j + 1; +/* L120: */ + } + } + ssq[1] *= 2; + +/* Sum diagonal */ + + k = 1; + colssq[0] = 0.; + colssq[1] = 1.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = k; + if (ap[i__2].r != 0.) { + i__2 = k; + absa = (d__1 = ap[i__2].r, abs(d__1)); + if (colssq[0] < absa) { +/* Computing 2nd power */ + d__1 = colssq[0] / absa; + colssq[1] = colssq[1] * (d__1 * d__1) + 1.; + colssq[0] = absa; + } else { +/* Computing 2nd power */ + d__1 = absa / colssq[0]; + colssq[1] += d__1 * d__1; + } + } + if (d_imag(&ap[k]) != 0.) { + absa = (d__1 = d_imag(&ap[k]), abs(d__1)); + if (colssq[0] < absa) { +/* Computing 2nd power */ + d__1 = colssq[0] / absa; + colssq[1] = colssq[1] * (d__1 * d__1) + 1.; + colssq[0] = absa; + } else { +/* Computing 2nd power */ + d__1 = absa / colssq[0]; + colssq[1] += d__1 * d__1; + } + } + if (lsame_(uplo, "U")) { + k = k + i__ + 1; + } else { + k = k + *n - i__ + 1; + } +/* L130: */ + } + dcombssq_(ssq, colssq); + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of ZLANSP */ + +} /* zlansp_ */ + diff --git a/lapack-netlib/SRC/zlansy.c b/lapack-netlib/SRC/zlansy.c new file mode 100644 index 000000000..2065148ae --- /dev/null +++ b/lapack-netlib/SRC/zlansy.c @@ -0,0 +1,687 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the ele +ment of largest absolute value of a complex symmetric matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLANSY + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLANSY( NORM, UPLO, N, A, LDA, WORK ) */ + +/* CHARACTER NORM, UPLO */ +/* INTEGER LDA, N */ +/* DOUBLE PRECISION WORK( * ) */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLANSY returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of a */ +/* > complex symmetric matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \return ZLANSY */ +/* > \verbatim */ +/* > */ +/* > ZLANSY = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in ZLANSY as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is to be referenced. */ +/* > = 'U': Upper triangular part of A is referenced */ +/* > = 'L': Lower triangular part of A is referenced */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, ZLANSY is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 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(N,1). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ +/* > where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise, */ +/* > WORK is not referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16SYauxiliary */ + +/* ===================================================================== */ +doublereal zlansy_(char *norm, char *uplo, integer *n, doublecomplex *a, + integer *lda, doublereal *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublereal ret_val; + + /* Local variables */ + doublereal absa; + extern /* Subroutine */ int dcombssq_(doublereal *, doublereal *); + integer i__, j; + extern logical lsame_(char *, char *); + doublereal value; + extern logical disnan_(doublereal *); + doublereal colssq[2]; + extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *, + doublereal *, doublereal *); + doublereal sum, ssq[2]; + + +/* -- 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; + --work; + + /* Function Body */ + if (*n == 0) { + value = 0.; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + value = 0.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + sum = z_abs(&a[i__ + j * a_dim1]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + sum = z_abs(&a[i__ + j * a_dim1]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L30: */ + } +/* L40: */ + } + } + } else if (lsame_(norm, "I") || lsame_(norm, "O") || *(unsigned char *)norm == '1') { + +/* Find normI(A) ( = norm1(A), since A is symmetric). */ + + value = 0.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = 0.; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + absa = z_abs(&a[i__ + j * a_dim1]); + sum += absa; + work[i__] += absa; +/* L50: */ + } + work[j] = sum + z_abs(&a[j + j * a_dim1]); +/* L60: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L70: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L80: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = work[j] + z_abs(&a[j + j * a_dim1]); + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + absa = z_abs(&a[i__ + j * a_dim1]); + sum += absa; + work[i__] += absa; +/* L90: */ + } + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L100: */ + } + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ +/* SSQ(1) is scale */ +/* SSQ(2) is sum-of-squares */ +/* For better accuracy, sum each column separately. */ + + ssq[0] = 0.; + ssq[1] = 1.; + +/* Sum off-diagonals */ + + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; + i__2 = j - 1; + zlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, colssq, &colssq[1]); + dcombssq_(ssq, colssq); +/* L110: */ + } + } else { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; + i__2 = *n - j; + zlassq_(&i__2, &a[j + 1 + j * a_dim1], &c__1, colssq, &colssq[ + 1]); + dcombssq_(ssq, colssq); +/* L120: */ + } + } + ssq[1] *= 2; + +/* Sum diagonal */ + + colssq[0] = 0.; + colssq[1] = 1.; + i__1 = *lda + 1; + zlassq_(n, &a[a_offset], &i__1, colssq, &colssq[1]); + dcombssq_(ssq, colssq); + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of ZLANSY */ + +} /* zlansy_ */ + diff --git a/lapack-netlib/SRC/zlantb.c b/lapack-netlib/SRC/zlantb.c new file mode 100644 index 000000000..11fe619f9 --- /dev/null +++ b/lapack-netlib/SRC/zlantb.c @@ -0,0 +1,883 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the ele +ment of largest absolute value of a triangular band matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLANTB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLANTB( NORM, UPLO, DIAG, N, K, AB, */ +/* LDAB, WORK ) */ + +/* CHARACTER DIAG, NORM, UPLO */ +/* INTEGER K, LDAB, N */ +/* DOUBLE PRECISION WORK( * ) */ +/* COMPLEX*16 AB( LDAB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLANTB returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of an */ +/* > n by n triangular band matrix A, with ( k + 1 ) diagonals. */ +/* > \endverbatim */ +/* > */ +/* > \return ZLANTB */ +/* > \verbatim */ +/* > */ +/* > ZLANTB = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in ZLANTB as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the matrix A is upper or lower triangular. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > Specifies whether or not the matrix A is unit triangular. */ +/* > = 'N': Non-unit triangular */ +/* > = 'U': Unit triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, ZLANTB is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of super-diagonals of the matrix A if UPLO = 'U', */ +/* > or the number of sub-diagonals of the matrix A if UPLO = 'L'. */ +/* > K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is COMPLEX*16 array, dimension (LDAB,N) */ +/* > The upper or lower triangular band matrix A, stored in the */ +/* > first k+1 rows of AB. The j-th column of A is stored */ +/* > in the j-th column of the array AB as follows: */ +/* > if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for f2cmax(1,j-k)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+k). */ +/* > Note that when DIAG = 'U', the elements of the array AB */ +/* > corresponding to the diagonal elements of the matrix A are */ +/* > not referenced, but are assumed to be one. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= K+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ +/* > where LWORK >= N when NORM = 'I'; otherwise, WORK is not */ +/* > referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +doublereal zlantb_(char *norm, char *uplo, char *diag, integer *n, integer *k, + doublecomplex *ab, integer *ldab, doublereal *work) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5; + doublereal ret_val; + + /* Local variables */ + extern /* Subroutine */ int dcombssq_(doublereal *, doublereal *); + integer i__, j, l; + logical udiag; + extern logical lsame_(char *, char *); + doublereal value; + extern logical disnan_(doublereal *); + doublereal colssq[2]; + extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *, + doublereal *, doublereal *); + doublereal sum, ssq[2]; + + +/* -- 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 */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --work; + + /* Function Body */ + if (*n == 0) { + value = 0.; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + if (lsame_(diag, "U")) { + value = 1.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = *k + 2 - j; + i__3 = *k; + for (i__ = f2cmax(i__2,1); i__ <= i__3; ++i__) { + sum = z_abs(&ab[i__ + j * ab_dim1]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = *n + 1 - j, i__4 = *k + 1; + i__3 = f2cmin(i__2,i__4); + for (i__ = 2; i__ <= i__3; ++i__) { + sum = z_abs(&ab[i__ + j * ab_dim1]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L30: */ + } +/* L40: */ + } + } + } else { + value = 0.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__3 = *k + 2 - j; + i__2 = *k + 1; + for (i__ = f2cmax(i__3,1); i__ <= i__2; ++i__) { + sum = z_abs(&ab[i__ + j * ab_dim1]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = *n + 1 - j, i__4 = *k + 1; + i__2 = f2cmin(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + sum = z_abs(&ab[i__ + j * ab_dim1]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L70: */ + } +/* L80: */ + } + } + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + value = 0.; + udiag = lsame_(diag, "U"); + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (udiag) { + sum = 1.; +/* Computing MAX */ + i__2 = *k + 2 - j; + i__3 = *k; + for (i__ = f2cmax(i__2,1); i__ <= i__3; ++i__) { + sum += z_abs(&ab[i__ + j * ab_dim1]); +/* L90: */ + } + } else { + sum = 0.; +/* Computing MAX */ + i__3 = *k + 2 - j; + i__2 = *k + 1; + for (i__ = f2cmax(i__3,1); i__ <= i__2; ++i__) { + sum += z_abs(&ab[i__ + j * ab_dim1]); +/* L100: */ + } + } + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L110: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (udiag) { + sum = 1.; +/* Computing MIN */ + i__3 = *n + 1 - j, i__4 = *k + 1; + i__2 = f2cmin(i__3,i__4); + for (i__ = 2; i__ <= i__2; ++i__) { + sum += z_abs(&ab[i__ + j * ab_dim1]); +/* L120: */ + } + } else { + sum = 0.; +/* Computing MIN */ + i__3 = *n + 1 - j, i__4 = *k + 1; + i__2 = f2cmin(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + sum += z_abs(&ab[i__ + j * ab_dim1]); +/* L130: */ + } + } + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L140: */ + } + } + } else if (lsame_(norm, "I")) { + +/* Find normI(A). */ + + value = 0.; + if (lsame_(uplo, "U")) { + if (lsame_(diag, "U")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 1.; +/* L150: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + l = *k + 1 - j; +/* Computing MAX */ + i__2 = 1, i__3 = j - *k; + i__4 = j - 1; + for (i__ = f2cmax(i__2,i__3); i__ <= i__4; ++i__) { + work[i__] += z_abs(&ab[l + i__ + j * ab_dim1]); +/* L160: */ + } +/* L170: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L180: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + l = *k + 1 - j; +/* Computing MAX */ + i__4 = 1, i__2 = j - *k; + i__3 = j; + for (i__ = f2cmax(i__4,i__2); i__ <= i__3; ++i__) { + work[i__] += z_abs(&ab[l + i__ + j * ab_dim1]); +/* L190: */ + } +/* L200: */ + } + } + } else { + if (lsame_(diag, "U")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 1.; +/* L210: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + l = 1 - j; +/* Computing MIN */ + i__4 = *n, i__2 = j + *k; + i__3 = f2cmin(i__4,i__2); + for (i__ = j + 1; i__ <= i__3; ++i__) { + work[i__] += z_abs(&ab[l + i__ + j * ab_dim1]); +/* L220: */ + } +/* L230: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L240: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + l = 1 - j; +/* Computing MIN */ + i__4 = *n, i__2 = j + *k; + i__3 = f2cmin(i__4,i__2); + for (i__ = j; i__ <= i__3; ++i__) { + work[i__] += z_abs(&ab[l + i__ + j * ab_dim1]); +/* L250: */ + } +/* L260: */ + } + } + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L270: */ + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ +/* SSQ(1) is scale */ +/* SSQ(2) is sum-of-squares */ +/* For better accuracy, sum each column separately. */ + + if (lsame_(uplo, "U")) { + if (lsame_(diag, "U")) { + ssq[0] = 1.; + ssq[1] = (doublereal) (*n); + if (*k > 0) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; +/* Computing MIN */ + i__4 = j - 1; + i__3 = f2cmin(i__4,*k); +/* Computing MAX */ + i__2 = *k + 2 - j; + zlassq_(&i__3, &ab[f2cmax(i__2,1) + j * ab_dim1], &c__1, + colssq, &colssq[1]); + dcombssq_(ssq, colssq); +/* L280: */ + } + } + } else { + ssq[0] = 0.; + ssq[1] = 1.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; +/* Computing MIN */ + i__4 = j, i__2 = *k + 1; + i__3 = f2cmin(i__4,i__2); +/* Computing MAX */ + i__5 = *k + 2 - j; + zlassq_(&i__3, &ab[f2cmax(i__5,1) + j * ab_dim1], &c__1, + colssq, &colssq[1]); + dcombssq_(ssq, colssq); +/* L290: */ + } + } + } else { + if (lsame_(diag, "U")) { + ssq[0] = 1.; + ssq[1] = (doublereal) (*n); + if (*k > 0) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; +/* Computing MIN */ + i__4 = *n - j; + i__3 = f2cmin(i__4,*k); + zlassq_(&i__3, &ab[j * ab_dim1 + 2], &c__1, colssq, & + colssq[1]); + dcombssq_(ssq, colssq); +/* L300: */ + } + } + } else { + ssq[0] = 0.; + ssq[1] = 1.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; +/* Computing MIN */ + i__4 = *n - j + 1, i__2 = *k + 1; + i__3 = f2cmin(i__4,i__2); + zlassq_(&i__3, &ab[j * ab_dim1 + 1], &c__1, colssq, & + colssq[1]); + dcombssq_(ssq, colssq); +/* L310: */ + } + } + } + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of ZLANTB */ + +} /* zlantb_ */ + diff --git a/lapack-netlib/SRC/zlantp.c b/lapack-netlib/SRC/zlantp.c new file mode 100644 index 000000000..c95be9785 --- /dev/null +++ b/lapack-netlib/SRC/zlantp.c @@ -0,0 +1,840 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLANTP returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the ele +ment of largest absolute value of a triangular matrix supplied in packed form. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLANTP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLANTP( NORM, UPLO, DIAG, N, AP, WORK ) */ + +/* CHARACTER DIAG, NORM, UPLO */ +/* INTEGER N */ +/* DOUBLE PRECISION WORK( * ) */ +/* COMPLEX*16 AP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLANTP returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of a */ +/* > triangular matrix A, supplied in packed form. */ +/* > \endverbatim */ +/* > */ +/* > \return ZLANTP */ +/* > \verbatim */ +/* > */ +/* > ZLANTP = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in ZLANTP as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the matrix A is upper or lower triangular. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > Specifies whether or not the matrix A is unit triangular. */ +/* > = 'N': Non-unit triangular */ +/* > = 'U': Unit triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. When N = 0, ZLANTP is */ +/* > set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > The upper or lower triangular 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. */ +/* > Note that when DIAG = 'U', the elements of the array AP */ +/* > corresponding to the diagonal elements of the matrix A are */ +/* > not referenced, but are assumed to be one. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ +/* > where LWORK >= N when NORM = 'I'; otherwise, WORK is not */ +/* > referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +doublereal zlantp_(char *norm, char *uplo, char *diag, integer *n, + doublecomplex *ap, doublereal *work) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal ret_val; + + /* Local variables */ + extern /* Subroutine */ int dcombssq_(doublereal *, doublereal *); + integer i__, j, k; + logical udiag; + extern logical lsame_(char *, char *); + doublereal value; + extern logical disnan_(doublereal *); + doublereal colssq[2]; + extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *, + doublereal *, doublereal *); + doublereal sum, ssq[2]; + + +/* -- 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 */ + --work; + --ap; + + /* Function Body */ + if (*n == 0) { + value = 0.; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + k = 1; + if (lsame_(diag, "U")) { + value = 1.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k + j - 2; + for (i__ = k; i__ <= i__2; ++i__) { + sum = z_abs(&ap[i__]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L10: */ + } + k += j; +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k + *n - j; + for (i__ = k + 1; i__ <= i__2; ++i__) { + sum = z_abs(&ap[i__]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L30: */ + } + k = k + *n - j + 1; +/* L40: */ + } + } + } else { + value = 0.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k + j - 1; + for (i__ = k; i__ <= i__2; ++i__) { + sum = z_abs(&ap[i__]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L50: */ + } + k += j; +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = k + *n - j; + for (i__ = k; i__ <= i__2; ++i__) { + sum = z_abs(&ap[i__]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L70: */ + } + k = k + *n - j + 1; +/* L80: */ + } + } + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + value = 0.; + k = 1; + udiag = lsame_(diag, "U"); + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (udiag) { + sum = 1.; + i__2 = k + j - 2; + for (i__ = k; i__ <= i__2; ++i__) { + sum += z_abs(&ap[i__]); +/* L90: */ + } + } else { + sum = 0.; + i__2 = k + j - 1; + for (i__ = k; i__ <= i__2; ++i__) { + sum += z_abs(&ap[i__]); +/* L100: */ + } + } + k += j; + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L110: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (udiag) { + sum = 1.; + i__2 = k + *n - j; + for (i__ = k + 1; i__ <= i__2; ++i__) { + sum += z_abs(&ap[i__]); +/* L120: */ + } + } else { + sum = 0.; + i__2 = k + *n - j; + for (i__ = k; i__ <= i__2; ++i__) { + sum += z_abs(&ap[i__]); +/* L130: */ + } + } + k = k + *n - j + 1; + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L140: */ + } + } + } else if (lsame_(norm, "I")) { + +/* Find normI(A). */ + + k = 1; + if (lsame_(uplo, "U")) { + if (lsame_(diag, "U")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 1.; +/* L150: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] += z_abs(&ap[k]); + ++k; +/* L160: */ + } + ++k; +/* L170: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L180: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] += z_abs(&ap[k]); + ++k; +/* L190: */ + } +/* L200: */ + } + } + } else { + if (lsame_(diag, "U")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 1.; +/* L210: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + ++k; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + work[i__] += z_abs(&ap[k]); + ++k; +/* L220: */ + } +/* L230: */ + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L240: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + work[i__] += z_abs(&ap[k]); + ++k; +/* L250: */ + } +/* L260: */ + } + } + } + value = 0.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L270: */ + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ +/* SSQ(1) is scale */ +/* SSQ(2) is sum-of-squares */ +/* For better accuracy, sum each column separately. */ + + if (lsame_(uplo, "U")) { + if (lsame_(diag, "U")) { + ssq[0] = 1.; + ssq[1] = (doublereal) (*n); + k = 2; + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; + i__2 = j - 1; + zlassq_(&i__2, &ap[k], &c__1, colssq, &colssq[1]); + dcombssq_(ssq, colssq); + k += j; +/* L280: */ + } + } else { + ssq[0] = 0.; + ssq[1] = 1.; + k = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; + zlassq_(&j, &ap[k], &c__1, colssq, &colssq[1]); + dcombssq_(ssq, colssq); + k += j; +/* L290: */ + } + } + } else { + if (lsame_(diag, "U")) { + ssq[0] = 1.; + ssq[1] = (doublereal) (*n); + k = 2; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; + i__2 = *n - j; + zlassq_(&i__2, &ap[k], &c__1, colssq, &colssq[1]); + dcombssq_(ssq, colssq); + k = k + *n - j + 1; +/* L300: */ + } + } else { + ssq[0] = 0.; + ssq[1] = 1.; + k = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; + i__2 = *n - j + 1; + zlassq_(&i__2, &ap[k], &c__1, colssq, &colssq[1]); + dcombssq_(ssq, colssq); + k = k + *n - j + 1; +/* L310: */ + } + } + } + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of ZLANTP */ + +} /* zlantp_ */ + diff --git a/lapack-netlib/SRC/zlantr.c b/lapack-netlib/SRC/zlantr.c new file mode 100644 index 000000000..488b4f81f --- /dev/null +++ b/lapack-netlib/SRC/zlantr.c @@ -0,0 +1,853 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLANTR returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the ele +ment of largest absolute value of a trapezoidal or triangular matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLANTR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLANTR( NORM, UPLO, DIAG, M, N, A, LDA, */ +/* WORK ) */ + +/* CHARACTER DIAG, NORM, UPLO */ +/* INTEGER LDA, M, N */ +/* DOUBLE PRECISION WORK( * ) */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLANTR returns the value of the one norm, or the Frobenius norm, or */ +/* > the infinity norm, or the element of largest absolute value of a */ +/* > trapezoidal or triangular matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \return ZLANTR */ +/* > \verbatim */ +/* > */ +/* > ZLANTR = ( f2cmax(abs(A(i,j))), NORM = 'M' or 'm' */ +/* > ( */ +/* > ( norm1(A), NORM = '1', 'O' or 'o' */ +/* > ( */ +/* > ( normI(A), NORM = 'I' or 'i' */ +/* > ( */ +/* > ( normF(A), NORM = 'F', 'f', 'E' or 'e' */ +/* > */ +/* > where norm1 denotes the one norm of a matrix (maximum column sum), */ +/* > normI denotes the infinity norm of a matrix (maximum row sum) and */ +/* > normF denotes the Frobenius norm of a matrix (square root of sum of */ +/* > squares). Note that f2cmax(abs(A(i,j))) is not a consistent matrix norm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies the value to be returned in ZLANTR as described */ +/* > above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the matrix A is upper or lower trapezoidal. */ +/* > = 'U': Upper trapezoidal */ +/* > = 'L': Lower trapezoidal */ +/* > Note that A is triangular instead of trapezoidal if M = N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > Specifies whether or not the matrix A has unit diagonal. */ +/* > = 'N': Non-unit diagonal */ +/* > = 'U': Unit diagonal */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0, and if */ +/* > UPLO = 'U', M <= N. When M = 0, ZLANTR is set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0, and if */ +/* > UPLO = 'L', N <= M. When N = 0, ZLANTR is set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > The trapezoidal matrix A (A is triangular if M = N). */ +/* > If UPLO = 'U', the leading m by n upper trapezoidal part of */ +/* > the array A contains the upper trapezoidal matrix, and the */ +/* > strictly lower triangular part of A is not referenced. */ +/* > If UPLO = 'L', the leading m by n lower trapezoidal part of */ +/* > the array A contains the lower trapezoidal matrix, and the */ +/* > strictly upper triangular part of A is not referenced. Note */ +/* > that when DIAG = 'U', the diagonal elements of A are not */ +/* > referenced and are assumed to be one. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(M,1). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */ +/* > where LWORK >= M when NORM = 'I'; otherwise, WORK is not */ +/* > referenced. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +doublereal zlantr_(char *norm, char *uplo, char *diag, integer *m, integer *n, + doublecomplex *a, integer *lda, doublereal *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + doublereal ret_val; + + /* Local variables */ + extern /* Subroutine */ int dcombssq_(doublereal *, doublereal *); + integer i__, j; + logical udiag; + extern logical lsame_(char *, char *); + doublereal value; + extern logical disnan_(doublereal *); + doublereal colssq[2]; + extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *, + doublereal *, doublereal *); + doublereal sum, ssq[2]; + + +/* -- 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; + --work; + + /* Function Body */ + if (f2cmin(*m,*n) == 0) { + value = 0.; + } else if (lsame_(norm, "M")) { + +/* Find f2cmax(abs(A(i,j))). */ + + if (lsame_(diag, "U")) { + value = 1.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = *m, i__4 = j - 1; + i__2 = f2cmin(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + sum = z_abs(&a[i__ + j * a_dim1]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + sum = z_abs(&a[i__ + j * a_dim1]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L30: */ + } +/* L40: */ + } + } + } else { + value = 0.; + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = f2cmin(*m,j); + for (i__ = 1; i__ <= i__2; ++i__) { + sum = z_abs(&a[i__ + j * a_dim1]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L50: */ + } +/* L60: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + sum = z_abs(&a[i__ + j * a_dim1]); + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L70: */ + } +/* L80: */ + } + } + } + } else if (lsame_(norm, "O") || *(unsigned char *) + norm == '1') { + +/* Find norm1(A). */ + + value = 0.; + udiag = lsame_(diag, "U"); + if (lsame_(uplo, "U")) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (udiag && j <= *m) { + sum = 1.; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + sum += z_abs(&a[i__ + j * a_dim1]); +/* L90: */ + } + } else { + sum = 0.; + i__2 = f2cmin(*m,j); + for (i__ = 1; i__ <= i__2; ++i__) { + sum += z_abs(&a[i__ + j * a_dim1]); +/* L100: */ + } + } + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L110: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (udiag) { + sum = 1.; + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + sum += z_abs(&a[i__ + j * a_dim1]); +/* L120: */ + } + } else { + sum = 0.; + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + sum += z_abs(&a[i__ + j * a_dim1]); +/* L130: */ + } + } + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L140: */ + } + } + } else if (lsame_(norm, "I")) { + +/* Find normI(A). */ + + if (lsame_(uplo, "U")) { + if (lsame_(diag, "U")) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 1.; +/* L150: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = *m, i__4 = j - 1; + i__2 = f2cmin(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] += z_abs(&a[i__ + j * a_dim1]); +/* L160: */ + } +/* L170: */ + } + } else { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L180: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = f2cmin(*m,j); + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] += z_abs(&a[i__ + j * a_dim1]); +/* L190: */ + } +/* L200: */ + } + } + } else { + if (lsame_(diag, "U")) { + i__1 = f2cmin(*m,*n); + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 1.; +/* L210: */ + } + i__1 = *m; + for (i__ = *n + 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L220: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + work[i__] += z_abs(&a[i__ + j * a_dim1]); +/* L230: */ + } +/* L240: */ + } + } else { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L250: */ + } + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + work[i__] += z_abs(&a[i__ + j * a_dim1]); +/* L260: */ + } +/* L270: */ + } + } + } + value = 0.; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + sum = work[i__]; + if (value < sum || disnan_(&sum)) { + value = sum; + } +/* L280: */ + } + } else if (lsame_(norm, "F") || lsame_(norm, "E")) { + +/* Find normF(A). */ +/* SSQ(1) is scale */ +/* SSQ(2) is sum-of-squares */ +/* For better accuracy, sum each column separately. */ + + if (lsame_(uplo, "U")) { + if (lsame_(diag, "U")) { + ssq[0] = 1.; + ssq[1] = (doublereal) f2cmin(*m,*n); + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; +/* Computing MIN */ + i__3 = *m, i__4 = j - 1; + i__2 = f2cmin(i__3,i__4); + zlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, colssq, &colssq[ + 1]); + dcombssq_(ssq, colssq); +/* L290: */ + } + } else { + ssq[0] = 0.; + ssq[1] = 1.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; + i__2 = f2cmin(*m,j); + zlassq_(&i__2, &a[j * a_dim1 + 1], &c__1, colssq, &colssq[ + 1]); + dcombssq_(ssq, colssq); +/* L300: */ + } + } + } else { + if (lsame_(diag, "U")) { + ssq[0] = 1.; + ssq[1] = (doublereal) f2cmin(*m,*n); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; + i__2 = *m - j; +/* Computing MIN */ + i__3 = *m, i__4 = j + 1; + zlassq_(&i__2, &a[f2cmin(i__3,i__4) + j * a_dim1], &c__1, + colssq, &colssq[1]); + dcombssq_(ssq, colssq); +/* L310: */ + } + } else { + ssq[0] = 0.; + ssq[1] = 1.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + colssq[0] = 0.; + colssq[1] = 1.; + i__2 = *m - j + 1; + zlassq_(&i__2, &a[j + j * a_dim1], &c__1, colssq, &colssq[ + 1]); + dcombssq_(ssq, colssq); +/* L320: */ + } + } + } + value = ssq[0] * sqrt(ssq[1]); + } + + ret_val = value; + return ret_val; + +/* End of ZLANTR */ + +} /* zlantr_ */ + diff --git a/lapack-netlib/SRC/zlapll.c b/lapack-netlib/SRC/zlapll.c new file mode 100644 index 000000000..c43bb6ee9 --- /dev/null +++ b/lapack-netlib/SRC/zlapll.c @@ -0,0 +1,565 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAPLL measures the linear dependence of two vectors. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAPLL + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAPLL( N, X, INCX, Y, INCY, SSMIN ) */ + +/* INTEGER INCX, INCY, N */ +/* DOUBLE PRECISION SSMIN */ +/* COMPLEX*16 X( * ), Y( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Given two column vectors X and Y, let */ +/* > */ +/* > A = ( X Y ). */ +/* > */ +/* > The subroutine first computes the QR factorization of A = Q*R, */ +/* > and then computes the SVD of the 2-by-2 upper triangular matrix R. */ +/* > The smaller singular value of R is returned in SSMIN, which is used */ +/* > as the measurement of the linear dependency of the vectors X and Y. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The length of the vectors X and Y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (1+(N-1)*INCX) */ +/* > On entry, X contains the N-vector X. */ +/* > On exit, X is overwritten. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The increment between successive elements of X. INCX > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is COMPLEX*16 array, dimension (1+(N-1)*INCY) */ +/* > On entry, Y contains the N-vector Y. */ +/* > On exit, Y is overwritten. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCY */ +/* > \verbatim */ +/* > INCY is INTEGER */ +/* > The increment between successive elements of Y. INCY > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SSMIN */ +/* > \verbatim */ +/* > SSMIN is DOUBLE PRECISION */ +/* > The smallest singular value of the N-by-2 matrix A = ( X Y ). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlapll_(integer *n, doublecomplex *x, integer *incx, + doublecomplex *y, integer *incy, doublereal *ssmin) +{ + /* System generated locals */ + integer i__1; + doublereal d__1, d__2, d__3; + doublecomplex z__1, z__2, z__3, z__4; + + /* Local variables */ + extern /* Subroutine */ int dlas2_(doublereal *, doublereal *, doublereal + *, doublereal *, doublereal *); + doublecomplex c__; + extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + doublereal ssmax; + extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *); + doublecomplex a11, a12, a22; + extern /* Subroutine */ int zlarfg_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *); + doublecomplex tau; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + --y; + --x; + + /* Function Body */ + if (*n <= 1) { + *ssmin = 0.; + return 0; + } + +/* Compute the QR factorization of the N-by-2 matrix ( X Y ) */ + + zlarfg_(n, &x[1], &x[*incx + 1], incx, &tau); + a11.r = x[1].r, a11.i = x[1].i; + x[1].r = 1., x[1].i = 0.; + + d_cnjg(&z__3, &tau); + z__2.r = -z__3.r, z__2.i = -z__3.i; + zdotc_(&z__4, n, &x[1], incx, &y[1], incy); + z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i + + z__2.i * z__4.r; + c__.r = z__1.r, c__.i = z__1.i; + zaxpy_(n, &c__, &x[1], incx, &y[1], incy); + + i__1 = *n - 1; + zlarfg_(&i__1, &y[*incy + 1], &y[(*incy << 1) + 1], incy, &tau); + + a12.r = y[1].r, a12.i = y[1].i; + i__1 = *incy + 1; + a22.r = y[i__1].r, a22.i = y[i__1].i; + +/* Compute the SVD of 2-by-2 Upper triangular matrix. */ + + d__1 = z_abs(&a11); + d__2 = z_abs(&a12); + d__3 = z_abs(&a22); + dlas2_(&d__1, &d__2, &d__3, ssmin, &ssmax); + + return 0; + +/* End of ZLAPLL */ + +} /* zlapll_ */ + diff --git a/lapack-netlib/SRC/zlapmr.c b/lapack-netlib/SRC/zlapmr.c new file mode 100644 index 000000000..564677fbf --- /dev/null +++ b/lapack-netlib/SRC/zlapmr.c @@ -0,0 +1,619 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAPMR rearranges rows of a matrix as specified by a permutation vector. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAPMR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAPMR( FORWRD, M, N, X, LDX, K ) */ + +/* LOGICAL FORWRD */ +/* INTEGER LDX, M, N */ +/* INTEGER K( * ) */ +/* COMPLEX*16 X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAPMR rearranges the rows of the M by N matrix X as specified */ +/* > by the permutation K(1),K(2),...,K(M) of the integers 1,...,M. */ +/* > If FORWRD = .TRUE., forward permutation: */ +/* > */ +/* > X(K(I),*) is moved X(I,*) for I = 1,2,...,M. */ +/* > */ +/* > If FORWRD = .FALSE., backward permutation: */ +/* > */ +/* > X(I,*) is moved to X(K(I),*) for I = 1,2,...,M. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] FORWRD */ +/* > \verbatim */ +/* > FORWRD is LOGICAL */ +/* > = .TRUE., forward permutation */ +/* > = .FALSE., backward permutation */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix X. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix X. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (LDX,N) */ +/* > On entry, the M by N matrix X. */ +/* > On exit, X contains the permuted matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X, LDX >= MAX(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] K */ +/* > \verbatim */ +/* > K is INTEGER array, dimension (M) */ +/* > On entry, K contains the permutation vector. K is used as */ +/* > internal workspace, but reset to its original value on */ +/* > output. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlapmr_(logical *forwrd, integer *m, integer *n, + doublecomplex *x, integer *ldx, integer *k) +{ + /* System generated locals */ + integer x_dim1, x_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + doublecomplex temp; + integer i__, j, jj, in; + + +/* -- 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 */ + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --k; + + /* Function Body */ + if (*m <= 1) { + return 0; + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + k[i__] = -k[i__]; +/* L10: */ + } + + if (*forwrd) { + +/* Forward permutation */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + + if (k[i__] > 0) { + goto L40; + } + + j = i__; + k[j] = -k[j]; + in = k[j]; + +L20: + if (k[in] > 0) { + goto L40; + } + + i__2 = *n; + for (jj = 1; jj <= i__2; ++jj) { + i__3 = j + jj * x_dim1; + temp.r = x[i__3].r, temp.i = x[i__3].i; + i__3 = j + jj * x_dim1; + i__4 = in + jj * x_dim1; + x[i__3].r = x[i__4].r, x[i__3].i = x[i__4].i; + i__3 = in + jj * x_dim1; + x[i__3].r = temp.r, x[i__3].i = temp.i; +/* L30: */ + } + + k[in] = -k[in]; + j = in; + in = k[in]; + goto L20; + +L40: + +/* L50: */ + ; + } + + } else { + +/* Backward permutation */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + + if (k[i__] > 0) { + goto L80; + } + + k[i__] = -k[i__]; + j = k[i__]; +L60: + if (j == i__) { + goto L80; + } + + i__2 = *n; + for (jj = 1; jj <= i__2; ++jj) { + i__3 = i__ + jj * x_dim1; + temp.r = x[i__3].r, temp.i = x[i__3].i; + i__3 = i__ + jj * x_dim1; + i__4 = j + jj * x_dim1; + x[i__3].r = x[i__4].r, x[i__3].i = x[i__4].i; + i__3 = j + jj * x_dim1; + x[i__3].r = temp.r, x[i__3].i = temp.i; +/* L70: */ + } + + k[j] = -k[j]; + j = k[j]; + goto L60; + +L80: + +/* L90: */ + ; + } + + } + + return 0; + +/* End of ZLAPMT */ + +} /* zlapmr_ */ + diff --git a/lapack-netlib/SRC/zlapmt.c b/lapack-netlib/SRC/zlapmt.c new file mode 100644 index 000000000..814999028 --- /dev/null +++ b/lapack-netlib/SRC/zlapmt.c @@ -0,0 +1,619 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAPMT performs a forward or backward permutation of the columns of a matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAPMT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAPMT( FORWRD, M, N, X, LDX, K ) */ + +/* LOGICAL FORWRD */ +/* INTEGER LDX, M, N */ +/* INTEGER K( * ) */ +/* COMPLEX*16 X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAPMT rearranges the columns of the M by N matrix X as specified */ +/* > by the permutation K(1),K(2),...,K(N) of the integers 1,...,N. */ +/* > If FORWRD = .TRUE., forward permutation: */ +/* > */ +/* > X(*,K(J)) is moved X(*,J) for J = 1,2,...,N. */ +/* > */ +/* > If FORWRD = .FALSE., backward permutation: */ +/* > */ +/* > X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] FORWRD */ +/* > \verbatim */ +/* > FORWRD is LOGICAL */ +/* > = .TRUE., forward permutation */ +/* > = .FALSE., backward permutation */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix X. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix X. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (LDX,N) */ +/* > On entry, the M by N matrix X. */ +/* > On exit, X contains the permuted matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X, LDX >= MAX(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] K */ +/* > \verbatim */ +/* > K is INTEGER array, dimension (N) */ +/* > On entry, K contains the permutation vector. K is used as */ +/* > internal workspace, but reset to its original value on */ +/* > output. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlapmt_(logical *forwrd, integer *m, integer *n, + doublecomplex *x, integer *ldx, integer *k) +{ + /* System generated locals */ + integer x_dim1, x_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + doublecomplex temp; + integer i__, j, ii, in; + + +/* -- 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 */ + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --k; + + /* Function Body */ + if (*n <= 1) { + return 0; + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + k[i__] = -k[i__]; +/* L10: */ + } + + if (*forwrd) { + +/* Forward permutation */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + + if (k[i__] > 0) { + goto L40; + } + + j = i__; + k[j] = -k[j]; + in = k[j]; + +L20: + if (k[in] > 0) { + goto L40; + } + + i__2 = *m; + for (ii = 1; ii <= i__2; ++ii) { + i__3 = ii + j * x_dim1; + temp.r = x[i__3].r, temp.i = x[i__3].i; + i__3 = ii + j * x_dim1; + i__4 = ii + in * x_dim1; + x[i__3].r = x[i__4].r, x[i__3].i = x[i__4].i; + i__3 = ii + in * x_dim1; + x[i__3].r = temp.r, x[i__3].i = temp.i; +/* L30: */ + } + + k[in] = -k[in]; + j = in; + in = k[in]; + goto L20; + +L40: + +/* L50: */ + ; + } + + } else { + +/* Backward permutation */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + + if (k[i__] > 0) { + goto L80; + } + + k[i__] = -k[i__]; + j = k[i__]; +L60: + if (j == i__) { + goto L80; + } + + i__2 = *m; + for (ii = 1; ii <= i__2; ++ii) { + i__3 = ii + i__ * x_dim1; + temp.r = x[i__3].r, temp.i = x[i__3].i; + i__3 = ii + i__ * x_dim1; + i__4 = ii + j * x_dim1; + x[i__3].r = x[i__4].r, x[i__3].i = x[i__4].i; + i__3 = ii + j * x_dim1; + x[i__3].r = temp.r, x[i__3].i = temp.i; +/* L70: */ + } + + k[j] = -k[j]; + j = k[j]; + goto L60; + +L80: + +/* L90: */ + ; + } + + } + + return 0; + +/* End of ZLAPMT */ + +} /* zlapmt_ */ + diff --git a/lapack-netlib/SRC/zlaqgb.c b/lapack-netlib/SRC/zlaqgb.c new file mode 100644 index 000000000..551768a9d --- /dev/null +++ b/lapack-netlib/SRC/zlaqgb.c @@ -0,0 +1,677 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAQGB scales a general band matrix, using row and column scaling factors computed by sgbequ. +*/ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAQGB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, */ +/* AMAX, EQUED ) */ + +/* CHARACTER EQUED */ +/* INTEGER KL, KU, LDAB, M, N */ +/* DOUBLE PRECISION AMAX, COLCND, ROWCND */ +/* DOUBLE PRECISION C( * ), R( * ) */ +/* COMPLEX*16 AB( LDAB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAQGB equilibrates a general M by N band matrix A with KL */ +/* > subdiagonals and KU superdiagonals using the row and scaling factors */ +/* > in the vectors R and C. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of subdiagonals within the band of A. KL >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of superdiagonals within the band of A. KU >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is COMPLEX*16 array, dimension (LDAB,N) */ +/* > On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */ +/* > The j-th column of A is stored in the j-th column of the */ +/* > array AB as follows: */ +/* > AB(ku+1+i-j,j) = A(i,j) for f2cmax(1,j-ku)<=i<=f2cmin(m,j+kl) */ +/* > */ +/* > On exit, the equilibrated matrix, in the same storage format */ +/* > as A. See EQUED for the form of the equilibrated matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDA >= KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] R */ +/* > \verbatim */ +/* > R is DOUBLE PRECISION array, dimension (M) */ +/* > The row scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N) */ +/* > The column scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ROWCND */ +/* > \verbatim */ +/* > ROWCND is DOUBLE PRECISION */ +/* > Ratio of the smallest R(i) to the largest R(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COLCND */ +/* > \verbatim */ +/* > COLCND is DOUBLE PRECISION */ +/* > Ratio of the smallest C(i) to the largest C(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AMAX */ +/* > \verbatim */ +/* > AMAX is DOUBLE PRECISION */ +/* > Absolute value of largest matrix entry. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies the form of equilibration that was done. */ +/* > = 'N': No equilibration */ +/* > = 'R': Row equilibration, i.e., A has been premultiplied by */ +/* > diag(R). */ +/* > = 'C': Column equilibration, i.e., A has been postmultiplied */ +/* > by diag(C). */ +/* > = 'B': Both row and column equilibration, i.e., A has been */ +/* > replaced by diag(R) * A * diag(C). */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > THRESH is a threshold value used to decide if row or column scaling */ +/* > should be done based on the ratio of the row or column scaling */ +/* > factors. If ROWCND < THRESH, row scaling is done, and if */ +/* > COLCND < THRESH, column scaling is done. */ +/* > */ +/* > LARGE and SMALL are threshold values used to decide if row scaling */ +/* > should be done based on the absolute size of the largest matrix */ +/* > element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GBauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlaqgb_(integer *m, integer *n, integer *kl, integer *ku, + doublecomplex *ab, integer *ldab, doublereal *r__, doublereal *c__, + doublereal *rowcnd, doublereal *colcnd, doublereal *amax, char *equed) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6; + doublereal d__1; + doublecomplex z__1; + + /* Local variables */ + integer i__, j; + doublereal large, small, cj; + extern doublereal dlamch_(char *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --r__; + --c__; + + /* Function Body */ + if (*m <= 0 || *n <= 0) { + *(unsigned char *)equed = 'N'; + return 0; + } + +/* Initialize LARGE and SMALL. */ + + small = dlamch_("Safe minimum") / dlamch_("Precision"); + large = 1. / small; + + if (*rowcnd >= .1 && *amax >= small && *amax <= large) { + +/* No row scaling */ + + if (*colcnd >= .1) { + +/* No column scaling */ + + *(unsigned char *)equed = 'N'; + } else { + +/* Column scaling */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = c__[j]; +/* Computing MAX */ + i__2 = 1, i__3 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__4 = f2cmin(i__5,i__6); + for (i__ = f2cmax(i__2,i__3); i__ <= i__4; ++i__) { + i__2 = *ku + 1 + i__ - j + j * ab_dim1; + i__3 = *ku + 1 + i__ - j + j * ab_dim1; + z__1.r = cj * ab[i__3].r, z__1.i = cj * ab[i__3].i; + ab[i__2].r = z__1.r, ab[i__2].i = z__1.i; +/* L10: */ + } +/* L20: */ + } + *(unsigned char *)equed = 'C'; + } + } else if (*colcnd >= .1) { + +/* Row scaling, no column scaling */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__4 = 1, i__2 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__3 = f2cmin(i__5,i__6); + for (i__ = f2cmax(i__4,i__2); i__ <= i__3; ++i__) { + i__4 = *ku + 1 + i__ - j + j * ab_dim1; + i__2 = i__; + i__5 = *ku + 1 + i__ - j + j * ab_dim1; + z__1.r = r__[i__2] * ab[i__5].r, z__1.i = r__[i__2] * ab[i__5] + .i; + ab[i__4].r = z__1.r, ab[i__4].i = z__1.i; +/* L30: */ + } +/* L40: */ + } + *(unsigned char *)equed = 'R'; + } else { + +/* Row and column scaling */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = c__[j]; +/* Computing MAX */ + i__3 = 1, i__4 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__2 = f2cmin(i__5,i__6); + for (i__ = f2cmax(i__3,i__4); i__ <= i__2; ++i__) { + i__3 = *ku + 1 + i__ - j + j * ab_dim1; + d__1 = cj * r__[i__]; + i__4 = *ku + 1 + i__ - j + j * ab_dim1; + z__1.r = d__1 * ab[i__4].r, z__1.i = d__1 * ab[i__4].i; + ab[i__3].r = z__1.r, ab[i__3].i = z__1.i; +/* L50: */ + } +/* L60: */ + } + *(unsigned char *)equed = 'B'; + } + + return 0; + +/* End of ZLAQGB */ + +} /* zlaqgb_ */ + diff --git a/lapack-netlib/SRC/zlaqge.c b/lapack-netlib/SRC/zlaqge.c new file mode 100644 index 000000000..12cefcff7 --- /dev/null +++ b/lapack-netlib/SRC/zlaqge.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 +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAQGE scales a general rectangular matrix, using row and column scaling factors computed by sg +eequ. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAQGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, */ +/* EQUED ) */ + +/* CHARACTER EQUED */ +/* INTEGER LDA, M, N */ +/* DOUBLE PRECISION AMAX, COLCND, ROWCND */ +/* DOUBLE PRECISION C( * ), R( * ) */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAQGE equilibrates a general M by N matrix A using the row and */ +/* > column scaling factors in the vectors R and C. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the M by N matrix A. */ +/* > On exit, the equilibrated matrix. See EQUED for the form of */ +/* > the equilibrated matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(M,1). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] R */ +/* > \verbatim */ +/* > R is DOUBLE PRECISION array, dimension (M) */ +/* > The row scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N) */ +/* > The column scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ROWCND */ +/* > \verbatim */ +/* > ROWCND is DOUBLE PRECISION */ +/* > Ratio of the smallest R(i) to the largest R(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COLCND */ +/* > \verbatim */ +/* > COLCND is DOUBLE PRECISION */ +/* > Ratio of the smallest C(i) to the largest C(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AMAX */ +/* > \verbatim */ +/* > AMAX is DOUBLE PRECISION */ +/* > Absolute value of largest matrix entry. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies the form of equilibration that was done. */ +/* > = 'N': No equilibration */ +/* > = 'R': Row equilibration, i.e., A has been premultiplied by */ +/* > diag(R). */ +/* > = 'C': Column equilibration, i.e., A has been postmultiplied */ +/* > by diag(C). */ +/* > = 'B': Both row and column equilibration, i.e., A has been */ +/* > replaced by diag(R) * A * diag(C). */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > THRESH is a threshold value used to decide if row or column scaling */ +/* > should be done based on the ratio of the row or column scaling */ +/* > factors. If ROWCND < THRESH, row scaling is done, and if */ +/* > COLCND < THRESH, column scaling is done. */ +/* > */ +/* > LARGE and SMALL are threshold values used to decide if row scaling */ +/* > should be done based on the absolute size of the largest matrix */ +/* > element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GEauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlaqge_(integer *m, integer *n, doublecomplex *a, + integer *lda, doublereal *r__, doublereal *c__, doublereal *rowcnd, + doublereal *colcnd, doublereal *amax, char *equed) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + doublereal d__1; + doublecomplex z__1; + + /* Local variables */ + integer i__, j; + doublereal large, small, cj; + extern doublereal dlamch_(char *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --r__; + --c__; + + /* Function Body */ + if (*m <= 0 || *n <= 0) { + *(unsigned char *)equed = 'N'; + return 0; + } + +/* Initialize LARGE and SMALL. */ + + small = dlamch_("Safe minimum") / dlamch_("Precision"); + large = 1. / small; + + if (*rowcnd >= .1 && *amax >= small && *amax <= large) { + +/* No row scaling */ + + if (*colcnd >= .1) { + +/* No column scaling */ + + *(unsigned char *)equed = 'N'; + } else { + +/* Column scaling */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = c__[j]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + z__1.r = cj * a[i__4].r, z__1.i = cj * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L10: */ + } +/* L20: */ + } + *(unsigned char *)equed = 'C'; + } + } else if (*colcnd >= .1) { + +/* Row scaling, no column scaling */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__; + i__5 = i__ + j * a_dim1; + z__1.r = r__[i__4] * a[i__5].r, z__1.i = r__[i__4] * a[i__5] + .i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L30: */ + } +/* L40: */ + } + *(unsigned char *)equed = 'R'; + } else { + +/* Row and column scaling */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = c__[j]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + d__1 = cj * r__[i__]; + i__4 = i__ + j * a_dim1; + z__1.r = d__1 * a[i__4].r, z__1.i = d__1 * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L50: */ + } +/* L60: */ + } + *(unsigned char *)equed = 'B'; + } + + return 0; + +/* End of ZLAQGE */ + +} /* zlaqge_ */ + diff --git a/lapack-netlib/SRC/zlaqhb.c b/lapack-netlib/SRC/zlaqhb.c new file mode 100644 index 000000000..0aee04d6f --- /dev/null +++ b/lapack-netlib/SRC/zlaqhb.c @@ -0,0 +1,640 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAQHB scales a Hermitian band matrix, using scaling factors computed by cpbequ. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAQHB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAQHB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) */ + +/* CHARACTER EQUED, UPLO */ +/* INTEGER KD, LDAB, N */ +/* DOUBLE PRECISION AMAX, SCOND */ +/* DOUBLE PRECISION S( * ) */ +/* COMPLEX*16 AB( LDAB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAQHB equilibrates a Hermitian band matrix A */ +/* > using the scaling factors in the vector S. */ +/* > \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] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of super-diagonals of the matrix A if UPLO = 'U', */ +/* > or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is COMPLEX*16 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, if INFO = 0, the triangular factor U or L from the */ +/* > Cholesky factorization A = U**H *U or A = L*L**H of the band */ +/* > matrix A, in the same storage format as A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is DOUBLE PRECISION array, dimension (N) */ +/* > The scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SCOND */ +/* > \verbatim */ +/* > SCOND is DOUBLE PRECISION */ +/* > Ratio of the smallest S(i) to the largest S(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AMAX */ +/* > \verbatim */ +/* > AMAX is DOUBLE PRECISION */ +/* > Absolute value of largest matrix entry. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies whether or not equilibration was done. */ +/* > = 'N': No equilibration. */ +/* > = 'Y': Equilibration was done, i.e., A has been replaced by */ +/* > diag(S) * A * diag(S). */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > THRESH is a threshold value used to decide if scaling should be done */ +/* > based on the ratio of the scaling factors. If SCOND < THRESH, */ +/* > scaling is done. */ +/* > */ +/* > LARGE and SMALL are threshold values used to decide if scaling should */ +/* > be done based on the absolute size of the largest matrix element. */ +/* > If AMAX > LARGE or AMAX < SMALL, scaling is done. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlaqhb_(char *uplo, integer *n, integer *kd, + doublecomplex *ab, integer *ldab, doublereal *s, doublereal *scond, + doublereal *amax, char *equed) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; + doublereal d__1; + doublecomplex z__1; + + /* Local variables */ + integer i__, j; + doublereal large; + extern logical lsame_(char *, char *); + doublereal small, cj; + extern doublereal dlamch_(char *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --s; + + /* Function Body */ + if (*n <= 0) { + *(unsigned char *)equed = 'N'; + return 0; + } + +/* Initialize LARGE and SMALL. */ + + small = dlamch_("Safe minimum") / dlamch_("Precision"); + large = 1. / small; + + if (*scond >= .1 && *amax >= small && *amax <= large) { + +/* No equilibration */ + + *(unsigned char *)equed = 'N'; + } else { + +/* Replace A by diag(S) * A * diag(S). */ + + if (lsame_(uplo, "U")) { + +/* Upper triangle of A is stored in band format. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; +/* Computing MAX */ + i__2 = 1, i__3 = j - *kd; + i__4 = j - 1; + for (i__ = f2cmax(i__2,i__3); i__ <= i__4; ++i__) { + i__2 = *kd + 1 + i__ - j + j * ab_dim1; + d__1 = cj * s[i__]; + i__3 = *kd + 1 + i__ - j + j * ab_dim1; + z__1.r = d__1 * ab[i__3].r, z__1.i = d__1 * ab[i__3].i; + ab[i__2].r = z__1.r, ab[i__2].i = z__1.i; +/* L10: */ + } + i__4 = *kd + 1 + j * ab_dim1; + i__2 = *kd + 1 + j * ab_dim1; + d__1 = cj * cj * ab[i__2].r; + ab[i__4].r = d__1, ab[i__4].i = 0.; +/* L20: */ + } + } else { + +/* Lower triangle of A is stored. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; + i__4 = j * ab_dim1 + 1; + i__2 = j * ab_dim1 + 1; + d__1 = cj * cj * ab[i__2].r; + ab[i__4].r = d__1, ab[i__4].i = 0.; +/* Computing MIN */ + i__2 = *n, i__3 = j + *kd; + i__4 = f2cmin(i__2,i__3); + for (i__ = j + 1; i__ <= i__4; ++i__) { + i__2 = i__ + 1 - j + j * ab_dim1; + d__1 = cj * s[i__]; + i__3 = i__ + 1 - j + j * ab_dim1; + z__1.r = d__1 * ab[i__3].r, z__1.i = d__1 * ab[i__3].i; + ab[i__2].r = z__1.r, ab[i__2].i = z__1.i; +/* L30: */ + } +/* L40: */ + } + } + *(unsigned char *)equed = 'Y'; + } + + return 0; + +/* End of ZLAQHB */ + +} /* zlaqhb_ */ + diff --git a/lapack-netlib/SRC/zlaqhe.c b/lapack-netlib/SRC/zlaqhe.c new file mode 100644 index 000000000..4487b9345 --- /dev/null +++ b/lapack-netlib/SRC/zlaqhe.c @@ -0,0 +1,629 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAQHE scales a Hermitian matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAQHE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAQHE( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) */ + +/* CHARACTER EQUED, UPLO */ +/* INTEGER LDA, N */ +/* DOUBLE PRECISION AMAX, SCOND */ +/* DOUBLE PRECISION S( * ) */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAQHE equilibrates a Hermitian matrix A using the scaling factors */ +/* > in the vector S. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > Hermitian 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 COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the Hermitian 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 EQUED = 'Y', the equilibrated matrix: */ +/* > diag(S) * A * diag(S). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(N,1). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is DOUBLE PRECISION array, dimension (N) */ +/* > The scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SCOND */ +/* > \verbatim */ +/* > SCOND is DOUBLE PRECISION */ +/* > Ratio of the smallest S(i) to the largest S(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AMAX */ +/* > \verbatim */ +/* > AMAX is DOUBLE PRECISION */ +/* > Absolute value of largest matrix entry. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies whether or not equilibration was done. */ +/* > = 'N': No equilibration. */ +/* > = 'Y': Equilibration was done, i.e., A has been replaced by */ +/* > diag(S) * A * diag(S). */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > THRESH is a threshold value used to decide if scaling should be done */ +/* > based on the ratio of the scaling factors. If SCOND < THRESH, */ +/* > scaling is done. */ +/* > */ +/* > LARGE and SMALL are threshold values used to decide if scaling should */ +/* > be done based on the absolute size of the largest matrix element. */ +/* > If AMAX > LARGE or AMAX < SMALL, scaling is done. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16HEauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlaqhe_(char *uplo, integer *n, doublecomplex *a, + integer *lda, doublereal *s, doublereal *scond, doublereal *amax, + char *equed) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + doublereal d__1; + doublecomplex z__1; + + /* Local variables */ + integer i__, j; + doublereal large; + extern logical lsame_(char *, char *); + doublereal small, cj; + extern doublereal dlamch_(char *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --s; + + /* Function Body */ + if (*n <= 0) { + *(unsigned char *)equed = 'N'; + return 0; + } + +/* Initialize LARGE and SMALL. */ + + small = dlamch_("Safe minimum") / dlamch_("Precision"); + large = 1. / small; + + if (*scond >= .1 && *amax >= small && *amax <= large) { + +/* No equilibration */ + + *(unsigned char *)equed = 'N'; + } else { + +/* Replace A by diag(S) * A * diag(S). */ + + if (lsame_(uplo, "U")) { + +/* Upper triangle of A is stored. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + d__1 = cj * s[i__]; + i__4 = i__ + j * a_dim1; + z__1.r = d__1 * a[i__4].r, z__1.i = d__1 * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L10: */ + } + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + d__1 = cj * cj * a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; +/* L20: */ + } + } else { + +/* Lower triangle of A is stored. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; + i__2 = j + j * a_dim1; + i__3 = j + j * a_dim1; + d__1 = cj * cj * a[i__3].r; + a[i__2].r = d__1, a[i__2].i = 0.; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + d__1 = cj * s[i__]; + i__4 = i__ + j * a_dim1; + z__1.r = d__1 * a[i__4].r, z__1.i = d__1 * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L30: */ + } +/* L40: */ + } + } + *(unsigned char *)equed = 'Y'; + } + + return 0; + +/* End of ZLAQHE */ + +} /* zlaqhe_ */ + diff --git a/lapack-netlib/SRC/zlaqhp.c b/lapack-netlib/SRC/zlaqhp.c new file mode 100644 index 000000000..66536cbd6 --- /dev/null +++ b/lapack-netlib/SRC/zlaqhp.c @@ -0,0 +1,624 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAQHP scales a Hermitian matrix stored in packed form. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAQHP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAQHP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) */ + +/* CHARACTER EQUED, UPLO */ +/* INTEGER N */ +/* DOUBLE PRECISION AMAX, SCOND */ +/* DOUBLE PRECISION S( * ) */ +/* COMPLEX*16 AP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAQHP equilibrates a Hermitian matrix A using the scaling factors */ +/* > in the vector S. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > Hermitian 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] AP */ +/* > \verbatim */ +/* > AP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the Hermitian 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, the equilibrated matrix: diag(S) * A * diag(S), in */ +/* > the same storage format as A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is DOUBLE PRECISION array, dimension (N) */ +/* > The scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SCOND */ +/* > \verbatim */ +/* > SCOND is DOUBLE PRECISION */ +/* > Ratio of the smallest S(i) to the largest S(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AMAX */ +/* > \verbatim */ +/* > AMAX is DOUBLE PRECISION */ +/* > Absolute value of largest matrix entry. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies whether or not equilibration was done. */ +/* > = 'N': No equilibration. */ +/* > = 'Y': Equilibration was done, i.e., A has been replaced by */ +/* > diag(S) * A * diag(S). */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > THRESH is a threshold value used to decide if scaling should be done */ +/* > based on the ratio of the scaling factors. If SCOND < THRESH, */ +/* > scaling is done. */ +/* > */ +/* > LARGE and SMALL are threshold values used to decide if scaling should */ +/* > be done based on the absolute size of the largest matrix element. */ +/* > If AMAX > LARGE or AMAX < SMALL, scaling is done. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlaqhp_(char *uplo, integer *n, doublecomplex *ap, + doublereal *s, doublereal *scond, doublereal *amax, char *equed) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4; + doublereal d__1; + doublecomplex z__1; + + /* Local variables */ + integer i__, j; + doublereal large; + extern logical lsame_(char *, char *); + doublereal small; + integer jc; + doublereal cj; + extern doublereal dlamch_(char *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + --s; + --ap; + + /* Function Body */ + if (*n <= 0) { + *(unsigned char *)equed = 'N'; + return 0; + } + +/* Initialize LARGE and SMALL. */ + + small = dlamch_("Safe minimum") / dlamch_("Precision"); + large = 1. / small; + + if (*scond >= .1 && *amax >= small && *amax <= large) { + +/* No equilibration */ + + *(unsigned char *)equed = 'N'; + } else { + +/* Replace A by diag(S) * A * diag(S). */ + + if (lsame_(uplo, "U")) { + +/* Upper triangle of A is stored. */ + + jc = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = jc + i__ - 1; + d__1 = cj * s[i__]; + i__4 = jc + i__ - 1; + z__1.r = d__1 * ap[i__4].r, z__1.i = d__1 * ap[i__4].i; + ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; +/* L10: */ + } + i__2 = jc + j - 1; + i__3 = jc + j - 1; + d__1 = cj * cj * ap[i__3].r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + jc += j; +/* L20: */ + } + } else { + +/* Lower triangle of A is stored. */ + + jc = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; + i__2 = jc; + i__3 = jc; + d__1 = cj * cj * ap[i__3].r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = jc + i__ - j; + d__1 = cj * s[i__]; + i__4 = jc + i__ - j; + z__1.r = d__1 * ap[i__4].r, z__1.i = d__1 * ap[i__4].i; + ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; +/* L30: */ + } + jc = jc + *n - j + 1; +/* L40: */ + } + } + *(unsigned char *)equed = 'Y'; + } + + return 0; + +/* End of ZLAQHP */ + +} /* zlaqhp_ */ + diff --git a/lapack-netlib/SRC/zlaqp2.c b/lapack-netlib/SRC/zlaqp2.c new file mode 100644 index 000000000..c8cdc1c68 --- /dev/null +++ b/lapack-netlib/SRC/zlaqp2.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 +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAQP2 computes a QR factorization with column pivoting of the matrix block. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAQP2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, */ +/* WORK ) */ + +/* INTEGER LDA, M, N, OFFSET */ +/* INTEGER JPVT( * ) */ +/* DOUBLE PRECISION VN1( * ), VN2( * ) */ +/* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAQP2 computes a QR factorization with column pivoting of */ +/* > the block A(OFFSET+1:M,1:N). */ +/* > The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] OFFSET */ +/* > \verbatim */ +/* > OFFSET is INTEGER */ +/* > The number of rows of the matrix A that must be pivoted */ +/* > but no factorized. OFFSET >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, the upper triangle of block A(OFFSET+1:M,1:N) is */ +/* > the triangular factor obtained; the elements in block */ +/* > A(OFFSET+1:M,1:N) below the diagonal, together with the */ +/* > array TAU, represent the orthogonal matrix Q as a product of */ +/* > elementary reflectors. Block A(1:OFFSET,1:N) has been */ +/* > accordingly pivoted, but no factorized. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] JPVT */ +/* > \verbatim */ +/* > JPVT is INTEGER array, dimension (N) */ +/* > On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */ +/* > to the front of A*P (a leading column); if JPVT(i) = 0, */ +/* > the i-th column of A is a free column. */ +/* > On exit, if JPVT(i) = k, then the i-th column of A*P */ +/* > was the k-th column of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 array, dimension (f2cmin(M,N)) */ +/* > The scalar factors of the elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VN1 */ +/* > \verbatim */ +/* > VN1 is DOUBLE PRECISION array, dimension (N) */ +/* > The vector with the partial column norms. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VN2 */ +/* > \verbatim */ +/* > VN2 is DOUBLE PRECISION array, dimension (N) */ +/* > The vector with the exact column norms. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (N) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */ +/* > X. Sun, Computer Science Dept., Duke University, USA */ +/* > \n */ +/* > Partial column norm updating strategy modified on April 2011 */ +/* > Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */ +/* > University of Zagreb, Croatia. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > LAPACK Working Note 176 */ + +/* > \htmlonly */ +/* > [PDF] */ +/* > \endhtmlonly */ + +/* ===================================================================== */ +/* Subroutine */ int zlaqp2_(integer *m, integer *n, integer *offset, + doublecomplex *a, integer *lda, integer *jpvt, doublecomplex *tau, + doublereal *vn1, doublereal *vn2, doublecomplex *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1; + doublecomplex z__1; + + /* Local variables */ + doublereal temp, temp2; + integer i__, j; + doublereal tol3z; + integer offpi, itemp; + extern /* Subroutine */ int zlarf_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *), zswap_(integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_( + char *); + integer mn; + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ int zlarfg_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *); + doublecomplex aii; + integer pvt; + + +/* -- 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; + --jpvt; + --tau; + --vn1; + --vn2; + --work; + + /* Function Body */ +/* Computing MIN */ + i__1 = *m - *offset; + mn = f2cmin(i__1,*n); + tol3z = sqrt(dlamch_("Epsilon")); + +/* Compute factorization. */ + + i__1 = mn; + for (i__ = 1; i__ <= i__1; ++i__) { + + offpi = *offset + i__; + +/* Determine ith pivot column and swap if necessary. */ + + i__2 = *n - i__ + 1; + pvt = i__ - 1 + idamax_(&i__2, &vn1[i__], &c__1); + + if (pvt != i__) { + zswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], & + c__1); + itemp = jpvt[pvt]; + jpvt[pvt] = jpvt[i__]; + jpvt[i__] = itemp; + vn1[pvt] = vn1[i__]; + vn2[pvt] = vn2[i__]; + } + +/* Generate elementary reflector H(i). */ + + if (offpi < *m) { + i__2 = *m - offpi + 1; + zlarfg_(&i__2, &a[offpi + i__ * a_dim1], &a[offpi + 1 + i__ * + a_dim1], &c__1, &tau[i__]); + } else { + zlarfg_(&c__1, &a[*m + i__ * a_dim1], &a[*m + i__ * a_dim1], & + c__1, &tau[i__]); + } + + if (i__ < *n) { + +/* Apply H(i)**H to A(offset+i:m,i+1:n) from the left. */ + + i__2 = offpi + i__ * a_dim1; + aii.r = a[i__2].r, aii.i = a[i__2].i; + i__2 = offpi + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + i__2 = *m - offpi + 1; + i__3 = *n - i__; + d_cnjg(&z__1, &tau[i__]); + zlarf_("Left", &i__2, &i__3, &a[offpi + i__ * a_dim1], &c__1, & + z__1, &a[offpi + (i__ + 1) * a_dim1], lda, &work[1]); + i__2 = offpi + i__ * a_dim1; + a[i__2].r = aii.r, a[i__2].i = aii.i; + } + +/* Update partial column norms. */ + + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + if (vn1[j] != 0.) { + +/* NOTE: The following 4 lines follow from the analysis in */ +/* Lapack Working Note 176. */ + +/* Computing 2nd power */ + d__1 = z_abs(&a[offpi + j * a_dim1]) / vn1[j]; + temp = 1. - d__1 * d__1; + temp = f2cmax(temp,0.); +/* Computing 2nd power */ + d__1 = vn1[j] / vn2[j]; + temp2 = temp * (d__1 * d__1); + if (temp2 <= tol3z) { + if (offpi < *m) { + i__3 = *m - offpi; + vn1[j] = dznrm2_(&i__3, &a[offpi + 1 + j * a_dim1], & + c__1); + vn2[j] = vn1[j]; + } else { + vn1[j] = 0.; + vn2[j] = 0.; + } + } else { + vn1[j] *= sqrt(temp); + } + } +/* L10: */ + } + +/* L20: */ + } + + return 0; + +/* End of ZLAQP2 */ + +} /* zlaqp2_ */ + diff --git a/lapack-netlib/SRC/zlaqps.c b/lapack-netlib/SRC/zlaqps.c new file mode 100644 index 000000000..e568a7c2e --- /dev/null +++ b/lapack-netlib/SRC/zlaqps.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 +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAQPS computes a step of QR factorization with column pivoting of a real m-by-n matrix A by us +ing BLAS level 3. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAQPS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, */ +/* VN2, AUXV, F, LDF ) */ + +/* INTEGER KB, LDA, LDF, M, N, NB, OFFSET */ +/* INTEGER JPVT( * ) */ +/* DOUBLE PRECISION VN1( * ), VN2( * ) */ +/* COMPLEX*16 A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAQPS computes a step of QR factorization with column pivoting */ +/* > of a complex M-by-N matrix A by using Blas-3. It tries to factorize */ +/* > NB columns from A starting from the row OFFSET+1, and updates all */ +/* > of the matrix with Blas-3 xGEMM. */ +/* > */ +/* > In some cases, due to catastrophic cancellations, it cannot */ +/* > factorize NB columns. Hence, the actual number of factorized */ +/* > columns is returned in KB. */ +/* > */ +/* > Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0 */ +/* > \endverbatim */ +/* > */ +/* > \param[in] OFFSET */ +/* > \verbatim */ +/* > OFFSET is INTEGER */ +/* > The number of rows of A that have been factorized in */ +/* > previous steps. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The number of columns to factorize. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] KB */ +/* > \verbatim */ +/* > KB is INTEGER */ +/* > The number of columns actually factorized. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, block A(OFFSET+1:M,1:KB) is the triangular */ +/* > factor obtained and block A(1:OFFSET,1:N) has been */ +/* > accordingly pivoted, but no factorized. */ +/* > The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has */ +/* > been updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] JPVT */ +/* > \verbatim */ +/* > JPVT is INTEGER array, dimension (N) */ +/* > JPVT(I) = K <==> Column K of the full matrix A has been */ +/* > permuted into position I in AP. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 array, dimension (KB) */ +/* > The scalar factors of the elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VN1 */ +/* > \verbatim */ +/* > VN1 is DOUBLE PRECISION array, dimension (N) */ +/* > The vector with the partial column norms. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VN2 */ +/* > \verbatim */ +/* > VN2 is DOUBLE PRECISION array, dimension (N) */ +/* > The vector with the exact column norms. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AUXV */ +/* > \verbatim */ +/* > AUXV is COMPLEX*16 array, dimension (NB) */ +/* > Auxiliary vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] F */ +/* > \verbatim */ +/* > F is COMPLEX*16 array, dimension (LDF,NB) */ +/* > Matrix F**H = L * Y**H * A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDF */ +/* > \verbatim */ +/* > LDF is INTEGER */ +/* > The leading dimension of the array F. LDF >= f2cmax(1,N). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */ +/* > X. Sun, Computer Science Dept., Duke University, USA */ +/* > \n */ +/* > Partial column norm updating strategy modified on April 2011 */ +/* > Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */ +/* > University of Zagreb, Croatia. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > LAPACK Working Note 176 */ + +/* > \htmlonly */ +/* > [PDF] */ +/* > \endhtmlonly */ + +/* ===================================================================== */ +/* Subroutine */ int zlaqps_(integer *m, integer *n, integer *offset, integer + *nb, integer *kb, doublecomplex *a, integer *lda, integer *jpvt, + doublecomplex *tau, doublereal *vn1, doublereal *vn2, doublecomplex * + auxv, doublecomplex *f, integer *ldf) +{ + /* System generated locals */ + integer a_dim1, a_offset, f_dim1, f_offset, i__1, i__2, i__3; + doublereal d__1, d__2; + doublecomplex z__1; + + /* Local variables */ + doublereal temp, temp2; + integer j, k; + doublereal tol3z; + integer itemp; + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *), zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *), + zswap_(integer *, doublecomplex *, integer *, doublecomplex *, + integer *); + extern doublereal dznrm2_(integer *, doublecomplex *, integer *), dlamch_( + char *); + integer rk; + extern integer idamax_(integer *, doublereal *, integer *); + integer lsticc; + extern /* Subroutine */ int zlarfg_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *); + integer lastrk; + doublecomplex akk; + integer pvt; + + +/* -- 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; + --jpvt; + --tau; + --vn1; + --vn2; + --auxv; + f_dim1 = *ldf; + f_offset = 1 + f_dim1 * 1; + f -= f_offset; + + /* Function Body */ +/* Computing MIN */ + i__1 = *m, i__2 = *n + *offset; + lastrk = f2cmin(i__1,i__2); + lsticc = 0; + k = 0; + tol3z = sqrt(dlamch_("Epsilon")); + +/* Beginning of while loop. */ + +L10: + if (k < *nb && lsticc == 0) { + ++k; + rk = *offset + k; + +/* Determine ith pivot column and swap if necessary */ + + i__1 = *n - k + 1; + pvt = k - 1 + idamax_(&i__1, &vn1[k], &c__1); + if (pvt != k) { + zswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + i__1 = k - 1; + zswap_(&i__1, &f[pvt + f_dim1], ldf, &f[k + f_dim1], ldf); + itemp = jpvt[pvt]; + jpvt[pvt] = jpvt[k]; + jpvt[k] = itemp; + vn1[pvt] = vn1[k]; + vn2[pvt] = vn2[k]; + } + +/* Apply previous Householder reflectors to column K: */ +/* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)**H. */ + + if (k > 1) { + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = k + j * f_dim1; + d_cnjg(&z__1, &f[k + j * f_dim1]); + f[i__2].r = z__1.r, f[i__2].i = z__1.i; +/* L20: */ + } + i__1 = *m - rk + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[rk + a_dim1], lda, + &f[k + f_dim1], ldf, &c_b2, &a[rk + k * a_dim1], &c__1); + i__1 = k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = k + j * f_dim1; + d_cnjg(&z__1, &f[k + j * f_dim1]); + f[i__2].r = z__1.r, f[i__2].i = z__1.i; +/* L30: */ + } + } + +/* Generate elementary reflector H(k). */ + + if (rk < *m) { + i__1 = *m - rk + 1; + zlarfg_(&i__1, &a[rk + k * a_dim1], &a[rk + 1 + k * a_dim1], & + c__1, &tau[k]); + } else { + zlarfg_(&c__1, &a[rk + k * a_dim1], &a[rk + k * a_dim1], &c__1, & + tau[k]); + } + + i__1 = rk + k * a_dim1; + akk.r = a[i__1].r, akk.i = a[i__1].i; + i__1 = rk + k * a_dim1; + a[i__1].r = 1., a[i__1].i = 0.; + +/* Compute Kth column of F: */ + +/* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**H*A(RK:M,K). */ + + if (k < *n) { + i__1 = *m - rk + 1; + i__2 = *n - k; + zgemv_("Conjugate transpose", &i__1, &i__2, &tau[k], &a[rk + (k + + 1) * a_dim1], lda, &a[rk + k * a_dim1], &c__1, &c_b1, &f[ + k + 1 + k * f_dim1], &c__1); + } + +/* Padding F(1:K,K) with zeros. */ + + i__1 = k; + for (j = 1; j <= i__1; ++j) { + i__2 = j + k * f_dim1; + f[i__2].r = 0., f[i__2].i = 0.; +/* L40: */ + } + +/* Incremental updating of F: */ +/* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)**H */ +/* *A(RK:M,K). */ + + if (k > 1) { + i__1 = *m - rk + 1; + i__2 = k - 1; + i__3 = k; + z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; + zgemv_("Conjugate transpose", &i__1, &i__2, &z__1, &a[rk + a_dim1] + , lda, &a[rk + k * a_dim1], &c__1, &c_b1, &auxv[1], &c__1); + + i__1 = k - 1; + zgemv_("No transpose", n, &i__1, &c_b2, &f[f_dim1 + 1], ldf, & + auxv[1], &c__1, &c_b2, &f[k * f_dim1 + 1], &c__1); + } + +/* Update the current row of A: */ +/* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)**H. */ + + if (k < *n) { + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Conjugate transpose", &c__1, &i__1, &k, & + z__1, &a[rk + a_dim1], lda, &f[k + 1 + f_dim1], ldf, & + c_b2, &a[rk + (k + 1) * a_dim1], lda); + } + +/* Update partial column norms. */ + + if (rk < lastrk) { + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + if (vn1[j] != 0.) { + +/* NOTE: The following 4 lines follow from the analysis in */ +/* Lapack Working Note 176. */ + + temp = z_abs(&a[rk + j * a_dim1]) / vn1[j]; +/* Computing MAX */ + d__1 = 0., d__2 = (temp + 1.) * (1. - temp); + temp = f2cmax(d__1,d__2); +/* Computing 2nd power */ + d__1 = vn1[j] / vn2[j]; + temp2 = temp * (d__1 * d__1); + if (temp2 <= tol3z) { + vn2[j] = (doublereal) lsticc; + lsticc = j; + } else { + vn1[j] *= sqrt(temp); + } + } +/* L50: */ + } + } + + i__1 = rk + k * a_dim1; + a[i__1].r = akk.r, a[i__1].i = akk.i; + +/* End of while loop. */ + + goto L10; + } + *kb = k; + rk = *offset + *kb; + +/* Apply the block reflector to the rest of the matrix: */ +/* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - */ +/* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)**H. */ + +/* Computing MIN */ + i__1 = *n, i__2 = *m - *offset; + if (*kb < f2cmin(i__1,i__2)) { + i__1 = *m - rk; + i__2 = *n - *kb; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Conjugate transpose", &i__1, &i__2, kb, &z__1, + &a[rk + 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b2, & + a[rk + 1 + (*kb + 1) * a_dim1], lda); + } + +/* Recomputation of difficult columns. */ + +L60: + if (lsticc > 0) { + itemp = i_dnnt(&vn2[lsticc]); + i__1 = *m - rk; + vn1[lsticc] = dznrm2_(&i__1, &a[rk + 1 + lsticc * a_dim1], &c__1); + +/* NOTE: The computation of VN1( LSTICC ) relies on the fact that */ +/* SNRM2 does not fail on vectors with norm below the value of */ +/* SQRT(DLAMCH('S')) */ + + vn2[lsticc] = vn1[lsticc]; + lsticc = itemp; + goto L60; + } + + return 0; + +/* End of ZLAQPS */ + +} /* zlaqps_ */ + diff --git a/lapack-netlib/SRC/zlaqr0.c b/lapack-netlib/SRC/zlaqr0.c new file mode 100644 index 000000000..3e0b2799c --- /dev/null +++ b/lapack-netlib/SRC/zlaqr0.c @@ -0,0 +1,1246 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAQR0 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Sc +hur decomposition. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAQR0 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, */ +/* IHIZ, Z, LDZ, WORK, LWORK, INFO ) */ + +/* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N */ +/* LOGICAL WANTT, WANTZ */ +/* COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAQR0 computes the eigenvalues of a Hessenberg matrix H */ +/* > and, optionally, the matrices T and Z from the Schur decomposition */ +/* > H = Z T Z**H, where T is an upper triangular matrix (the */ +/* > Schur form), and Z is the unitary matrix of Schur vectors. */ +/* > */ +/* > Optionally Z may be postmultiplied into an input unitary */ +/* > matrix Q so that this routine can give the Schur factorization */ +/* > of a matrix A which has been reduced to the Hessenberg form H */ +/* > by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] WANTT */ +/* > \verbatim */ +/* > WANTT is LOGICAL */ +/* > = .TRUE. : the full Schur form T is required; */ +/* > = .FALSE.: only eigenvalues are required. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTZ */ +/* > \verbatim */ +/* > WANTZ is LOGICAL */ +/* > = .TRUE. : the matrix of Schur vectors Z is required; */ +/* > = .FALSE.: Schur vectors are not required. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix H. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILO */ +/* > \verbatim */ +/* > ILO is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHI */ +/* > \verbatim */ +/* > IHI is INTEGER */ +/* > */ +/* > It is assumed that H is already upper triangular in rows */ +/* > and columns 1:ILO-1 and IHI+1:N and, if ILO > 1, */ +/* > H(ILO,ILO-1) is zero. ILO and IHI are normally set by a */ +/* > previous call to ZGEBAL, and then passed to ZGEHRD when the */ +/* > matrix output by ZGEBAL is reduced to Hessenberg form. */ +/* > Otherwise, ILO and IHI should be set to 1 and N, */ +/* > respectively. If N > 0, then 1 <= ILO <= IHI <= N. */ +/* > If N = 0, then ILO = 1 and IHI = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] H */ +/* > \verbatim */ +/* > H is COMPLEX*16 array, dimension (LDH,N) */ +/* > On entry, the upper Hessenberg matrix H. */ +/* > On exit, if INFO = 0 and WANTT is .TRUE., then H */ +/* > contains the upper triangular matrix T from the Schur */ +/* > decomposition (the Schur form). If INFO = 0 and WANT is */ +/* > .FALSE., then the contents of H are unspecified on exit. */ +/* > (The output value of H when INFO > 0 is given under the */ +/* > description of INFO below.) */ +/* > */ +/* > This subroutine may explicitly set H(i,j) = 0 for i > j and */ +/* > j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > The leading dimension of the array H. LDH >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is COMPLEX*16 array, dimension (N) */ +/* > The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored */ +/* > in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are */ +/* > stored in the same order as on the diagonal of the Schur */ +/* > form returned in H, with W(i) = H(i,i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILOZ */ +/* > \verbatim */ +/* > ILOZ is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHIZ */ +/* > \verbatim */ +/* > IHIZ is INTEGER */ +/* > Specify the rows of Z to which transformations must be */ +/* > applied if WANTZ is .TRUE.. */ +/* > 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX*16 array, dimension (LDZ,IHI) */ +/* > If WANTZ is .FALSE., then Z is not referenced. */ +/* > If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is */ +/* > replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the */ +/* > orthogonal Schur factor of H(ILO:IHI,ILO:IHI). */ +/* > (The output value of Z when INFO > 0 is given under */ +/* > the description of INFO below.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. if WANTZ is .TRUE. */ +/* > then LDZ >= MAX(1,IHIZ). Otherwise, LDZ >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension LWORK */ +/* > On exit, if LWORK = -1, WORK(1) returns an estimate of */ +/* > the optimal value for LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,N) */ +/* > is sufficient, but LWORK typically as large as 6*N may */ +/* > be required for optimal performance. A workspace query */ +/* > to determine the optimal workspace size is recommended. */ +/* > */ +/* > If LWORK = -1, then ZLAQR0 does a workspace query. */ +/* > In this case, ZLAQR0 checks the input parameters and */ +/* > estimates the optimal workspace size for the given */ +/* > values of N, ILO and IHI. The estimate is returned */ +/* > in WORK(1). No error message related to LWORK is */ +/* > issued by XERBLA. Neither H nor Z are accessed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > > 0: if INFO = i, ZLAQR0 failed to compute all of */ +/* > the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */ +/* > and WI contain those eigenvalues which have been */ +/* > successfully computed. (Failures are rare.) */ +/* > */ +/* > If INFO > 0 and WANT is .FALSE., then on exit, */ +/* > the remaining unconverged eigenvalues are the eigen- */ +/* > values of the upper Hessenberg matrix rows and */ +/* > columns ILO through INFO of the final, output */ +/* > value of H. */ +/* > */ +/* > If INFO > 0 and WANTT is .TRUE., then on exit */ +/* > */ +/* > (*) (initial value of H)*U = U*(final value of H) */ +/* > */ +/* > where U is a unitary matrix. The final */ +/* > value of H is upper Hessenberg and triangular in */ +/* > rows and columns INFO+1 through IHI. */ +/* > */ +/* > If INFO > 0 and WANTZ is .TRUE., then on exit */ +/* > */ +/* > (final value of Z(ILO:IHI,ILOZ:IHIZ) */ +/* > = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U */ +/* > */ +/* > where U is the unitary matrix in (*) (regard- */ +/* > less of the value of WANTT.) */ +/* > */ +/* > If INFO > 0 and WANTZ is .FALSE., then Z is not */ +/* > accessed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Karen Braman and Ralph Byers, Department of Mathematics, */ +/* > University of Kansas, USA */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ +/* > Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */ +/* > Performance, SIAM Journal of Matrix Analysis, volume 23, pages */ +/* > 929--947, 2002. */ +/* > \n */ +/* > K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ +/* > Algorithm Part II: Aggressive Early Deflation, SIAM Journal */ +/* > of Matrix Analysis, volume 23, pages 948--973, 2002. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlaqr0_(logical *wantt, logical *wantz, integer *n, + integer *ilo, integer *ihi, doublecomplex *h__, integer *ldh, + doublecomplex *w, integer *iloz, integer *ihiz, doublecomplex *z__, + integer *ldz, doublecomplex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; + doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8; + doublecomplex z__1, z__2, z__3, z__4, z__5; + + /* Local variables */ + integer ndec, ndfl, kbot, nmin; + doublecomplex swap; + integer ktop; + doublecomplex zdum[1] /* was [1][1] */; + integer kacc22, i__, k; + doublereal s; + integer itmax, nsmax, nwmax, kwtop; + doublecomplex aa, bb, cc, dd; + extern /* Subroutine */ int zlaqr3_(logical *, logical *, integer *, + integer *, integer *, integer *, doublecomplex *, integer *, + integer *, integer *, doublecomplex *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, integer *, + doublecomplex *, integer *, integer *, doublecomplex *, integer * + , doublecomplex *, integer *), zlaqr4_(logical *, logical *, + integer *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, integer *), zlaqr5_(logical *, + logical *, integer *, integer *, integer *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, integer *, doublecomplex *, integer *, + integer *, doublecomplex *, integer *); + integer ld, nh, nibble, it, ks, kt, ku, kv, ls, ns, nw; + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + char jbcmpz[2]; + doublecomplex rtdisc; + integer nwupbd; + logical sorted; + extern /* Subroutine */ int zlahqr_(logical *, logical *, integer *, + integer *, integer *, doublecomplex *, integer *, doublecomplex *, + integer *, integer *, doublecomplex *, integer *, integer *), + zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + integer lwkopt; + doublecomplex tr2, det; + integer inf, kdu, nho, nve, kwh, nsr, nwr, kwv; + + +/* -- 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 */ + + +/* ================================================================ */ + + +/* ==== Matrices of order NTINY or smaller must be processed by */ +/* . ZLAHQR because of insufficient subdiagonal scratch space. */ +/* . (This is a hard limit.) ==== */ + +/* ==== Exceptional deflation windows: try to cure rare */ +/* . slow convergence by varying the size of the */ +/* . deflation window after KEXNW iterations. ==== */ + +/* ==== Exceptional shifts: try to cure rare slow convergence */ +/* . with ad-hoc exceptional shifts every KEXSH iterations. */ +/* . ==== */ + +/* ==== The constant WILK1 is used to form the exceptional */ +/* . shifts. ==== */ + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + + /* Function Body */ + *info = 0; + +/* ==== Quick return for N = 0: nothing to do. ==== */ + + if (*n == 0) { + work[1].r = 1., work[1].i = 0.; + return 0; + } + + if (*n <= 15) { + +/* ==== Tiny matrices must use ZLAHQR. ==== */ + + lwkopt = 1; + if (*lwork != -1) { + zlahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1], + iloz, ihiz, &z__[z_offset], ldz, info); + } + } else { + +/* ==== Use small bulge multi-shift QR with aggressive early */ +/* . deflation on larger-than-tiny matrices. ==== */ + +/* ==== Hope for the best. ==== */ + + *info = 0; + +/* ==== Set up job flags for ILAENV. ==== */ + + if (*wantt) { + *(unsigned char *)jbcmpz = 'S'; + } else { + *(unsigned char *)jbcmpz = 'E'; + } + if (*wantz) { + *(unsigned char *)&jbcmpz[1] = 'V'; + } else { + *(unsigned char *)&jbcmpz[1] = 'N'; + } + +/* ==== NWR = recommended deflation window size. At this */ +/* . point, N .GT. NTINY = 15, so there is enough */ +/* . subdiagonal workspace for NWR.GE.2 as required. */ +/* . (In fact, there is enough subdiagonal space for */ +/* . NWR.GE.4.) ==== */ + + nwr = ilaenv_(&c__13, "ZLAQR0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, + (ftnlen)2); + nwr = f2cmax(2,nwr); +/* Computing MIN */ + i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = f2cmin(i__1,i__2); + nwr = f2cmin(i__1,nwr); + +/* ==== NSR = recommended number of simultaneous shifts. */ +/* . At this point N .GT. NTINY = 15, so there is at */ +/* . enough subdiagonal workspace for NSR to be even */ +/* . and greater than or equal to two as required. ==== */ + + nsr = ilaenv_(&c__15, "ZLAQR0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, + (ftnlen)2); +/* Computing MIN */ + i__1 = nsr, i__2 = (*n - 3) / 6, i__1 = f2cmin(i__1,i__2), i__2 = *ihi - + *ilo; + nsr = f2cmin(i__1,i__2); +/* Computing MAX */ + i__1 = 2, i__2 = nsr - nsr % 2; + nsr = f2cmax(i__1,i__2); + +/* ==== Estimate optimal workspace ==== */ + +/* ==== Workspace query call to ZLAQR3 ==== */ + + i__1 = nwr + 1; + zlaqr3_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz, + ihiz, &z__[z_offset], ldz, &ls, &ld, &w[1], &h__[h_offset], + ldh, n, &h__[h_offset], ldh, n, &h__[h_offset], ldh, &work[1], + &c_n1); + +/* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR3) ==== */ + +/* Computing MAX */ + i__1 = nsr * 3 / 2, i__2 = (integer) work[1].r; + lwkopt = f2cmax(i__1,i__2); + +/* ==== Quick return in case of workspace query. ==== */ + + if (*lwork == -1) { + d__1 = (doublereal) lwkopt; + z__1.r = d__1, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + return 0; + } + +/* ==== ZLAHQR/ZLAQR0 crossover point ==== */ + + nmin = ilaenv_(&c__12, "ZLAQR0", jbcmpz, n, ilo, ihi, lwork, (ftnlen) + 6, (ftnlen)2); + nmin = f2cmax(15,nmin); + +/* ==== Nibble crossover point ==== */ + + nibble = ilaenv_(&c__14, "ZLAQR0", jbcmpz, n, ilo, ihi, lwork, ( + ftnlen)6, (ftnlen)2); + nibble = f2cmax(0,nibble); + +/* ==== Accumulate reflections during ttswp? Use block */ +/* . 2-by-2 structure during matrix-matrix multiply? ==== */ + + kacc22 = ilaenv_(&c__16, "ZLAQR0", jbcmpz, n, ilo, ihi, lwork, ( + ftnlen)6, (ftnlen)2); + kacc22 = f2cmax(0,kacc22); + kacc22 = f2cmin(2,kacc22); + +/* ==== NWMAX = the largest possible deflation window for */ +/* . which there is sufficient workspace. ==== */ + +/* Computing MIN */ + i__1 = (*n - 1) / 3, i__2 = *lwork / 2; + nwmax = f2cmin(i__1,i__2); + nw = nwmax; + +/* ==== NSMAX = the Largest number of simultaneous shifts */ +/* . for which there is sufficient workspace. ==== */ + +/* Computing MIN */ + i__1 = (*n - 3) / 6, i__2 = (*lwork << 1) / 3; + nsmax = f2cmin(i__1,i__2); + nsmax -= nsmax % 2; + +/* ==== NDFL: an iteration count restarted at deflation. ==== */ + + ndfl = 1; + +/* ==== ITMAX = iteration limit ==== */ + +/* Computing MAX */ + i__1 = 10, i__2 = *ihi - *ilo + 1; + itmax = 30 * f2cmax(i__1,i__2); + +/* ==== Last row and column in the active block ==== */ + + kbot = *ihi; + +/* ==== Main Loop ==== */ + + i__1 = itmax; + for (it = 1; it <= i__1; ++it) { + +/* ==== Done when KBOT falls below ILO ==== */ + + if (kbot < *ilo) { + goto L80; + } + +/* ==== Locate active block ==== */ + + i__2 = *ilo + 1; + for (k = kbot; k >= i__2; --k) { + i__3 = k + (k - 1) * h_dim1; + if (h__[i__3].r == 0. && h__[i__3].i == 0.) { + goto L20; + } +/* L10: */ + } + k = *ilo; +L20: + ktop = k; + +/* ==== Select deflation window size: */ +/* . Typical Case: */ +/* . If possible and advisable, nibble the entire */ +/* . active block. If not, use size MIN(NWR,NWMAX) */ +/* . or MIN(NWR+1,NWMAX) depending upon which has */ +/* . the smaller corresponding subdiagonal entry */ +/* . (a heuristic). */ +/* . */ +/* . Exceptional Case: */ +/* . If there have been no deflations in KEXNW or */ +/* . more iterations, then vary the deflation window */ +/* . size. At first, because, larger windows are, */ +/* . in general, more powerful than smaller ones, */ +/* . rapidly increase the window to the maximum possible. */ +/* . Then, gradually reduce the window size. ==== */ + + nh = kbot - ktop + 1; + nwupbd = f2cmin(nh,nwmax); + if (ndfl < 5) { + nw = f2cmin(nwupbd,nwr); + } else { +/* Computing MIN */ + i__2 = nwupbd, i__3 = nw << 1; + nw = f2cmin(i__2,i__3); + } + if (nw < nwmax) { + if (nw >= nh - 1) { + nw = nh; + } else { + kwtop = kbot - nw + 1; + i__2 = kwtop + (kwtop - 1) * h_dim1; + i__3 = kwtop - 1 + (kwtop - 2) * h_dim1; + if ((d__1 = h__[i__2].r, abs(d__1)) + (d__2 = d_imag(&h__[ + kwtop + (kwtop - 1) * h_dim1]), abs(d__2)) > ( + d__3 = h__[i__3].r, abs(d__3)) + (d__4 = d_imag(& + h__[kwtop - 1 + (kwtop - 2) * h_dim1]), abs(d__4)) + ) { + ++nw; + } + } + } + if (ndfl < 5) { + ndec = -1; + } else if (ndec >= 0 || nw >= nwupbd) { + ++ndec; + if (nw - ndec < 2) { + ndec = 0; + } + nw -= ndec; + } + +/* ==== Aggressive early deflation: */ +/* . split workspace under the subdiagonal into */ +/* . - an nw-by-nw work array V in the lower */ +/* . left-hand-corner, */ +/* . - an NW-by-at-least-NW-but-more-is-better */ +/* . (NW-by-NHO) horizontal work array along */ +/* . the bottom edge, */ +/* . - an at-least-NW-but-more-is-better (NHV-by-NW) */ +/* . vertical work array along the left-hand-edge. */ +/* . ==== */ + + kv = *n - nw + 1; + kt = nw + 1; + nho = *n - nw - 1 - kt + 1; + kwv = nw + 2; + nve = *n - nw - kwv + 1; + +/* ==== Aggressive early deflation ==== */ + + zlaqr3_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh, + iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &w[1], &h__[kv + + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1], ldh, &nve, & + h__[kwv + h_dim1], ldh, &work[1], lwork); + +/* ==== Adjust KBOT accounting for new deflations. ==== */ + + kbot -= ld; + +/* ==== KS points to the shifts. ==== */ + + ks = kbot - ls + 1; + +/* ==== Skip an expensive QR sweep if there is a (partly */ +/* . heuristic) reason to expect that many eigenvalues */ +/* . will deflate without it. Here, the QR sweep is */ +/* . skipped if many eigenvalues have just been deflated */ +/* . or if the remaining active block is small. */ + + if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > f2cmin( + nmin,nwmax)) { + +/* ==== NS = nominal number of simultaneous shifts. */ +/* . This may be lowered (slightly) if ZLAQR3 */ +/* . did not provide that many shifts. ==== */ + +/* Computing MIN */ +/* Computing MAX */ + i__4 = 2, i__5 = kbot - ktop; + i__2 = f2cmin(nsmax,nsr), i__3 = f2cmax(i__4,i__5); + ns = f2cmin(i__2,i__3); + ns -= ns % 2; + +/* ==== If there have been no deflations */ +/* . in a multiple of KEXSH iterations, */ +/* . then try exceptional shifts. */ +/* . Otherwise use shifts provided by */ +/* . ZLAQR3 above or from the eigenvalues */ +/* . of a trailing principal submatrix. ==== */ + + if (ndfl % 6 == 0) { + ks = kbot - ns + 1; + i__2 = ks + 1; + for (i__ = kbot; i__ >= i__2; i__ += -2) { + i__3 = i__; + i__4 = i__ + i__ * h_dim1; + i__5 = i__ + (i__ - 1) * h_dim1; + d__3 = ((d__1 = h__[i__5].r, abs(d__1)) + (d__2 = + d_imag(&h__[i__ + (i__ - 1) * h_dim1]), abs( + d__2))) * .75; + z__1.r = h__[i__4].r + d__3, z__1.i = h__[i__4].i; + w[i__3].r = z__1.r, w[i__3].i = z__1.i; + i__3 = i__ - 1; + i__4 = i__; + w[i__3].r = w[i__4].r, w[i__3].i = w[i__4].i; +/* L30: */ + } + } else { + +/* ==== Got NS/2 or fewer shifts? Use ZLAQR4 or */ +/* . ZLAHQR on a trailing principal submatrix to */ +/* . get more. (Since NS.LE.NSMAX.LE.(N-3)/6, */ +/* . there is enough space below the subdiagonal */ +/* . to fit an NS-by-NS scratch array.) ==== */ + + if (kbot - ks + 1 <= ns / 2) { + ks = kbot - ns + 1; + kt = *n - ns + 1; + zlacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, & + h__[kt + h_dim1], ldh); + if (ns > nmin) { + zlaqr4_(&c_false, &c_false, &ns, &c__1, &ns, &h__[ + kt + h_dim1], ldh, &w[ks], &c__1, &c__1, + zdum, &c__1, &work[1], lwork, &inf); + } else { + zlahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[ + kt + h_dim1], ldh, &w[ks], &c__1, &c__1, + zdum, &c__1, &inf); + } + ks += inf; + +/* ==== In case of a rare QR failure use */ +/* . eigenvalues of the trailing 2-by-2 */ +/* . principal submatrix. Scale to avoid */ +/* . overflows, underflows and subnormals. */ +/* . (The scale factor S can not be zero, */ +/* . because H(KBOT,KBOT-1) is nonzero.) ==== */ + + if (ks >= kbot) { + i__2 = kbot - 1 + (kbot - 1) * h_dim1; + i__3 = kbot + (kbot - 1) * h_dim1; + i__4 = kbot - 1 + kbot * h_dim1; + i__5 = kbot + kbot * h_dim1; + s = (d__1 = h__[i__2].r, abs(d__1)) + (d__2 = + d_imag(&h__[kbot - 1 + (kbot - 1) * + h_dim1]), abs(d__2)) + ((d__3 = h__[i__3] + .r, abs(d__3)) + (d__4 = d_imag(&h__[kbot + + (kbot - 1) * h_dim1]), abs(d__4))) + (( + d__5 = h__[i__4].r, abs(d__5)) + (d__6 = + d_imag(&h__[kbot - 1 + kbot * h_dim1]), + abs(d__6))) + ((d__7 = h__[i__5].r, abs( + d__7)) + (d__8 = d_imag(&h__[kbot + kbot * + h_dim1]), abs(d__8))); + i__2 = kbot - 1 + (kbot - 1) * h_dim1; + z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i / + s; + aa.r = z__1.r, aa.i = z__1.i; + i__2 = kbot + (kbot - 1) * h_dim1; + z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i / + s; + cc.r = z__1.r, cc.i = z__1.i; + i__2 = kbot - 1 + kbot * h_dim1; + z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i / + s; + bb.r = z__1.r, bb.i = z__1.i; + i__2 = kbot + kbot * h_dim1; + z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i / + s; + dd.r = z__1.r, dd.i = z__1.i; + z__2.r = aa.r + dd.r, z__2.i = aa.i + dd.i; + z__1.r = z__2.r / 2., z__1.i = z__2.i / 2.; + tr2.r = z__1.r, tr2.i = z__1.i; + z__3.r = aa.r - tr2.r, z__3.i = aa.i - tr2.i; + z__4.r = dd.r - tr2.r, z__4.i = dd.i - tr2.i; + z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, + z__2.i = z__3.r * z__4.i + z__3.i * + z__4.r; + z__5.r = bb.r * cc.r - bb.i * cc.i, z__5.i = bb.r + * cc.i + bb.i * cc.r; + z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - + z__5.i; + det.r = z__1.r, det.i = z__1.i; + z__2.r = -det.r, z__2.i = -det.i; + z_sqrt(&z__1, &z__2); + rtdisc.r = z__1.r, rtdisc.i = z__1.i; + i__2 = kbot - 1; + z__2.r = tr2.r + rtdisc.r, z__2.i = tr2.i + + rtdisc.i; + z__1.r = s * z__2.r, z__1.i = s * z__2.i; + w[i__2].r = z__1.r, w[i__2].i = z__1.i; + i__2 = kbot; + z__2.r = tr2.r - rtdisc.r, z__2.i = tr2.i - + rtdisc.i; + z__1.r = s * z__2.r, z__1.i = s * z__2.i; + w[i__2].r = z__1.r, w[i__2].i = z__1.i; + + ks = kbot - 1; + } + } + + if (kbot - ks + 1 > ns) { + +/* ==== Sort the shifts (Helps a little) ==== */ + + sorted = FALSE_; + i__2 = ks + 1; + for (k = kbot; k >= i__2; --k) { + if (sorted) { + goto L60; + } + sorted = TRUE_; + i__3 = k - 1; + for (i__ = ks; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__ + 1; + if ((d__1 = w[i__4].r, abs(d__1)) + (d__2 = + d_imag(&w[i__]), abs(d__2)) < (d__3 = + w[i__5].r, abs(d__3)) + (d__4 = + d_imag(&w[i__ + 1]), abs(d__4))) { + sorted = FALSE_; + i__4 = i__; + swap.r = w[i__4].r, swap.i = w[i__4].i; + i__4 = i__; + i__5 = i__ + 1; + w[i__4].r = w[i__5].r, w[i__4].i = w[i__5] + .i; + i__4 = i__ + 1; + w[i__4].r = swap.r, w[i__4].i = swap.i; + } +/* L40: */ + } +/* L50: */ + } +L60: + ; + } + } + +/* ==== If there are only two shifts, then use */ +/* . only one. ==== */ + + if (kbot - ks + 1 == 2) { + i__2 = kbot; + i__3 = kbot + kbot * h_dim1; + z__2.r = w[i__2].r - h__[i__3].r, z__2.i = w[i__2].i - + h__[i__3].i; + z__1.r = z__2.r, z__1.i = z__2.i; + i__4 = kbot - 1; + i__5 = kbot + kbot * h_dim1; + z__4.r = w[i__4].r - h__[i__5].r, z__4.i = w[i__4].i - + h__[i__5].i; + z__3.r = z__4.r, z__3.i = z__4.i; + if ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), + abs(d__2)) < (d__3 = z__3.r, abs(d__3)) + (d__4 = + d_imag(&z__3), abs(d__4))) { + i__2 = kbot - 1; + i__3 = kbot; + w[i__2].r = w[i__3].r, w[i__2].i = w[i__3].i; + } else { + i__2 = kbot; + i__3 = kbot - 1; + w[i__2].r = w[i__3].r, w[i__2].i = w[i__3].i; + } + } + +/* ==== Use up to NS of the the smallest magnitude */ +/* . shifts. If there aren't NS shifts available, */ +/* . then use them all, possibly dropping one to */ +/* . make the number of shifts even. ==== */ + +/* Computing MIN */ + i__2 = ns, i__3 = kbot - ks + 1; + ns = f2cmin(i__2,i__3); + ns -= ns % 2; + ks = kbot - ns + 1; + +/* ==== Small-bulge multi-shift QR sweep: */ +/* . split workspace under the subdiagonal into */ +/* . - a KDU-by-KDU work array U in the lower */ +/* . left-hand-corner, */ +/* . - a KDU-by-at-least-KDU-but-more-is-better */ +/* . (KDU-by-NHo) horizontal work array WH along */ +/* . the bottom edge, */ +/* . - and an at-least-KDU-but-more-is-better-by-KDU */ +/* . (NVE-by-KDU) vertical work WV arrow along */ +/* . the left-hand-edge. ==== */ + + kdu = ns << 1; + ku = *n - kdu + 1; + kwh = kdu + 1; + nho = *n - kdu - 3 - (kdu + 1) + 1; + kwv = kdu + 4; + nve = *n - kdu - kwv + 1; + +/* ==== Small-bulge multi-shift QR sweep ==== */ + + zlaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &w[ks], & + h__[h_offset], ldh, iloz, ihiz, &z__[z_offset], ldz, & + work[1], &c__3, &h__[ku + h_dim1], ldh, &nve, &h__[ + kwv + h_dim1], ldh, &nho, &h__[ku + kwh * h_dim1], + ldh); + } + +/* ==== Note progress (or the lack of it). ==== */ + + if (ld > 0) { + ndfl = 1; + } else { + ++ndfl; + } + +/* ==== End of main loop ==== */ +/* L70: */ + } + +/* ==== Iteration limit exceeded. Set INFO to show where */ +/* . the problem occurred and exit. ==== */ + + *info = kbot; +L80: + ; + } + +/* ==== Return the optimal value of LWORK. ==== */ + + d__1 = (doublereal) lwkopt; + z__1.r = d__1, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + +/* ==== End of ZLAQR0 ==== */ + + return 0; +} /* zlaqr0_ */ + diff --git a/lapack-netlib/SRC/zlaqr1.c b/lapack-netlib/SRC/zlaqr1.c new file mode 100644 index 000000000..ca04e1c13 --- /dev/null +++ b/lapack-netlib/SRC/zlaqr1.c @@ -0,0 +1,635 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAQR1 sets a scalar multiple of the first column of the product of 2-by-2 or 3-by-3 matrix H a +nd specified shifts. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAQR1 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAQR1( N, H, LDH, S1, S2, V ) */ + +/* COMPLEX*16 S1, S2 */ +/* INTEGER LDH, N */ +/* COMPLEX*16 H( LDH, * ), V( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Given a 2-by-2 or 3-by-3 matrix H, ZLAQR1 sets v to a */ +/* > scalar multiple of the first column of the product */ +/* > */ +/* > (*) K = (H - s1*I)*(H - s2*I) */ +/* > */ +/* > scaling to avoid overflows and most underflows. */ +/* > */ +/* > This is useful for starting double implicit shift bulges */ +/* > in the QR algorithm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Order of the matrix H. N must be either 2 or 3. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] H */ +/* > \verbatim */ +/* > H is COMPLEX*16 array, dimension (LDH,N) */ +/* > The 2-by-2 or 3-by-3 matrix H in (*). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > The leading dimension of H as declared in */ +/* > the calling procedure. LDH >= N */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S1 */ +/* > \verbatim */ +/* > S1 is COMPLEX*16 */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S2 */ +/* > \verbatim */ +/* > S2 is COMPLEX*16 */ +/* > */ +/* > S1 and S2 are the shifts defining K in (*) above. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is COMPLEX*16 array, dimension (N) */ +/* > A scalar multiple of the first column of the */ +/* > matrix K in (*). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Karen Braman and Ralph Byers, Department of Mathematics, */ +/* > University of Kansas, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlaqr1_(integer *n, doublecomplex *h__, integer *ldh, + doublecomplex *s1, doublecomplex *s2, doublecomplex *v) +{ + /* System generated locals */ + integer h_dim1, h_offset, i__1, i__2, i__3, i__4; + doublereal d__1, d__2, d__3, d__4, d__5, d__6; + doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8; + + /* Local variables */ + doublereal s; + doublecomplex h21s, h31s; + + +/* -- LAPACK auxiliary 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 */ + + +/* ================================================================ */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + --v; + + /* Function Body */ + if (*n != 2 && *n != 3) { + return 0; + } + + if (*n == 2) { + i__1 = h_dim1 + 1; + z__2.r = h__[i__1].r - s2->r, z__2.i = h__[i__1].i - s2->i; + z__1.r = z__2.r, z__1.i = z__2.i; + i__2 = h_dim1 + 2; + s = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), abs(d__2)) + ( + (d__3 = h__[i__2].r, abs(d__3)) + (d__4 = d_imag(&h__[h_dim1 + + 2]), abs(d__4))); + if (s == 0.) { + v[1].r = 0., v[1].i = 0.; + v[2].r = 0., v[2].i = 0.; + } else { + i__1 = h_dim1 + 2; + z__1.r = h__[i__1].r / s, z__1.i = h__[i__1].i / s; + h21s.r = z__1.r, h21s.i = z__1.i; + i__1 = (h_dim1 << 1) + 1; + z__2.r = h21s.r * h__[i__1].r - h21s.i * h__[i__1].i, z__2.i = + h21s.r * h__[i__1].i + h21s.i * h__[i__1].r; + i__2 = h_dim1 + 1; + z__4.r = h__[i__2].r - s1->r, z__4.i = h__[i__2].i - s1->i; + i__3 = h_dim1 + 1; + z__6.r = h__[i__3].r - s2->r, z__6.i = h__[i__3].i - s2->i; + z__5.r = z__6.r / s, z__5.i = z__6.i / s; + z__3.r = z__4.r * z__5.r - z__4.i * z__5.i, z__3.i = z__4.r * + z__5.i + z__4.i * z__5.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + v[1].r = z__1.r, v[1].i = z__1.i; + i__1 = h_dim1 + 1; + i__2 = (h_dim1 << 1) + 2; + z__4.r = h__[i__1].r + h__[i__2].r, z__4.i = h__[i__1].i + h__[ + i__2].i; + z__3.r = z__4.r - s1->r, z__3.i = z__4.i - s1->i; + z__2.r = z__3.r - s2->r, z__2.i = z__3.i - s2->i; + z__1.r = h21s.r * z__2.r - h21s.i * z__2.i, z__1.i = h21s.r * + z__2.i + h21s.i * z__2.r; + v[2].r = z__1.r, v[2].i = z__1.i; + } + } else { + i__1 = h_dim1 + 1; + z__2.r = h__[i__1].r - s2->r, z__2.i = h__[i__1].i - s2->i; + z__1.r = z__2.r, z__1.i = z__2.i; + i__2 = h_dim1 + 2; + i__3 = h_dim1 + 3; + s = (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), abs(d__2)) + ( + (d__3 = h__[i__2].r, abs(d__3)) + (d__4 = d_imag(&h__[h_dim1 + + 2]), abs(d__4))) + ((d__5 = h__[i__3].r, abs(d__5)) + (d__6 + = d_imag(&h__[h_dim1 + 3]), abs(d__6))); + if (s == 0.) { + v[1].r = 0., v[1].i = 0.; + v[2].r = 0., v[2].i = 0.; + v[3].r = 0., v[3].i = 0.; + } else { + i__1 = h_dim1 + 2; + z__1.r = h__[i__1].r / s, z__1.i = h__[i__1].i / s; + h21s.r = z__1.r, h21s.i = z__1.i; + i__1 = h_dim1 + 3; + z__1.r = h__[i__1].r / s, z__1.i = h__[i__1].i / s; + h31s.r = z__1.r, h31s.i = z__1.i; + i__1 = h_dim1 + 1; + z__4.r = h__[i__1].r - s1->r, z__4.i = h__[i__1].i - s1->i; + i__2 = h_dim1 + 1; + z__6.r = h__[i__2].r - s2->r, z__6.i = h__[i__2].i - s2->i; + z__5.r = z__6.r / s, z__5.i = z__6.i / s; + z__3.r = z__4.r * z__5.r - z__4.i * z__5.i, z__3.i = z__4.r * + z__5.i + z__4.i * z__5.r; + i__3 = (h_dim1 << 1) + 1; + z__7.r = h__[i__3].r * h21s.r - h__[i__3].i * h21s.i, z__7.i = + h__[i__3].r * h21s.i + h__[i__3].i * h21s.r; + z__2.r = z__3.r + z__7.r, z__2.i = z__3.i + z__7.i; + i__4 = h_dim1 * 3 + 1; + z__8.r = h__[i__4].r * h31s.r - h__[i__4].i * h31s.i, z__8.i = + h__[i__4].r * h31s.i + h__[i__4].i * h31s.r; + z__1.r = z__2.r + z__8.r, z__1.i = z__2.i + z__8.i; + v[1].r = z__1.r, v[1].i = z__1.i; + i__1 = h_dim1 + 1; + i__2 = (h_dim1 << 1) + 2; + z__5.r = h__[i__1].r + h__[i__2].r, z__5.i = h__[i__1].i + h__[ + i__2].i; + z__4.r = z__5.r - s1->r, z__4.i = z__5.i - s1->i; + z__3.r = z__4.r - s2->r, z__3.i = z__4.i - s2->i; + z__2.r = h21s.r * z__3.r - h21s.i * z__3.i, z__2.i = h21s.r * + z__3.i + h21s.i * z__3.r; + i__3 = h_dim1 * 3 + 2; + z__6.r = h__[i__3].r * h31s.r - h__[i__3].i * h31s.i, z__6.i = + h__[i__3].r * h31s.i + h__[i__3].i * h31s.r; + z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i; + v[2].r = z__1.r, v[2].i = z__1.i; + i__1 = h_dim1 + 1; + i__2 = h_dim1 * 3 + 3; + z__5.r = h__[i__1].r + h__[i__2].r, z__5.i = h__[i__1].i + h__[ + i__2].i; + z__4.r = z__5.r - s1->r, z__4.i = z__5.i - s1->i; + z__3.r = z__4.r - s2->r, z__3.i = z__4.i - s2->i; + z__2.r = h31s.r * z__3.r - h31s.i * z__3.i, z__2.i = h31s.r * + z__3.i + h31s.i * z__3.r; + i__3 = (h_dim1 << 1) + 3; + z__6.r = h21s.r * h__[i__3].r - h21s.i * h__[i__3].i, z__6.i = + h21s.r * h__[i__3].i + h21s.i * h__[i__3].r; + z__1.r = z__2.r + z__6.r, z__1.i = z__2.i + z__6.i; + v[3].r = z__1.r, v[3].i = z__1.i; + } + } + return 0; +} /* zlaqr1_ */ + diff --git a/lapack-netlib/SRC/zlaqr2.c b/lapack-netlib/SRC/zlaqr2.c new file mode 100644 index 000000000..0b0fe7616 --- /dev/null +++ b/lapack-netlib/SRC/zlaqr2.c @@ -0,0 +1,1095 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAQR2 performs the unitary similarity transformation of a Hessenberg matrix to detect and defl +ate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAQR2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, */ +/* IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, */ +/* NV, WV, LDWV, WORK, LWORK ) */ + +/* INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, */ +/* $ LDZ, LWORK, N, ND, NH, NS, NV, NW */ +/* LOGICAL WANTT, WANTZ */ +/* COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), */ +/* $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAQR2 is identical to ZLAQR3 except that it avoids */ +/* > recursion by calling ZLAHQR instead of ZLAQR4. */ +/* > */ +/* > Aggressive early deflation: */ +/* > */ +/* > ZLAQR2 accepts as input an upper Hessenberg matrix */ +/* > H and performs an unitary similarity transformation */ +/* > designed to detect and deflate fully converged eigenvalues from */ +/* > a trailing principal submatrix. On output H has been over- */ +/* > written by a new Hessenberg matrix that is a perturbation of */ +/* > an unitary similarity transformation of H. It is to be */ +/* > hoped that the final version of H has many zero subdiagonal */ +/* > entries. */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] WANTT */ +/* > \verbatim */ +/* > WANTT is LOGICAL */ +/* > If .TRUE., then the Hessenberg matrix H is fully updated */ +/* > so that the triangular Schur factor may be */ +/* > computed (in cooperation with the calling subroutine). */ +/* > If .FALSE., then only enough of H is updated to preserve */ +/* > the eigenvalues. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTZ */ +/* > \verbatim */ +/* > WANTZ is LOGICAL */ +/* > If .TRUE., then the unitary matrix Z is updated so */ +/* > so that the unitary Schur factor may be computed */ +/* > (in cooperation with the calling subroutine). */ +/* > If .FALSE., then Z is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix H and (if WANTZ is .TRUE.) the */ +/* > order of the unitary matrix Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KTOP */ +/* > \verbatim */ +/* > KTOP is INTEGER */ +/* > It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */ +/* > KBOT and KTOP together determine an isolated block */ +/* > along the diagonal of the Hessenberg matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KBOT */ +/* > \verbatim */ +/* > KBOT is INTEGER */ +/* > It is assumed without a check that either */ +/* > KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */ +/* > determine an isolated block along the diagonal of the */ +/* > Hessenberg matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NW */ +/* > \verbatim */ +/* > NW is INTEGER */ +/* > Deflation window size. 1 <= NW <= (KBOT-KTOP+1). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] H */ +/* > \verbatim */ +/* > H is COMPLEX*16 array, dimension (LDH,N) */ +/* > On input the initial N-by-N section of H stores the */ +/* > Hessenberg matrix undergoing aggressive early deflation. */ +/* > On output H has been transformed by a unitary */ +/* > similarity transformation, perturbed, and the returned */ +/* > to Hessenberg form that (it is to be hoped) has some */ +/* > zero subdiagonal entries. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > Leading dimension of H just as declared in the calling */ +/* > subroutine. N <= LDH */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILOZ */ +/* > \verbatim */ +/* > ILOZ is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHIZ */ +/* > \verbatim */ +/* > IHIZ is INTEGER */ +/* > Specify the rows of Z to which transformations must be */ +/* > applied if WANTZ is .TRUE.. 1 <= ILOZ <= IHIZ <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX*16 array, dimension (LDZ,N) */ +/* > IF WANTZ is .TRUE., then on output, the unitary */ +/* > similarity transformation mentioned above has been */ +/* > accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. */ +/* > If WANTZ is .FALSE., then Z is unreferenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of Z just as declared in the */ +/* > calling subroutine. 1 <= LDZ. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] NS */ +/* > \verbatim */ +/* > NS is INTEGER */ +/* > The number of unconverged (ie approximate) eigenvalues */ +/* > returned in SR and SI that may be used as shifts by the */ +/* > calling subroutine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ND */ +/* > \verbatim */ +/* > ND is INTEGER */ +/* > The number of converged eigenvalues uncovered by this */ +/* > subroutine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SH */ +/* > \verbatim */ +/* > SH is COMPLEX*16 array, dimension (KBOT) */ +/* > On output, approximate eigenvalues that may */ +/* > be used for shifts are stored in SH(KBOT-ND-NS+1) */ +/* > through SR(KBOT-ND). Converged eigenvalues are */ +/* > stored in SH(KBOT-ND+1) through SH(KBOT). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is COMPLEX*16 array, dimension (LDV,NW) */ +/* > An NW-by-NW work array. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of V just as declared in the */ +/* > calling subroutine. NW <= LDV */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NH */ +/* > \verbatim */ +/* > NH is INTEGER */ +/* > The number of columns of T. NH >= NW. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is COMPLEX*16 array, dimension (LDT,NW) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of T just as declared in the */ +/* > calling subroutine. NW <= LDT */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NV */ +/* > \verbatim */ +/* > NV is INTEGER */ +/* > The number of rows of work array WV available for */ +/* > workspace. NV >= NW. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WV */ +/* > \verbatim */ +/* > WV is COMPLEX*16 array, dimension (LDWV,NW) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDWV */ +/* > \verbatim */ +/* > LDWV is INTEGER */ +/* > The leading dimension of W just as declared in the */ +/* > calling subroutine. NW <= LDV */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (LWORK) */ +/* > On exit, WORK(1) is set to an estimate of the optimal value */ +/* > of LWORK for the given values of N, NW, KTOP and KBOT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the work array WORK. LWORK = 2*NW */ +/* > suffices, but greater efficiency may result from larger */ +/* > values of LWORK. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; ZLAQR2 */ +/* > only estimates the optimal workspace size for the given */ +/* > values of N, NW, KTOP and KBOT. The estimate is returned */ +/* > in WORK(1). No error message related to LWORK is issued */ +/* > by XERBLA. Neither H nor Z are accessed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Karen Braman and Ralph Byers, Department of Mathematics, */ +/* > University of Kansas, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlaqr2_(logical *wantt, logical *wantz, integer *n, + integer *ktop, integer *kbot, integer *nw, doublecomplex *h__, + integer *ldh, integer *iloz, integer *ihiz, doublecomplex *z__, + integer *ldz, integer *ns, integer *nd, doublecomplex *sh, + doublecomplex *v, integer *ldv, integer *nh, doublecomplex *t, + integer *ldt, integer *nv, doublecomplex *wv, integer *ldwv, + doublecomplex *work, integer *lwork) +{ + /* System generated locals */ + integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1, + wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4; + doublereal d__1, d__2, d__3, d__4, d__5, d__6; + doublecomplex z__1, z__2; + + /* Local variables */ + doublecomplex beta; + integer kcol, info, ifst, ilst, ltop, krow, i__, j; + doublecomplex s; + extern /* Subroutine */ int zlarf_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *); + integer infqr; + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + integer kwtop; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), dlabad_(doublereal *, doublereal *); + extern doublereal dlamch_(char *); + integer jw; + doublereal safmin, safmax; + extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *), zlarfg_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *), zlahqr_(logical *, + logical *, integer *, integer *, integer *, doublecomplex *, + integer *, doublecomplex *, integer *, integer *, doublecomplex *, + integer *, integer *), zlacpy_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *), + zlaset_(char *, integer *, integer *, doublecomplex *, + doublecomplex *, doublecomplex *, integer *); + doublereal smlnum; + extern /* Subroutine */ int ztrexc_(char *, integer *, doublecomplex *, + integer *, doublecomplex *, integer *, integer *, integer *, + integer *); + integer lwkopt; + extern /* Subroutine */ int zunmhr_(char *, char *, integer *, integer *, + integer *, integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer * + ); + doublereal foo; + integer kln; + doublecomplex tau; + integer knt; + doublereal ulp; + integer lwk1, lwk2; + + +/* -- LAPACK auxiliary 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 */ + + +/* ================================================================ */ + + +/* ==== Estimate optimal workspace. ==== */ + + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --sh; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + wv_dim1 = *ldwv; + wv_offset = 1 + wv_dim1 * 1; + wv -= wv_offset; + --work; + + /* Function Body */ +/* Computing MIN */ + i__1 = *nw, i__2 = *kbot - *ktop + 1; + jw = f2cmin(i__1,i__2); + if (jw <= 2) { + lwkopt = 1; + } else { + +/* ==== Workspace query call to ZGEHRD ==== */ + + i__1 = jw - 1; + zgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & + c_n1, &info); + lwk1 = (integer) work[1].r; + +/* ==== Workspace query call to ZUNMHR ==== */ + + i__1 = jw - 1; + zunmhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], + &v[v_offset], ldv, &work[1], &c_n1, &info); + lwk2 = (integer) work[1].r; + +/* ==== Optimal workspace ==== */ + + lwkopt = jw + f2cmax(lwk1,lwk2); + } + +/* ==== Quick return in case of workspace query. ==== */ + + if (*lwork == -1) { + d__1 = (doublereal) lwkopt; + z__1.r = d__1, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + return 0; + } + +/* ==== Nothing to do ... */ +/* ... for an empty active block ... ==== */ + *ns = 0; + *nd = 0; + work[1].r = 1., work[1].i = 0.; + if (*ktop > *kbot) { + return 0; + } +/* ... nor for an empty deflation window. ==== */ + if (*nw < 1) { + return 0; + } + +/* ==== Machine constants ==== */ + + safmin = dlamch_("SAFE MINIMUM"); + safmax = 1. / safmin; + dlabad_(&safmin, &safmax); + ulp = dlamch_("PRECISION"); + smlnum = safmin * ((doublereal) (*n) / ulp); + +/* ==== Setup deflation window ==== */ + +/* Computing MIN */ + i__1 = *nw, i__2 = *kbot - *ktop + 1; + jw = f2cmin(i__1,i__2); + kwtop = *kbot - jw + 1; + if (kwtop == *ktop) { + s.r = 0., s.i = 0.; + } else { + i__1 = kwtop + (kwtop - 1) * h_dim1; + s.r = h__[i__1].r, s.i = h__[i__1].i; + } + + if (*kbot == kwtop) { + +/* ==== 1-by-1 deflation window: not much to do ==== */ + + i__1 = kwtop; + i__2 = kwtop + kwtop * h_dim1; + sh[i__1].r = h__[i__2].r, sh[i__1].i = h__[i__2].i; + *ns = 1; + *nd = 0; +/* Computing MAX */ + i__1 = kwtop + kwtop * h_dim1; + d__5 = smlnum, d__6 = ulp * ((d__1 = h__[i__1].r, abs(d__1)) + (d__2 = + d_imag(&h__[kwtop + kwtop * h_dim1]), abs(d__2))); + if ((d__3 = s.r, abs(d__3)) + (d__4 = d_imag(&s), abs(d__4)) <= f2cmax( + d__5,d__6)) { + *ns = 0; + *nd = 1; + if (kwtop > *ktop) { + i__1 = kwtop + (kwtop - 1) * h_dim1; + h__[i__1].r = 0., h__[i__1].i = 0.; + } + } + work[1].r = 1., work[1].i = 0.; + return 0; + } + +/* ==== Convert to spike-triangular form. (In case of a */ +/* . rare QR failure, this routine continues to do */ +/* . aggressive early deflation using that part of */ +/* . the deflation window that converged using INFQR */ +/* . here and there to keep track.) ==== */ + + zlacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset], + ldt); + i__1 = jw - 1; + i__2 = *ldh + 1; + i__3 = *ldt + 1; + zcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], & + i__3); + + zlaset_("A", &jw, &jw, &c_b1, &c_b2, &v[v_offset], ldv); + zlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[kwtop], + &c__1, &jw, &v[v_offset], ldv, &infqr); + +/* ==== Deflation detection loop ==== */ + + *ns = jw; + ilst = infqr + 1; + i__1 = jw; + for (knt = infqr + 1; knt <= i__1; ++knt) { + +/* ==== Small spike tip deflation test ==== */ + + i__2 = *ns + *ns * t_dim1; + foo = (d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&t[*ns + *ns * + t_dim1]), abs(d__2)); + if (foo == 0.) { + foo = (d__1 = s.r, abs(d__1)) + (d__2 = d_imag(&s), abs(d__2)); + } + i__2 = *ns * v_dim1 + 1; +/* Computing MAX */ + d__5 = smlnum, d__6 = ulp * foo; + if (((d__1 = s.r, abs(d__1)) + (d__2 = d_imag(&s), abs(d__2))) * (( + d__3 = v[i__2].r, abs(d__3)) + (d__4 = d_imag(&v[*ns * v_dim1 + + 1]), abs(d__4))) <= f2cmax(d__5,d__6)) { + +/* ==== One more converged eigenvalue ==== */ + + --(*ns); + } else { + +/* ==== One undeflatable eigenvalue. Move it up out of the */ +/* . way. (ZTREXC can not fail in this case.) ==== */ + + ifst = *ns; + ztrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, & + ilst, &info); + ++ilst; + } +/* L10: */ + } + +/* ==== Return to Hessenberg form ==== */ + + if (*ns == 0) { + s.r = 0., s.i = 0.; + } + + if (*ns < jw) { + +/* ==== sorting the diagonal of T improves accuracy for */ +/* . graded matrices. ==== */ + + i__1 = *ns; + for (i__ = infqr + 1; i__ <= i__1; ++i__) { + ifst = i__; + i__2 = *ns; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = j + j * t_dim1; + i__4 = ifst + ifst * t_dim1; + if ((d__1 = t[i__3].r, abs(d__1)) + (d__2 = d_imag(&t[j + j * + t_dim1]), abs(d__2)) > (d__3 = t[i__4].r, abs(d__3)) + + (d__4 = d_imag(&t[ifst + ifst * t_dim1]), abs(d__4)) + ) { + ifst = j; + } +/* L20: */ + } + ilst = i__; + if (ifst != ilst) { + ztrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, + &ilst, &info); + } +/* L30: */ + } + } + +/* ==== Restore shift/eigenvalue array from T ==== */ + + i__1 = jw; + for (i__ = infqr + 1; i__ <= i__1; ++i__) { + i__2 = kwtop + i__ - 1; + i__3 = i__ + i__ * t_dim1; + sh[i__2].r = t[i__3].r, sh[i__2].i = t[i__3].i; +/* L40: */ + } + + + if (*ns < jw || s.r == 0. && s.i == 0.) { + if (*ns > 1 && (s.r != 0. || s.i != 0.)) { + +/* ==== Reflect spike back into lower triangle ==== */ + + zcopy_(ns, &v[v_offset], ldv, &work[1], &c__1); + i__1 = *ns; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + d_cnjg(&z__1, &work[i__]); + work[i__2].r = z__1.r, work[i__2].i = z__1.i; +/* L50: */ + } + beta.r = work[1].r, beta.i = work[1].i; + zlarfg_(ns, &beta, &work[2], &c__1, &tau); + work[1].r = 1., work[1].i = 0.; + + i__1 = jw - 2; + i__2 = jw - 2; + zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &t[t_dim1 + 3], ldt); + + d_cnjg(&z__1, &tau); + zlarf_("L", ns, &jw, &work[1], &c__1, &z__1, &t[t_offset], ldt, & + work[jw + 1]); + zlarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, & + work[jw + 1]); + zlarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, & + work[jw + 1]); + + i__1 = *lwork - jw; + zgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1] + , &i__1, &info); + } + +/* ==== Copy updated reduced window into place ==== */ + + if (kwtop > 1) { + i__1 = kwtop + (kwtop - 1) * h_dim1; + d_cnjg(&z__2, &v[v_dim1 + 1]); + z__1.r = s.r * z__2.r - s.i * z__2.i, z__1.i = s.r * z__2.i + s.i + * z__2.r; + h__[i__1].r = z__1.r, h__[i__1].i = z__1.i; + } + zlacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1] + , ldh); + i__1 = jw - 1; + i__2 = *ldt + 1; + i__3 = *ldh + 1; + zcopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1], + &i__3); + +/* ==== Accumulate orthogonal matrix in order update */ +/* . H and Z, if requested. ==== */ + + if (*ns > 1 && (s.r != 0. || s.i != 0.)) { + i__1 = *lwork - jw; + zunmhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1], + &v[v_offset], ldv, &work[jw + 1], &i__1, &info); + } + +/* ==== Update vertical slab in H ==== */ + + if (*wantt) { + ltop = 1; + } else { + ltop = *ktop; + } + i__1 = kwtop - 1; + i__2 = *nv; + for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += + i__2) { +/* Computing MIN */ + i__3 = *nv, i__4 = kwtop - krow; + kln = f2cmin(i__3,i__4); + zgemm_("N", "N", &kln, &jw, &jw, &c_b2, &h__[krow + kwtop * + h_dim1], ldh, &v[v_offset], ldv, &c_b1, &wv[wv_offset], + ldwv); + zlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * + h_dim1], ldh); +/* L60: */ + } + +/* ==== Update horizontal slab in H ==== */ + + if (*wantt) { + i__2 = *n; + i__1 = *nh; + for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2; + kcol += i__1) { +/* Computing MIN */ + i__3 = *nh, i__4 = *n - kcol + 1; + kln = f2cmin(i__3,i__4); + zgemm_("C", "N", &jw, &kln, &jw, &c_b2, &v[v_offset], ldv, & + h__[kwtop + kcol * h_dim1], ldh, &c_b1, &t[t_offset], + ldt); + zlacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * + h_dim1], ldh); +/* L70: */ + } + } + +/* ==== Update vertical slab in Z ==== */ + + if (*wantz) { + i__1 = *ihiz; + i__2 = *nv; + for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += + i__2) { +/* Computing MIN */ + i__3 = *nv, i__4 = *ihiz - krow + 1; + kln = f2cmin(i__3,i__4); + zgemm_("N", "N", &kln, &jw, &jw, &c_b2, &z__[krow + kwtop * + z_dim1], ldz, &v[v_offset], ldv, &c_b1, &wv[wv_offset] + , ldwv); + zlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + + kwtop * z_dim1], ldz); +/* L80: */ + } + } + } + +/* ==== Return the number of deflations ... ==== */ + + *nd = jw - *ns; + +/* ==== ... and the number of shifts. (Subtracting */ +/* . INFQR from the spike length takes care */ +/* . of the case of a rare QR failure while */ +/* . calculating eigenvalues of the deflation */ +/* . window.) ==== */ + + *ns -= infqr; + +/* ==== Return optimal workspace. ==== */ + + d__1 = (doublereal) lwkopt; + z__1.r = d__1, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + +/* ==== End of ZLAQR2 ==== */ + + return 0; +} /* zlaqr2_ */ + diff --git a/lapack-netlib/SRC/zlaqr3.c b/lapack-netlib/SRC/zlaqr3.c new file mode 100644 index 000000000..34fdc35d7 --- /dev/null +++ b/lapack-netlib/SRC/zlaqr3.c @@ -0,0 +1,1115 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAQR3 performs the unitary similarity transformation of a Hessenberg matrix to detect and defl +ate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAQR3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, */ +/* IHIZ, Z, LDZ, NS, ND, SH, V, LDV, NH, T, LDT, */ +/* NV, WV, LDWV, WORK, LWORK ) */ + +/* INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, */ +/* $ LDZ, LWORK, N, ND, NH, NS, NV, NW */ +/* LOGICAL WANTT, WANTZ */ +/* COMPLEX*16 H( LDH, * ), SH( * ), T( LDT, * ), V( LDV, * ), */ +/* $ WORK( * ), WV( LDWV, * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Aggressive early deflation: */ +/* > */ +/* > ZLAQR3 accepts as input an upper Hessenberg matrix */ +/* > H and performs an unitary similarity transformation */ +/* > designed to detect and deflate fully converged eigenvalues from */ +/* > a trailing principal submatrix. On output H has been over- */ +/* > written by a new Hessenberg matrix that is a perturbation of */ +/* > an unitary similarity transformation of H. It is to be */ +/* > hoped that the final version of H has many zero subdiagonal */ +/* > entries. */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] WANTT */ +/* > \verbatim */ +/* > WANTT is LOGICAL */ +/* > If .TRUE., then the Hessenberg matrix H is fully updated */ +/* > so that the triangular Schur factor may be */ +/* > computed (in cooperation with the calling subroutine). */ +/* > If .FALSE., then only enough of H is updated to preserve */ +/* > the eigenvalues. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTZ */ +/* > \verbatim */ +/* > WANTZ is LOGICAL */ +/* > If .TRUE., then the unitary matrix Z is updated so */ +/* > so that the unitary Schur factor may be computed */ +/* > (in cooperation with the calling subroutine). */ +/* > If .FALSE., then Z is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix H and (if WANTZ is .TRUE.) the */ +/* > order of the unitary matrix Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KTOP */ +/* > \verbatim */ +/* > KTOP is INTEGER */ +/* > It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */ +/* > KBOT and KTOP together determine an isolated block */ +/* > along the diagonal of the Hessenberg matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KBOT */ +/* > \verbatim */ +/* > KBOT is INTEGER */ +/* > It is assumed without a check that either */ +/* > KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */ +/* > determine an isolated block along the diagonal of the */ +/* > Hessenberg matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NW */ +/* > \verbatim */ +/* > NW is INTEGER */ +/* > Deflation window size. 1 <= NW <= (KBOT-KTOP+1). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] H */ +/* > \verbatim */ +/* > H is COMPLEX*16 array, dimension (LDH,N) */ +/* > On input the initial N-by-N section of H stores the */ +/* > Hessenberg matrix undergoing aggressive early deflation. */ +/* > On output H has been transformed by a unitary */ +/* > similarity transformation, perturbed, and the returned */ +/* > to Hessenberg form that (it is to be hoped) has some */ +/* > zero subdiagonal entries. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > Leading dimension of H just as declared in the calling */ +/* > subroutine. N <= LDH */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILOZ */ +/* > \verbatim */ +/* > ILOZ is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHIZ */ +/* > \verbatim */ +/* > IHIZ is INTEGER */ +/* > Specify the rows of Z to which transformations must be */ +/* > applied if WANTZ is .TRUE.. 1 <= ILOZ <= IHIZ <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX*16 array, dimension (LDZ,N) */ +/* > IF WANTZ is .TRUE., then on output, the unitary */ +/* > similarity transformation mentioned above has been */ +/* > accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. */ +/* > If WANTZ is .FALSE., then Z is unreferenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of Z just as declared in the */ +/* > calling subroutine. 1 <= LDZ. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] NS */ +/* > \verbatim */ +/* > NS is INTEGER */ +/* > The number of unconverged (ie approximate) eigenvalues */ +/* > returned in SR and SI that may be used as shifts by the */ +/* > calling subroutine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ND */ +/* > \verbatim */ +/* > ND is INTEGER */ +/* > The number of converged eigenvalues uncovered by this */ +/* > subroutine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SH */ +/* > \verbatim */ +/* > SH is COMPLEX*16 array, dimension (KBOT) */ +/* > On output, approximate eigenvalues that may */ +/* > be used for shifts are stored in SH(KBOT-ND-NS+1) */ +/* > through SR(KBOT-ND). Converged eigenvalues are */ +/* > stored in SH(KBOT-ND+1) through SH(KBOT). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is COMPLEX*16 array, dimension (LDV,NW) */ +/* > An NW-by-NW work array. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of V just as declared in the */ +/* > calling subroutine. NW <= LDV */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NH */ +/* > \verbatim */ +/* > NH is INTEGER */ +/* > The number of columns of T. NH >= NW. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is COMPLEX*16 array, dimension (LDT,NW) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of T just as declared in the */ +/* > calling subroutine. NW <= LDT */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NV */ +/* > \verbatim */ +/* > NV is INTEGER */ +/* > The number of rows of work array WV available for */ +/* > workspace. NV >= NW. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WV */ +/* > \verbatim */ +/* > WV is COMPLEX*16 array, dimension (LDWV,NW) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDWV */ +/* > \verbatim */ +/* > LDWV is INTEGER */ +/* > The leading dimension of W just as declared in the */ +/* > calling subroutine. NW <= LDV */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (LWORK) */ +/* > On exit, WORK(1) is set to an estimate of the optimal value */ +/* > of LWORK for the given values of N, NW, KTOP and KBOT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the work array WORK. LWORK = 2*NW */ +/* > suffices, but greater efficiency may result from larger */ +/* > values of LWORK. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; ZLAQR3 */ +/* > only estimates the optimal workspace size for the given */ +/* > values of N, NW, KTOP and KBOT. The estimate is returned */ +/* > in WORK(1). No error message related to LWORK is issued */ +/* > by XERBLA. Neither H nor Z are accessed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Karen Braman and Ralph Byers, Department of Mathematics, */ +/* > University of Kansas, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlaqr3_(logical *wantt, logical *wantz, integer *n, + integer *ktop, integer *kbot, integer *nw, doublecomplex *h__, + integer *ldh, integer *iloz, integer *ihiz, doublecomplex *z__, + integer *ldz, integer *ns, integer *nd, doublecomplex *sh, + doublecomplex *v, integer *ldv, integer *nh, doublecomplex *t, + integer *ldt, integer *nv, doublecomplex *wv, integer *ldwv, + doublecomplex *work, integer *lwork) +{ + /* System generated locals */ + integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1, + wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4; + doublereal d__1, d__2, d__3, d__4, d__5, d__6; + doublecomplex z__1, z__2; + + /* Local variables */ + doublecomplex beta; + integer kcol, info, nmin, ifst, ilst, ltop, krow, i__, j; + doublecomplex s; + extern /* Subroutine */ int zlarf_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *); + integer infqr; + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + integer kwtop; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), dlabad_(doublereal *, doublereal *), + zlaqr4_(logical *, logical *, integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, integer * + ); + extern doublereal dlamch_(char *); + integer jw; + doublereal safmin, safmax; + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *), zlarfg_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *), zlahqr_(logical *, + logical *, integer *, integer *, integer *, doublecomplex *, + integer *, doublecomplex *, integer *, integer *, doublecomplex *, + integer *, integer *), zlacpy_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *), + zlaset_(char *, integer *, integer *, doublecomplex *, + doublecomplex *, doublecomplex *, integer *); + doublereal smlnum; + extern /* Subroutine */ int ztrexc_(char *, integer *, doublecomplex *, + integer *, doublecomplex *, integer *, integer *, integer *, + integer *); + integer lwkopt; + extern /* Subroutine */ int zunmhr_(char *, char *, integer *, integer *, + integer *, integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer * + ); + doublereal foo; + integer kln; + doublecomplex tau; + integer knt; + doublereal ulp; + integer lwk1, lwk2, lwk3; + + +/* -- LAPACK auxiliary 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 */ + + +/* ================================================================ */ + + +/* ==== Estimate optimal workspace. ==== */ + + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --sh; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + wv_dim1 = *ldwv; + wv_offset = 1 + wv_dim1 * 1; + wv -= wv_offset; + --work; + + /* Function Body */ +/* Computing MIN */ + i__1 = *nw, i__2 = *kbot - *ktop + 1; + jw = f2cmin(i__1,i__2); + if (jw <= 2) { + lwkopt = 1; + } else { + +/* ==== Workspace query call to ZGEHRD ==== */ + + i__1 = jw - 1; + zgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & + c_n1, &info); + lwk1 = (integer) work[1].r; + +/* ==== Workspace query call to ZUNMHR ==== */ + + i__1 = jw - 1; + zunmhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], + &v[v_offset], ldv, &work[1], &c_n1, &info); + lwk2 = (integer) work[1].r; + +/* ==== Workspace query call to ZLAQR4 ==== */ + + zlaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[1], + &c__1, &jw, &v[v_offset], ldv, &work[1], &c_n1, &infqr); + lwk3 = (integer) work[1].r; + +/* ==== Optimal workspace ==== */ + +/* Computing MAX */ + i__1 = jw + f2cmax(lwk1,lwk2); + lwkopt = f2cmax(i__1,lwk3); + } + +/* ==== Quick return in case of workspace query. ==== */ + + if (*lwork == -1) { + d__1 = (doublereal) lwkopt; + z__1.r = d__1, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + return 0; + } + +/* ==== Nothing to do ... */ +/* ... for an empty active block ... ==== */ + *ns = 0; + *nd = 0; + work[1].r = 1., work[1].i = 0.; + if (*ktop > *kbot) { + return 0; + } +/* ... nor for an empty deflation window. ==== */ + if (*nw < 1) { + return 0; + } + +/* ==== Machine constants ==== */ + + safmin = dlamch_("SAFE MINIMUM"); + safmax = 1. / safmin; + dlabad_(&safmin, &safmax); + ulp = dlamch_("PRECISION"); + smlnum = safmin * ((doublereal) (*n) / ulp); + +/* ==== Setup deflation window ==== */ + +/* Computing MIN */ + i__1 = *nw, i__2 = *kbot - *ktop + 1; + jw = f2cmin(i__1,i__2); + kwtop = *kbot - jw + 1; + if (kwtop == *ktop) { + s.r = 0., s.i = 0.; + } else { + i__1 = kwtop + (kwtop - 1) * h_dim1; + s.r = h__[i__1].r, s.i = h__[i__1].i; + } + + if (*kbot == kwtop) { + +/* ==== 1-by-1 deflation window: not much to do ==== */ + + i__1 = kwtop; + i__2 = kwtop + kwtop * h_dim1; + sh[i__1].r = h__[i__2].r, sh[i__1].i = h__[i__2].i; + *ns = 1; + *nd = 0; +/* Computing MAX */ + i__1 = kwtop + kwtop * h_dim1; + d__5 = smlnum, d__6 = ulp * ((d__1 = h__[i__1].r, abs(d__1)) + (d__2 = + d_imag(&h__[kwtop + kwtop * h_dim1]), abs(d__2))); + if ((d__3 = s.r, abs(d__3)) + (d__4 = d_imag(&s), abs(d__4)) <= f2cmax( + d__5,d__6)) { + *ns = 0; + *nd = 1; + if (kwtop > *ktop) { + i__1 = kwtop + (kwtop - 1) * h_dim1; + h__[i__1].r = 0., h__[i__1].i = 0.; + } + } + work[1].r = 1., work[1].i = 0.; + return 0; + } + +/* ==== Convert to spike-triangular form. (In case of a */ +/* . rare QR failure, this routine continues to do */ +/* . aggressive early deflation using that part of */ +/* . the deflation window that converged using INFQR */ +/* . here and there to keep track.) ==== */ + + zlacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset], + ldt); + i__1 = jw - 1; + i__2 = *ldh + 1; + i__3 = *ldt + 1; + zcopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], & + i__3); + + zlaset_("A", &jw, &jw, &c_b1, &c_b2, &v[v_offset], ldv); + nmin = ilaenv_(&c__12, "ZLAQR3", "SV", &jw, &c__1, &jw, lwork, (ftnlen)6, + (ftnlen)2); + if (jw > nmin) { + zlaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[ + kwtop], &c__1, &jw, &v[v_offset], ldv, &work[1], lwork, & + infqr); + } else { + zlahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sh[ + kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr); + } + +/* ==== Deflation detection loop ==== */ + + *ns = jw; + ilst = infqr + 1; + i__1 = jw; + for (knt = infqr + 1; knt <= i__1; ++knt) { + +/* ==== Small spike tip deflation test ==== */ + + i__2 = *ns + *ns * t_dim1; + foo = (d__1 = t[i__2].r, abs(d__1)) + (d__2 = d_imag(&t[*ns + *ns * + t_dim1]), abs(d__2)); + if (foo == 0.) { + foo = (d__1 = s.r, abs(d__1)) + (d__2 = d_imag(&s), abs(d__2)); + } + i__2 = *ns * v_dim1 + 1; +/* Computing MAX */ + d__5 = smlnum, d__6 = ulp * foo; + if (((d__1 = s.r, abs(d__1)) + (d__2 = d_imag(&s), abs(d__2))) * (( + d__3 = v[i__2].r, abs(d__3)) + (d__4 = d_imag(&v[*ns * v_dim1 + + 1]), abs(d__4))) <= f2cmax(d__5,d__6)) { + +/* ==== One more converged eigenvalue ==== */ + + --(*ns); + } else { + +/* ==== One undeflatable eigenvalue. Move it up out of the */ +/* . way. (ZTREXC can not fail in this case.) ==== */ + + ifst = *ns; + ztrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, & + ilst, &info); + ++ilst; + } +/* L10: */ + } + +/* ==== Return to Hessenberg form ==== */ + + if (*ns == 0) { + s.r = 0., s.i = 0.; + } + + if (*ns < jw) { + +/* ==== sorting the diagonal of T improves accuracy for */ +/* . graded matrices. ==== */ + + i__1 = *ns; + for (i__ = infqr + 1; i__ <= i__1; ++i__) { + ifst = i__; + i__2 = *ns; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = j + j * t_dim1; + i__4 = ifst + ifst * t_dim1; + if ((d__1 = t[i__3].r, abs(d__1)) + (d__2 = d_imag(&t[j + j * + t_dim1]), abs(d__2)) > (d__3 = t[i__4].r, abs(d__3)) + + (d__4 = d_imag(&t[ifst + ifst * t_dim1]), abs(d__4)) + ) { + ifst = j; + } +/* L20: */ + } + ilst = i__; + if (ifst != ilst) { + ztrexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, + &ilst, &info); + } +/* L30: */ + } + } + +/* ==== Restore shift/eigenvalue array from T ==== */ + + i__1 = jw; + for (i__ = infqr + 1; i__ <= i__1; ++i__) { + i__2 = kwtop + i__ - 1; + i__3 = i__ + i__ * t_dim1; + sh[i__2].r = t[i__3].r, sh[i__2].i = t[i__3].i; +/* L40: */ + } + + + if (*ns < jw || s.r == 0. && s.i == 0.) { + if (*ns > 1 && (s.r != 0. || s.i != 0.)) { + +/* ==== Reflect spike back into lower triangle ==== */ + + zcopy_(ns, &v[v_offset], ldv, &work[1], &c__1); + i__1 = *ns; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + d_cnjg(&z__1, &work[i__]); + work[i__2].r = z__1.r, work[i__2].i = z__1.i; +/* L50: */ + } + beta.r = work[1].r, beta.i = work[1].i; + zlarfg_(ns, &beta, &work[2], &c__1, &tau); + work[1].r = 1., work[1].i = 0.; + + i__1 = jw - 2; + i__2 = jw - 2; + zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &t[t_dim1 + 3], ldt); + + d_cnjg(&z__1, &tau); + zlarf_("L", ns, &jw, &work[1], &c__1, &z__1, &t[t_offset], ldt, & + work[jw + 1]); + zlarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, & + work[jw + 1]); + zlarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, & + work[jw + 1]); + + i__1 = *lwork - jw; + zgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1] + , &i__1, &info); + } + +/* ==== Copy updated reduced window into place ==== */ + + if (kwtop > 1) { + i__1 = kwtop + (kwtop - 1) * h_dim1; + d_cnjg(&z__2, &v[v_dim1 + 1]); + z__1.r = s.r * z__2.r - s.i * z__2.i, z__1.i = s.r * z__2.i + s.i + * z__2.r; + h__[i__1].r = z__1.r, h__[i__1].i = z__1.i; + } + zlacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1] + , ldh); + i__1 = jw - 1; + i__2 = *ldt + 1; + i__3 = *ldh + 1; + zcopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1], + &i__3); + +/* ==== Accumulate orthogonal matrix in order update */ +/* . H and Z, if requested. ==== */ + + if (*ns > 1 && (s.r != 0. || s.i != 0.)) { + i__1 = *lwork - jw; + zunmhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1], + &v[v_offset], ldv, &work[jw + 1], &i__1, &info); + } + +/* ==== Update vertical slab in H ==== */ + + if (*wantt) { + ltop = 1; + } else { + ltop = *ktop; + } + i__1 = kwtop - 1; + i__2 = *nv; + for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += + i__2) { +/* Computing MIN */ + i__3 = *nv, i__4 = kwtop - krow; + kln = f2cmin(i__3,i__4); + zgemm_("N", "N", &kln, &jw, &jw, &c_b2, &h__[krow + kwtop * + h_dim1], ldh, &v[v_offset], ldv, &c_b1, &wv[wv_offset], + ldwv); + zlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * + h_dim1], ldh); +/* L60: */ + } + +/* ==== Update horizontal slab in H ==== */ + + if (*wantt) { + i__2 = *n; + i__1 = *nh; + for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2; + kcol += i__1) { +/* Computing MIN */ + i__3 = *nh, i__4 = *n - kcol + 1; + kln = f2cmin(i__3,i__4); + zgemm_("C", "N", &jw, &kln, &jw, &c_b2, &v[v_offset], ldv, & + h__[kwtop + kcol * h_dim1], ldh, &c_b1, &t[t_offset], + ldt); + zlacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * + h_dim1], ldh); +/* L70: */ + } + } + +/* ==== Update vertical slab in Z ==== */ + + if (*wantz) { + i__1 = *ihiz; + i__2 = *nv; + for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += + i__2) { +/* Computing MIN */ + i__3 = *nv, i__4 = *ihiz - krow + 1; + kln = f2cmin(i__3,i__4); + zgemm_("N", "N", &kln, &jw, &jw, &c_b2, &z__[krow + kwtop * + z_dim1], ldz, &v[v_offset], ldv, &c_b1, &wv[wv_offset] + , ldwv); + zlacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + + kwtop * z_dim1], ldz); +/* L80: */ + } + } + } + +/* ==== Return the number of deflations ... ==== */ + + *nd = jw - *ns; + +/* ==== ... and the number of shifts. (Subtracting */ +/* . INFQR from the spike length takes care */ +/* . of the case of a rare QR failure while */ +/* . calculating eigenvalues of the deflation */ +/* . window.) ==== */ + + *ns -= infqr; + +/* ==== Return optimal workspace. ==== */ + + d__1 = (doublereal) lwkopt; + z__1.r = d__1, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + +/* ==== End of ZLAQR3 ==== */ + + return 0; +} /* zlaqr3_ */ + diff --git a/lapack-netlib/SRC/zlaqr4.c b/lapack-netlib/SRC/zlaqr4.c new file mode 100644 index 000000000..3d6e73234 --- /dev/null +++ b/lapack-netlib/SRC/zlaqr4.c @@ -0,0 +1,1243 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAQR4 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Sc +hur decomposition. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAQR4 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, W, ILOZ, */ +/* IHIZ, Z, LDZ, WORK, LWORK, INFO ) */ + +/* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N */ +/* LOGICAL WANTT, WANTZ */ +/* COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAQR4 implements one level of recursion for ZLAQR0. */ +/* > It is a complete implementation of the small bulge multi-shift */ +/* > QR algorithm. It may be called by ZLAQR0 and, for large enough */ +/* > deflation window size, it may be called by ZLAQR3. This */ +/* > subroutine is identical to ZLAQR0 except that it calls ZLAQR2 */ +/* > instead of ZLAQR3. */ +/* > */ +/* > ZLAQR4 computes the eigenvalues of a Hessenberg matrix H */ +/* > and, optionally, the matrices T and Z from the Schur decomposition */ +/* > H = Z T Z**H, where T is an upper triangular matrix (the */ +/* > Schur form), and Z is the unitary matrix of Schur vectors. */ +/* > */ +/* > Optionally Z may be postmultiplied into an input unitary */ +/* > matrix Q so that this routine can give the Schur factorization */ +/* > of a matrix A which has been reduced to the Hessenberg form H */ +/* > by the unitary matrix Q: A = Q*H*Q**H = (QZ)*H*(QZ)**H. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] WANTT */ +/* > \verbatim */ +/* > WANTT is LOGICAL */ +/* > = .TRUE. : the full Schur form T is required; */ +/* > = .FALSE.: only eigenvalues are required. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTZ */ +/* > \verbatim */ +/* > WANTZ is LOGICAL */ +/* > = .TRUE. : the matrix of Schur vectors Z is required; */ +/* > = .FALSE.: Schur vectors are not required. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix H. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILO */ +/* > \verbatim */ +/* > ILO is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHI */ +/* > \verbatim */ +/* > IHI is INTEGER */ +/* > It is assumed that H is already upper triangular in rows */ +/* > and columns 1:ILO-1 and IHI+1:N and, if ILO > 1, */ +/* > H(ILO,ILO-1) is zero. ILO and IHI are normally set by a */ +/* > previous call to ZGEBAL, and then passed to ZGEHRD when the */ +/* > matrix output by ZGEBAL is reduced to Hessenberg form. */ +/* > Otherwise, ILO and IHI should be set to 1 and N, */ +/* > respectively. If N > 0, then 1 <= ILO <= IHI <= N. */ +/* > If N = 0, then ILO = 1 and IHI = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] H */ +/* > \verbatim */ +/* > H is COMPLEX*16 array, dimension (LDH,N) */ +/* > On entry, the upper Hessenberg matrix H. */ +/* > On exit, if INFO = 0 and WANTT is .TRUE., then H */ +/* > contains the upper triangular matrix T from the Schur */ +/* > decomposition (the Schur form). If INFO = 0 and WANT is */ +/* > .FALSE., then the contents of H are unspecified on exit. */ +/* > (The output value of H when INFO > 0 is given under the */ +/* > description of INFO below.) */ +/* > */ +/* > This subroutine may explicitly set H(i,j) = 0 for i > j and */ +/* > j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > The leading dimension of the array H. LDH >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is COMPLEX*16 array, dimension (N) */ +/* > The computed eigenvalues of H(ILO:IHI,ILO:IHI) are stored */ +/* > in W(ILO:IHI). If WANTT is .TRUE., then the eigenvalues are */ +/* > stored in the same order as on the diagonal of the Schur */ +/* > form returned in H, with W(i) = H(i,i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILOZ */ +/* > \verbatim */ +/* > ILOZ is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHIZ */ +/* > \verbatim */ +/* > IHIZ is INTEGER */ +/* > Specify the rows of Z to which transformations must be */ +/* > applied if WANTZ is .TRUE.. */ +/* > 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX*16 array, dimension (LDZ,IHI) */ +/* > If WANTZ is .FALSE., then Z is not referenced. */ +/* > If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is */ +/* > replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the */ +/* > orthogonal Schur factor of H(ILO:IHI,ILO:IHI). */ +/* > (The output value of Z when INFO > 0 is given under */ +/* > the description of INFO below.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. if WANTZ is .TRUE. */ +/* > then LDZ >= MAX(1,IHIZ). Otherwise, LDZ >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension LWORK */ +/* > On exit, if LWORK = -1, WORK(1) returns an estimate of */ +/* > the optimal value for LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,N) */ +/* > is sufficient, but LWORK typically as large as 6*N may */ +/* > be required for optimal performance. A workspace query */ +/* > to determine the optimal workspace size is recommended. */ +/* > */ +/* > If LWORK = -1, then ZLAQR4 does a workspace query. */ +/* > In this case, ZLAQR4 checks the input parameters and */ +/* > estimates the optimal workspace size for the given */ +/* > values of N, ILO and IHI. The estimate is returned */ +/* > in WORK(1). No error message related to LWORK is */ +/* > issued by XERBLA. Neither H nor Z are accessed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > > 0: if INFO = i, ZLAQR4 failed to compute all of */ +/* > the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */ +/* > and WI contain those eigenvalues which have been */ +/* > successfully computed. (Failures are rare.) */ +/* > */ +/* > If INFO > 0 and WANT is .FALSE., then on exit, */ +/* > the remaining unconverged eigenvalues are the eigen- */ +/* > values of the upper Hessenberg matrix rows and */ +/* > columns ILO through INFO of the final, output */ +/* > value of H. */ +/* > */ +/* > If INFO > 0 and WANTT is .TRUE., then on exit */ +/* > */ +/* > (*) (initial value of H)*U = U*(final value of H) */ +/* > */ +/* > where U is a unitary matrix. The final */ +/* > value of H is upper Hessenberg and triangular in */ +/* > rows and columns INFO+1 through IHI. */ +/* > */ +/* > If INFO > 0 and WANTZ is .TRUE., then on exit */ +/* > */ +/* > (final value of Z(ILO:IHI,ILOZ:IHIZ) */ +/* > = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U */ +/* > */ +/* > where U is the unitary matrix in (*) (regard- */ +/* > less of the value of WANTT.) */ +/* > */ +/* > If INFO > 0 and WANTZ is .FALSE., then Z is not */ +/* > accessed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Karen Braman and Ralph Byers, Department of Mathematics, */ +/* > University of Kansas, USA */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ +/* > Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */ +/* > Performance, SIAM Journal of Matrix Analysis, volume 23, pages */ +/* > 929--947, 2002. */ +/* > \n */ +/* > K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ +/* > Algorithm Part II: Aggressive Early Deflation, SIAM Journal */ +/* > of Matrix Analysis, volume 23, pages 948--973, 2002. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlaqr4_(logical *wantt, logical *wantz, integer *n, + integer *ilo, integer *ihi, doublecomplex *h__, integer *ldh, + doublecomplex *w, integer *iloz, integer *ihiz, doublecomplex *z__, + integer *ldz, doublecomplex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; + doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8; + doublecomplex z__1, z__2, z__3, z__4, z__5; + + /* Local variables */ + integer ndec, ndfl, kbot, nmin; + doublecomplex swap; + integer ktop; + doublecomplex zdum[1] /* was [1][1] */; + integer kacc22, i__, k; + doublereal s; + integer itmax, nsmax, nwmax, kwtop; + doublecomplex aa, bb, cc, dd; + extern /* Subroutine */ int zlaqr2_(logical *, logical *, integer *, + integer *, integer *, integer *, doublecomplex *, integer *, + integer *, integer *, doublecomplex *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, integer *, + doublecomplex *, integer *, integer *, doublecomplex *, integer * + , doublecomplex *, integer *), zlaqr5_(logical *, logical *, + integer *, integer *, integer *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, integer *, doublecomplex *, integer *, + integer *, doublecomplex *, integer *); + integer ld, nh, nibble, it, ks, kt, ku, kv, ls, ns, nw; + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + char jbcmpz[2]; + doublecomplex rtdisc; + integer nwupbd; + logical sorted; + extern /* Subroutine */ int zlahqr_(logical *, logical *, integer *, + integer *, integer *, doublecomplex *, integer *, doublecomplex *, + integer *, integer *, doublecomplex *, integer *, integer *), + zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + integer lwkopt; + doublecomplex tr2, det; + integer inf, kdu, nho, nve, kwh, nsr, nwr, kwv; + + +/* -- 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 */ + + +/* ================================================================ */ + + +/* ==== Matrices of order NTINY or smaller must be processed by */ +/* . ZLAHQR because of insufficient subdiagonal scratch space. */ +/* . (This is a hard limit.) ==== */ + +/* ==== Exceptional deflation windows: try to cure rare */ +/* . slow convergence by varying the size of the */ +/* . deflation window after KEXNW iterations. ==== */ + +/* ==== Exceptional shifts: try to cure rare slow convergence */ +/* . with ad-hoc exceptional shifts every KEXSH iterations. */ +/* . ==== */ + +/* ==== The constant WILK1 is used to form the exceptional */ +/* . shifts. ==== */ + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + + /* Function Body */ + *info = 0; + +/* ==== Quick return for N = 0: nothing to do. ==== */ + + if (*n == 0) { + work[1].r = 1., work[1].i = 0.; + return 0; + } + + if (*n <= 15) { + +/* ==== Tiny matrices must use ZLAHQR. ==== */ + + lwkopt = 1; + if (*lwork != -1) { + zlahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1], + iloz, ihiz, &z__[z_offset], ldz, info); + } + } else { + +/* ==== Use small bulge multi-shift QR with aggressive early */ +/* . deflation on larger-than-tiny matrices. ==== */ + +/* ==== Hope for the best. ==== */ + + *info = 0; + +/* ==== Set up job flags for ILAENV. ==== */ + + if (*wantt) { + *(unsigned char *)jbcmpz = 'S'; + } else { + *(unsigned char *)jbcmpz = 'E'; + } + if (*wantz) { + *(unsigned char *)&jbcmpz[1] = 'V'; + } else { + *(unsigned char *)&jbcmpz[1] = 'N'; + } + +/* ==== NWR = recommended deflation window size. At this */ +/* . point, N .GT. NTINY = 15, so there is enough */ +/* . subdiagonal workspace for NWR.GE.2 as required. */ +/* . (In fact, there is enough subdiagonal space for */ +/* . NWR.GE.4.) ==== */ + + nwr = ilaenv_(&c__13, "ZLAQR4", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, + (ftnlen)2); + nwr = f2cmax(2,nwr); +/* Computing MIN */ + i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = f2cmin(i__1,i__2); + nwr = f2cmin(i__1,nwr); + +/* ==== NSR = recommended number of simultaneous shifts. */ +/* . At this point N .GT. NTINY = 15, so there is at */ +/* . enough subdiagonal workspace for NSR to be even */ +/* . and greater than or equal to two as required. ==== */ + + nsr = ilaenv_(&c__15, "ZLAQR4", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, + (ftnlen)2); +/* Computing MIN */ + i__1 = nsr, i__2 = (*n - 3) / 6, i__1 = f2cmin(i__1,i__2), i__2 = *ihi - + *ilo; + nsr = f2cmin(i__1,i__2); +/* Computing MAX */ + i__1 = 2, i__2 = nsr - nsr % 2; + nsr = f2cmax(i__1,i__2); + +/* ==== Estimate optimal workspace ==== */ + +/* ==== Workspace query call to ZLAQR2 ==== */ + + i__1 = nwr + 1; + zlaqr2_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz, + ihiz, &z__[z_offset], ldz, &ls, &ld, &w[1], &h__[h_offset], + ldh, n, &h__[h_offset], ldh, n, &h__[h_offset], ldh, &work[1], + &c_n1); + +/* ==== Optimal workspace = MAX(ZLAQR5, ZLAQR2) ==== */ + +/* Computing MAX */ + i__1 = nsr * 3 / 2, i__2 = (integer) work[1].r; + lwkopt = f2cmax(i__1,i__2); + +/* ==== Quick return in case of workspace query. ==== */ + + if (*lwork == -1) { + d__1 = (doublereal) lwkopt; + z__1.r = d__1, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + return 0; + } + +/* ==== ZLAHQR/ZLAQR0 crossover point ==== */ + + nmin = ilaenv_(&c__12, "ZLAQR4", jbcmpz, n, ilo, ihi, lwork, (ftnlen) + 6, (ftnlen)2); + nmin = f2cmax(15,nmin); + +/* ==== Nibble crossover point ==== */ + + nibble = ilaenv_(&c__14, "ZLAQR4", jbcmpz, n, ilo, ihi, lwork, ( + ftnlen)6, (ftnlen)2); + nibble = f2cmax(0,nibble); + +/* ==== Accumulate reflections during ttswp? Use block */ +/* . 2-by-2 structure during matrix-matrix multiply? ==== */ + + kacc22 = ilaenv_(&c__16, "ZLAQR4", jbcmpz, n, ilo, ihi, lwork, ( + ftnlen)6, (ftnlen)2); + kacc22 = f2cmax(0,kacc22); + kacc22 = f2cmin(2,kacc22); + +/* ==== NWMAX = the largest possible deflation window for */ +/* . which there is sufficient workspace. ==== */ + +/* Computing MIN */ + i__1 = (*n - 1) / 3, i__2 = *lwork / 2; + nwmax = f2cmin(i__1,i__2); + nw = nwmax; + +/* ==== NSMAX = the Largest number of simultaneous shifts */ +/* . for which there is sufficient workspace. ==== */ + +/* Computing MIN */ + i__1 = (*n - 3) / 6, i__2 = (*lwork << 1) / 3; + nsmax = f2cmin(i__1,i__2); + nsmax -= nsmax % 2; + +/* ==== NDFL: an iteration count restarted at deflation. ==== */ + + ndfl = 1; + +/* ==== ITMAX = iteration limit ==== */ + +/* Computing MAX */ + i__1 = 10, i__2 = *ihi - *ilo + 1; + itmax = 30 * f2cmax(i__1,i__2); + +/* ==== Last row and column in the active block ==== */ + + kbot = *ihi; + +/* ==== Main Loop ==== */ + + i__1 = itmax; + for (it = 1; it <= i__1; ++it) { + +/* ==== Done when KBOT falls below ILO ==== */ + + if (kbot < *ilo) { + goto L80; + } + +/* ==== Locate active block ==== */ + + i__2 = *ilo + 1; + for (k = kbot; k >= i__2; --k) { + i__3 = k + (k - 1) * h_dim1; + if (h__[i__3].r == 0. && h__[i__3].i == 0.) { + goto L20; + } +/* L10: */ + } + k = *ilo; +L20: + ktop = k; + +/* ==== Select deflation window size: */ +/* . Typical Case: */ +/* . If possible and advisable, nibble the entire */ +/* . active block. If not, use size MIN(NWR,NWMAX) */ +/* . or MIN(NWR+1,NWMAX) depending upon which has */ +/* . the smaller corresponding subdiagonal entry */ +/* . (a heuristic). */ +/* . */ +/* . Exceptional Case: */ +/* . If there have been no deflations in KEXNW or */ +/* . more iterations, then vary the deflation window */ +/* . size. At first, because, larger windows are, */ +/* . in general, more powerful than smaller ones, */ +/* . rapidly increase the window to the maximum possible. */ +/* . Then, gradually reduce the window size. ==== */ + + nh = kbot - ktop + 1; + nwupbd = f2cmin(nh,nwmax); + if (ndfl < 5) { + nw = f2cmin(nwupbd,nwr); + } else { +/* Computing MIN */ + i__2 = nwupbd, i__3 = nw << 1; + nw = f2cmin(i__2,i__3); + } + if (nw < nwmax) { + if (nw >= nh - 1) { + nw = nh; + } else { + kwtop = kbot - nw + 1; + i__2 = kwtop + (kwtop - 1) * h_dim1; + i__3 = kwtop - 1 + (kwtop - 2) * h_dim1; + if ((d__1 = h__[i__2].r, abs(d__1)) + (d__2 = d_imag(&h__[ + kwtop + (kwtop - 1) * h_dim1]), abs(d__2)) > ( + d__3 = h__[i__3].r, abs(d__3)) + (d__4 = d_imag(& + h__[kwtop - 1 + (kwtop - 2) * h_dim1]), abs(d__4)) + ) { + ++nw; + } + } + } + if (ndfl < 5) { + ndec = -1; + } else if (ndec >= 0 || nw >= nwupbd) { + ++ndec; + if (nw - ndec < 2) { + ndec = 0; + } + nw -= ndec; + } + +/* ==== Aggressive early deflation: */ +/* . split workspace under the subdiagonal into */ +/* . - an nw-by-nw work array V in the lower */ +/* . left-hand-corner, */ +/* . - an NW-by-at-least-NW-but-more-is-better */ +/* . (NW-by-NHO) horizontal work array along */ +/* . the bottom edge, */ +/* . - an at-least-NW-but-more-is-better (NHV-by-NW) */ +/* . vertical work array along the left-hand-edge. */ +/* . ==== */ + + kv = *n - nw + 1; + kt = nw + 1; + nho = *n - nw - 1 - kt + 1; + kwv = nw + 2; + nve = *n - nw - kwv + 1; + +/* ==== Aggressive early deflation ==== */ + + zlaqr2_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh, + iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &w[1], &h__[kv + + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1], ldh, &nve, & + h__[kwv + h_dim1], ldh, &work[1], lwork); + +/* ==== Adjust KBOT accounting for new deflations. ==== */ + + kbot -= ld; + +/* ==== KS points to the shifts. ==== */ + + ks = kbot - ls + 1; + +/* ==== Skip an expensive QR sweep if there is a (partly */ +/* . heuristic) reason to expect that many eigenvalues */ +/* . will deflate without it. Here, the QR sweep is */ +/* . skipped if many eigenvalues have just been deflated */ +/* . or if the remaining active block is small. */ + + if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > f2cmin( + nmin,nwmax)) { + +/* ==== NS = nominal number of simultaneous shifts. */ +/* . This may be lowered (slightly) if ZLAQR2 */ +/* . did not provide that many shifts. ==== */ + +/* Computing MIN */ +/* Computing MAX */ + i__4 = 2, i__5 = kbot - ktop; + i__2 = f2cmin(nsmax,nsr), i__3 = f2cmax(i__4,i__5); + ns = f2cmin(i__2,i__3); + ns -= ns % 2; + +/* ==== If there have been no deflations */ +/* . in a multiple of KEXSH iterations, */ +/* . then try exceptional shifts. */ +/* . Otherwise use shifts provided by */ +/* . ZLAQR2 above or from the eigenvalues */ +/* . of a trailing principal submatrix. ==== */ + + if (ndfl % 6 == 0) { + ks = kbot - ns + 1; + i__2 = ks + 1; + for (i__ = kbot; i__ >= i__2; i__ += -2) { + i__3 = i__; + i__4 = i__ + i__ * h_dim1; + i__5 = i__ + (i__ - 1) * h_dim1; + d__3 = ((d__1 = h__[i__5].r, abs(d__1)) + (d__2 = + d_imag(&h__[i__ + (i__ - 1) * h_dim1]), abs( + d__2))) * .75; + z__1.r = h__[i__4].r + d__3, z__1.i = h__[i__4].i; + w[i__3].r = z__1.r, w[i__3].i = z__1.i; + i__3 = i__ - 1; + i__4 = i__; + w[i__3].r = w[i__4].r, w[i__3].i = w[i__4].i; +/* L30: */ + } + } else { + +/* ==== Got NS/2 or fewer shifts? Use ZLAHQR */ +/* . on a trailing principal submatrix to */ +/* . get more. (Since NS.LE.NSMAX.LE.(N-3)/6, */ +/* . there is enough space below the subdiagonal */ +/* . to fit an NS-by-NS scratch array.) ==== */ + + if (kbot - ks + 1 <= ns / 2) { + ks = kbot - ns + 1; + kt = *n - ns + 1; + zlacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, & + h__[kt + h_dim1], ldh); + zlahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[kt + + h_dim1], ldh, &w[ks], &c__1, &c__1, zdum, & + c__1, &inf); + ks += inf; + +/* ==== In case of a rare QR failure use */ +/* . eigenvalues of the trailing 2-by-2 */ +/* . principal submatrix. Scale to avoid */ +/* . overflows, underflows and subnormals. */ +/* . (The scale factor S can not be zero, */ +/* . because H(KBOT,KBOT-1) is nonzero.) ==== */ + + if (ks >= kbot) { + i__2 = kbot - 1 + (kbot - 1) * h_dim1; + i__3 = kbot + (kbot - 1) * h_dim1; + i__4 = kbot - 1 + kbot * h_dim1; + i__5 = kbot + kbot * h_dim1; + s = (d__1 = h__[i__2].r, abs(d__1)) + (d__2 = + d_imag(&h__[kbot - 1 + (kbot - 1) * + h_dim1]), abs(d__2)) + ((d__3 = h__[i__3] + .r, abs(d__3)) + (d__4 = d_imag(&h__[kbot + + (kbot - 1) * h_dim1]), abs(d__4))) + (( + d__5 = h__[i__4].r, abs(d__5)) + (d__6 = + d_imag(&h__[kbot - 1 + kbot * h_dim1]), + abs(d__6))) + ((d__7 = h__[i__5].r, abs( + d__7)) + (d__8 = d_imag(&h__[kbot + kbot * + h_dim1]), abs(d__8))); + i__2 = kbot - 1 + (kbot - 1) * h_dim1; + z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i / + s; + aa.r = z__1.r, aa.i = z__1.i; + i__2 = kbot + (kbot - 1) * h_dim1; + z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i / + s; + cc.r = z__1.r, cc.i = z__1.i; + i__2 = kbot - 1 + kbot * h_dim1; + z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i / + s; + bb.r = z__1.r, bb.i = z__1.i; + i__2 = kbot + kbot * h_dim1; + z__1.r = h__[i__2].r / s, z__1.i = h__[i__2].i / + s; + dd.r = z__1.r, dd.i = z__1.i; + z__2.r = aa.r + dd.r, z__2.i = aa.i + dd.i; + z__1.r = z__2.r / 2., z__1.i = z__2.i / 2.; + tr2.r = z__1.r, tr2.i = z__1.i; + z__3.r = aa.r - tr2.r, z__3.i = aa.i - tr2.i; + z__4.r = dd.r - tr2.r, z__4.i = dd.i - tr2.i; + z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, + z__2.i = z__3.r * z__4.i + z__3.i * + z__4.r; + z__5.r = bb.r * cc.r - bb.i * cc.i, z__5.i = bb.r + * cc.i + bb.i * cc.r; + z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - + z__5.i; + det.r = z__1.r, det.i = z__1.i; + z__2.r = -det.r, z__2.i = -det.i; + z_sqrt(&z__1, &z__2); + rtdisc.r = z__1.r, rtdisc.i = z__1.i; + i__2 = kbot - 1; + z__2.r = tr2.r + rtdisc.r, z__2.i = tr2.i + + rtdisc.i; + z__1.r = s * z__2.r, z__1.i = s * z__2.i; + w[i__2].r = z__1.r, w[i__2].i = z__1.i; + i__2 = kbot; + z__2.r = tr2.r - rtdisc.r, z__2.i = tr2.i - + rtdisc.i; + z__1.r = s * z__2.r, z__1.i = s * z__2.i; + w[i__2].r = z__1.r, w[i__2].i = z__1.i; + + ks = kbot - 1; + } + } + + if (kbot - ks + 1 > ns) { + +/* ==== Sort the shifts (Helps a little) ==== */ + + sorted = FALSE_; + i__2 = ks + 1; + for (k = kbot; k >= i__2; --k) { + if (sorted) { + goto L60; + } + sorted = TRUE_; + i__3 = k - 1; + for (i__ = ks; i__ <= i__3; ++i__) { + i__4 = i__; + i__5 = i__ + 1; + if ((d__1 = w[i__4].r, abs(d__1)) + (d__2 = + d_imag(&w[i__]), abs(d__2)) < (d__3 = + w[i__5].r, abs(d__3)) + (d__4 = + d_imag(&w[i__ + 1]), abs(d__4))) { + sorted = FALSE_; + i__4 = i__; + swap.r = w[i__4].r, swap.i = w[i__4].i; + i__4 = i__; + i__5 = i__ + 1; + w[i__4].r = w[i__5].r, w[i__4].i = w[i__5] + .i; + i__4 = i__ + 1; + w[i__4].r = swap.r, w[i__4].i = swap.i; + } +/* L40: */ + } +/* L50: */ + } +L60: + ; + } + } + +/* ==== If there are only two shifts, then use */ +/* . only one. ==== */ + + if (kbot - ks + 1 == 2) { + i__2 = kbot; + i__3 = kbot + kbot * h_dim1; + z__2.r = w[i__2].r - h__[i__3].r, z__2.i = w[i__2].i - + h__[i__3].i; + z__1.r = z__2.r, z__1.i = z__2.i; + i__4 = kbot - 1; + i__5 = kbot + kbot * h_dim1; + z__4.r = w[i__4].r - h__[i__5].r, z__4.i = w[i__4].i - + h__[i__5].i; + z__3.r = z__4.r, z__3.i = z__4.i; + if ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), + abs(d__2)) < (d__3 = z__3.r, abs(d__3)) + (d__4 = + d_imag(&z__3), abs(d__4))) { + i__2 = kbot - 1; + i__3 = kbot; + w[i__2].r = w[i__3].r, w[i__2].i = w[i__3].i; + } else { + i__2 = kbot; + i__3 = kbot - 1; + w[i__2].r = w[i__3].r, w[i__2].i = w[i__3].i; + } + } + +/* ==== Use up to NS of the the smallest magnitude */ +/* . shifts. If there aren't NS shifts available, */ +/* . then use them all, possibly dropping one to */ +/* . make the number of shifts even. ==== */ + +/* Computing MIN */ + i__2 = ns, i__3 = kbot - ks + 1; + ns = f2cmin(i__2,i__3); + ns -= ns % 2; + ks = kbot - ns + 1; + +/* ==== Small-bulge multi-shift QR sweep: */ +/* . split workspace under the subdiagonal into */ +/* . - a KDU-by-KDU work array U in the lower */ +/* . left-hand-corner, */ +/* . - a KDU-by-at-least-KDU-but-more-is-better */ +/* . (KDU-by-NHo) horizontal work array WH along */ +/* . the bottom edge, */ +/* . - and an at-least-KDU-but-more-is-better-by-KDU */ +/* . (NVE-by-KDU) vertical work WV arrow along */ +/* . the left-hand-edge. ==== */ + + kdu = ns << 1; + ku = *n - kdu + 1; + kwh = kdu + 1; + nho = *n - kdu - 3 - (kdu + 1) + 1; + kwv = kdu + 4; + nve = *n - kdu - kwv + 1; + +/* ==== Small-bulge multi-shift QR sweep ==== */ + + zlaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &w[ks], & + h__[h_offset], ldh, iloz, ihiz, &z__[z_offset], ldz, & + work[1], &c__3, &h__[ku + h_dim1], ldh, &nve, &h__[ + kwv + h_dim1], ldh, &nho, &h__[ku + kwh * h_dim1], + ldh); + } + +/* ==== Note progress (or the lack of it). ==== */ + + if (ld > 0) { + ndfl = 1; + } else { + ++ndfl; + } + +/* ==== End of main loop ==== */ +/* L70: */ + } + +/* ==== Iteration limit exceeded. Set INFO to show where */ +/* . the problem occurred and exit. ==== */ + + *info = kbot; +L80: + ; + } + +/* ==== Return the optimal value of LWORK. ==== */ + + d__1 = (doublereal) lwkopt; + z__1.r = d__1, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + +/* ==== End of ZLAQR4 ==== */ + + return 0; +} /* zlaqr4_ */ + diff --git a/lapack-netlib/SRC/zlaqr5.c b/lapack-netlib/SRC/zlaqr5.c new file mode 100644 index 000000000..04c53f12b --- /dev/null +++ b/lapack-netlib/SRC/zlaqr5.c @@ -0,0 +1,1784 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAQR5 performs a single small-bulge multi-shift QR sweep. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAQR5 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, */ +/* H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, LDU, NV, */ +/* WV, LDWV, NH, WH, LDWH ) */ + +/* INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, */ +/* $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV */ +/* LOGICAL WANTT, WANTZ */ +/* COMPLEX*16 H( LDH, * ), S( * ), U( LDU, * ), V( LDV, * ), */ +/* $ WH( LDWH, * ), WV( LDWV, * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAQR5, called by ZLAQR0, performs a */ +/* > single small-bulge multi-shift QR sweep. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] WANTT */ +/* > \verbatim */ +/* > WANTT is LOGICAL */ +/* > WANTT = .true. if the triangular Schur factor */ +/* > is being computed. WANTT is set to .false. otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTZ */ +/* > \verbatim */ +/* > WANTZ is LOGICAL */ +/* > WANTZ = .true. if the unitary Schur factor is being */ +/* > computed. WANTZ is set to .false. otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KACC22 */ +/* > \verbatim */ +/* > KACC22 is INTEGER with value 0, 1, or 2. */ +/* > Specifies the computation mode of far-from-diagonal */ +/* > orthogonal updates. */ +/* > = 0: ZLAQR5 does not accumulate reflections and does not */ +/* > use matrix-matrix multiply to update far-from-diagonal */ +/* > matrix entries. */ +/* > = 1: ZLAQR5 accumulates reflections and uses matrix-matrix */ +/* > multiply to update the far-from-diagonal matrix entries. */ +/* > = 2: Same as KACC22 = 1. This option used to enable exploiting */ +/* > the 2-by-2 structure during matrix multiplications, but */ +/* > this is no longer supported. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > N is the order of the Hessenberg matrix H upon which this */ +/* > subroutine operates. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KTOP */ +/* > \verbatim */ +/* > KTOP is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KBOT */ +/* > \verbatim */ +/* > KBOT is INTEGER */ +/* > These are the first and last rows and columns of an */ +/* > isolated diagonal block upon which the QR sweep is to be */ +/* > applied. It is assumed without a check that */ +/* > either KTOP = 1 or H(KTOP,KTOP-1) = 0 */ +/* > and */ +/* > either KBOT = N or H(KBOT+1,KBOT) = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NSHFTS */ +/* > \verbatim */ +/* > NSHFTS is INTEGER */ +/* > NSHFTS gives the number of simultaneous shifts. NSHFTS */ +/* > must be positive and even. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] S */ +/* > \verbatim */ +/* > S is COMPLEX*16 array, dimension (NSHFTS) */ +/* > S contains the shifts of origin that define the multi- */ +/* > shift QR sweep. On output S may be reordered. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] H */ +/* > \verbatim */ +/* > H is COMPLEX*16 array, dimension (LDH,N) */ +/* > On input H contains a Hessenberg matrix. On output a */ +/* > multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied */ +/* > to the isolated diagonal block in rows and columns KTOP */ +/* > through KBOT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > LDH is the leading dimension of H just as declared in the */ +/* > calling procedure. LDH >= MAX(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILOZ */ +/* > \verbatim */ +/* > ILOZ is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHIZ */ +/* > \verbatim */ +/* > IHIZ is INTEGER */ +/* > Specify the rows of Z to which transformations must be */ +/* > applied if WANTZ is .TRUE.. 1 <= ILOZ <= IHIZ <= N */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX*16 array, dimension (LDZ,IHIZ) */ +/* > If WANTZ = .TRUE., then the QR Sweep unitary */ +/* > similarity transformation is accumulated into */ +/* > Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. */ +/* > If WANTZ = .FALSE., then Z is unreferenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > LDA is the leading dimension of Z just as declared in */ +/* > the calling procedure. LDZ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is COMPLEX*16 array, dimension (LDV,NSHFTS/2) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > LDV is the leading dimension of V as declared in the */ +/* > calling procedure. LDV >= 3. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] U */ +/* > \verbatim */ +/* > U is COMPLEX*16 array, dimension (LDU,2*NSHFTS) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > LDU is the leading dimension of U just as declared in the */ +/* > in the calling subroutine. LDU >= 2*NSHFTS. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NV */ +/* > \verbatim */ +/* > NV is INTEGER */ +/* > NV is the number of rows in WV agailable for workspace. */ +/* > NV >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WV */ +/* > \verbatim */ +/* > WV is COMPLEX*16 array, dimension (LDWV,2*NSHFTS) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDWV */ +/* > \verbatim */ +/* > LDWV is INTEGER */ +/* > LDWV is the leading dimension of WV as declared in the */ +/* > in the calling subroutine. LDWV >= NV. */ +/* > \endverbatim */ + +/* > \param[in] NH */ +/* > \verbatim */ +/* > NH is INTEGER */ +/* > NH is the number of columns in array WH available for */ +/* > workspace. NH >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WH */ +/* > \verbatim */ +/* > WH is COMPLEX*16 array, dimension (LDWH,NH) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDWH */ +/* > \verbatim */ +/* > LDWH is INTEGER */ +/* > Leading dimension of WH just as declared in the */ +/* > calling procedure. LDWH >= 2*NSHFTS. */ +/* > \endverbatim */ +/* > */ +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date January 2021 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Karen Braman and Ralph Byers, Department of Mathematics, */ +/* > University of Kansas, USA */ +/* > */ +/* > Lars Karlsson, Daniel Kressner, and Bruno Lang */ +/* > */ +/* > Thijs Steel, Department of Computer science, */ +/* > KU Leuven, Belgium */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ +/* > Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */ +/* > Performance, SIAM Journal of Matrix Analysis, volume 23, pages */ +/* > 929--947, 2002. */ +/* > */ +/* > Lars Karlsson, Daniel Kressner, and Bruno Lang, Optimally packed */ +/* > chains of bulges in multishift QR algorithms. */ +/* > ACM Trans. Math. Softw. 40, 2, Article 12 (February 2014). */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlaqr5_(logical *wantt, logical *wantz, integer *kacc22, + integer *n, integer *ktop, integer *kbot, integer *nshfts, + doublecomplex *s, doublecomplex *h__, integer *ldh, integer *iloz, + integer *ihiz, doublecomplex *z__, integer *ldz, doublecomplex *v, + integer *ldv, doublecomplex *u, integer *ldu, integer *nv, + doublecomplex *wv, integer *ldwv, integer *nh, doublecomplex *wh, + integer *ldwh) +{ + /* System generated locals */ + integer h_dim1, h_offset, u_dim1, u_offset, v_dim1, v_offset, wh_dim1, + wh_offset, wv_dim1, wv_offset, z_dim1, z_offset, i__1, i__2, i__3, + i__4, i__5, i__6, i__7, i__8, i__9, i__10, i__11; + doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10; + doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8; + + /* Local variables */ + doublecomplex beta; + logical bmp22; + integer jcol, jlen, jbot, mbot, jtop, jrow, mtop, j, k, m; + doublecomplex alpha; + logical accum; + integer ndcol, incol, krcol, nbmps; + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + integer i2, k1, i4; + extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); + doublereal h11, h12, h21, h22; + extern /* Subroutine */ int zlaqr1_(integer *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, doublecomplex *); + integer m22; + extern doublereal dlamch_(char *); + integer ns, nu; + doublecomplex vt[3]; + doublereal safmin, safmax; + extern /* Subroutine */ int zlarfg_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *); + doublecomplex refsum; + extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *), + zlaset_(char *, integer *, integer *, doublecomplex *, + doublecomplex *, doublecomplex *, integer *); + doublereal smlnum, scl; + integer kdu, kms; + doublereal ulp; + doublereal tst1, tst2; + + +/* -- LAPACK auxiliary 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 */ + + +/* ================================================================ */ + + +/* ==== If there are no shifts, then there is nothing to do. ==== */ + + /* Parameter adjustments */ + --s; + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + wv_dim1 = *ldwv; + wv_offset = 1 + wv_dim1 * 1; + wv -= wv_offset; + wh_dim1 = *ldwh; + wh_offset = 1 + wh_dim1 * 1; + wh -= wh_offset; + + /* Function Body */ + if (*nshfts < 2) { + return 0; + } + +/* ==== If the active block is empty or 1-by-1, then there */ +/* . is nothing to do. ==== */ + + if (*ktop >= *kbot) { + return 0; + } + +/* ==== NSHFTS is supposed to be even, but if it is odd, */ +/* . then simply reduce it by one. ==== */ + + ns = *nshfts - *nshfts % 2; + +/* ==== Machine constants for deflation ==== */ + + safmin = dlamch_("SAFE MINIMUM"); + safmax = 1. / safmin; + dlabad_(&safmin, &safmax); + ulp = dlamch_("PRECISION"); + smlnum = safmin * ((doublereal) (*n) / ulp); + +/* ==== Use accumulated reflections to update far-from-diagonal */ +/* . entries ? ==== */ + + accum = *kacc22 == 1 || *kacc22 == 2; + +/* ==== clear trash ==== */ + + if (*ktop + 2 <= *kbot) { + i__1 = *ktop + 2 + *ktop * h_dim1; + h__[i__1].r = 0., h__[i__1].i = 0.; + } + +/* ==== NBMPS = number of 2-shift bulges in the chain ==== */ + + nbmps = ns / 2; + +/* ==== KDU = width of slab ==== */ + + kdu = nbmps << 2; + +/* ==== Create and chase chains of NBMPS bulges ==== */ + + i__1 = *kbot - 2; + i__2 = nbmps << 1; + for (incol = *ktop - (nbmps << 1) + 1; i__2 < 0 ? incol >= i__1 : incol <= + i__1; incol += i__2) { + +/* JTOP = Index from which updates from the right start. */ + + if (accum) { + jtop = f2cmax(*ktop,incol); + } else if (*wantt) { + jtop = 1; + } else { + jtop = *ktop; + } + + ndcol = incol + kdu; + if (accum) { + zlaset_("ALL", &kdu, &kdu, &c_b1, &c_b2, &u[u_offset], ldu); + } + +/* ==== Near-the-diagonal bulge chase. The following loop */ +/* . performs the near-the-diagonal part of a small bulge */ +/* . multi-shift QR sweep. Each 4*NBMPS column diagonal */ +/* . chunk extends from column INCOL to column NDCOL */ +/* . (including both column INCOL and column NDCOL). The */ +/* . following loop chases a 2*NBMPS+1 column long chain of */ +/* . NBMPS bulges 2*NBMPS columns to the right. (INCOL */ +/* . may be less than KTOP and and NDCOL may be greater than */ +/* . KBOT indicating phantom columns from which to chase */ +/* . bulges before they are actually introduced or to which */ +/* . to chase bulges beyond column KBOT.) ==== */ + +/* Computing MIN */ + i__4 = incol + (nbmps << 1) - 1, i__5 = *kbot - 2; + i__3 = f2cmin(i__4,i__5); + for (krcol = incol; krcol <= i__3; ++krcol) { + +/* ==== Bulges number MTOP to MBOT are active double implicit */ +/* . shift bulges. There may or may not also be small */ +/* . 2-by-2 bulge, if there is room. The inactive bulges */ +/* . (if any) must wait until the active bulges have moved */ +/* . down the diagonal to make room. The phantom matrix */ +/* . paradigm described above helps keep track. ==== */ + +/* Computing MAX */ + i__4 = 1, i__5 = (*ktop - krcol) / 2 + 1; + mtop = f2cmax(i__4,i__5); +/* Computing MIN */ + i__4 = nbmps, i__5 = (*kbot - krcol - 1) / 2; + mbot = f2cmin(i__4,i__5); + m22 = mbot + 1; + bmp22 = mbot < nbmps && krcol + (m22 - 1 << 1) == *kbot - 2; + +/* ==== Generate reflections to chase the chain right */ +/* . one column. (The minimum value of K is KTOP-1.) ==== */ + + if (bmp22) { + +/* ==== Special case: 2-by-2 reflection at bottom treated */ +/* . separately ==== */ + + k = krcol + (m22 - 1 << 1); + if (k == *ktop - 1) { + zlaqr1_(&c__2, &h__[k + 1 + (k + 1) * h_dim1], ldh, &s[( + m22 << 1) - 1], &s[m22 * 2], &v[m22 * v_dim1 + 1]) + ; + i__4 = m22 * v_dim1 + 1; + beta.r = v[i__4].r, beta.i = v[i__4].i; + zlarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22 + * v_dim1 + 1]); + } else { + i__4 = k + 1 + k * h_dim1; + beta.r = h__[i__4].r, beta.i = h__[i__4].i; + i__4 = m22 * v_dim1 + 2; + i__5 = k + 2 + k * h_dim1; + v[i__4].r = h__[i__5].r, v[i__4].i = h__[i__5].i; + zlarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22 + * v_dim1 + 1]); + i__4 = k + 1 + k * h_dim1; + h__[i__4].r = beta.r, h__[i__4].i = beta.i; + i__4 = k + 2 + k * h_dim1; + h__[i__4].r = 0., h__[i__4].i = 0.; + } + +/* ==== Perform update from right within */ +/* . computational window. ==== */ + +/* Computing MIN */ + i__5 = *kbot, i__6 = k + 3; + i__4 = f2cmin(i__5,i__6); + for (j = jtop; j <= i__4; ++j) { + i__5 = m22 * v_dim1 + 1; + i__6 = j + (k + 1) * h_dim1; + i__7 = m22 * v_dim1 + 2; + i__8 = j + (k + 2) * h_dim1; + z__3.r = v[i__7].r * h__[i__8].r - v[i__7].i * h__[i__8] + .i, z__3.i = v[i__7].r * h__[i__8].i + v[i__7].i * + h__[i__8].r; + z__2.r = h__[i__6].r + z__3.r, z__2.i = h__[i__6].i + + z__3.i; + z__1.r = v[i__5].r * z__2.r - v[i__5].i * z__2.i, z__1.i = + v[i__5].r * z__2.i + v[i__5].i * z__2.r; + refsum.r = z__1.r, refsum.i = z__1.i; + i__5 = j + (k + 1) * h_dim1; + i__6 = j + (k + 1) * h_dim1; + z__1.r = h__[i__6].r - refsum.r, z__1.i = h__[i__6].i - + refsum.i; + h__[i__5].r = z__1.r, h__[i__5].i = z__1.i; + i__5 = j + (k + 2) * h_dim1; + i__6 = j + (k + 2) * h_dim1; + d_cnjg(&z__3, &v[m22 * v_dim1 + 2]); + z__2.r = refsum.r * z__3.r - refsum.i * z__3.i, z__2.i = + refsum.r * z__3.i + refsum.i * z__3.r; + z__1.r = h__[i__6].r - z__2.r, z__1.i = h__[i__6].i - + z__2.i; + h__[i__5].r = z__1.r, h__[i__5].i = z__1.i; +/* L30: */ + } + +/* ==== Perform update from left within */ +/* . computational window. ==== */ + + if (accum) { + jbot = f2cmin(ndcol,*kbot); + } else if (*wantt) { + jbot = *n; + } else { + jbot = *kbot; + } + i__4 = jbot; + for (j = k + 1; j <= i__4; ++j) { + d_cnjg(&z__2, &v[m22 * v_dim1 + 1]); + i__5 = k + 1 + j * h_dim1; + d_cnjg(&z__5, &v[m22 * v_dim1 + 2]); + i__6 = k + 2 + j * h_dim1; + z__4.r = z__5.r * h__[i__6].r - z__5.i * h__[i__6].i, + z__4.i = z__5.r * h__[i__6].i + z__5.i * h__[i__6] + .r; + z__3.r = h__[i__5].r + z__4.r, z__3.i = h__[i__5].i + + z__4.i; + z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = + z__2.r * z__3.i + z__2.i * z__3.r; + refsum.r = z__1.r, refsum.i = z__1.i; + i__5 = k + 1 + j * h_dim1; + i__6 = k + 1 + j * h_dim1; + z__1.r = h__[i__6].r - refsum.r, z__1.i = h__[i__6].i - + refsum.i; + h__[i__5].r = z__1.r, h__[i__5].i = z__1.i; + i__5 = k + 2 + j * h_dim1; + i__6 = k + 2 + j * h_dim1; + i__7 = m22 * v_dim1 + 2; + z__2.r = refsum.r * v[i__7].r - refsum.i * v[i__7].i, + z__2.i = refsum.r * v[i__7].i + refsum.i * v[i__7] + .r; + z__1.r = h__[i__6].r - z__2.r, z__1.i = h__[i__6].i - + z__2.i; + h__[i__5].r = z__1.r, h__[i__5].i = z__1.i; +/* L40: */ + } + +/* ==== The following convergence test requires that */ +/* . the tradition small-compared-to-nearby-diagonals */ +/* . criterion and the Ahues & Tisseur (LAWN 122, 1997) */ +/* . criteria both be satisfied. The latter improves */ +/* . accuracy in some examples. Falling back on an */ +/* . alternate convergence criterion when TST1 or TST2 */ +/* . is zero (as done here) is traditional but probably */ +/* . unnecessary. ==== */ + + if (k >= *ktop) { + i__4 = k + 1 + k * h_dim1; + if (h__[i__4].r != 0. || h__[i__4].i != 0.) { + i__4 = k + k * h_dim1; + i__5 = k + 1 + (k + 1) * h_dim1; + tst1 = (d__1 = h__[i__4].r, abs(d__1)) + (d__2 = + d_imag(&h__[k + k * h_dim1]), abs(d__2)) + (( + d__3 = h__[i__5].r, abs(d__3)) + (d__4 = + d_imag(&h__[k + 1 + (k + 1) * h_dim1]), abs( + d__4))); + if (tst1 == 0.) { + if (k >= *ktop + 1) { + i__4 = k + (k - 1) * h_dim1; + tst1 += (d__1 = h__[i__4].r, abs(d__1)) + ( + d__2 = d_imag(&h__[k + (k - 1) * + h_dim1]), abs(d__2)); + } + if (k >= *ktop + 2) { + i__4 = k + (k - 2) * h_dim1; + tst1 += (d__1 = h__[i__4].r, abs(d__1)) + ( + d__2 = d_imag(&h__[k + (k - 2) * + h_dim1]), abs(d__2)); + } + if (k >= *ktop + 3) { + i__4 = k + (k - 3) * h_dim1; + tst1 += (d__1 = h__[i__4].r, abs(d__1)) + ( + d__2 = d_imag(&h__[k + (k - 3) * + h_dim1]), abs(d__2)); + } + if (k <= *kbot - 2) { + i__4 = k + 2 + (k + 1) * h_dim1; + tst1 += (d__1 = h__[i__4].r, abs(d__1)) + ( + d__2 = d_imag(&h__[k + 2 + (k + 1) * + h_dim1]), abs(d__2)); + } + if (k <= *kbot - 3) { + i__4 = k + 3 + (k + 1) * h_dim1; + tst1 += (d__1 = h__[i__4].r, abs(d__1)) + ( + d__2 = d_imag(&h__[k + 3 + (k + 1) * + h_dim1]), abs(d__2)); + } + if (k <= *kbot - 4) { + i__4 = k + 4 + (k + 1) * h_dim1; + tst1 += (d__1 = h__[i__4].r, abs(d__1)) + ( + d__2 = d_imag(&h__[k + 4 + (k + 1) * + h_dim1]), abs(d__2)); + } + } + i__4 = k + 1 + k * h_dim1; +/* Computing MAX */ + d__3 = smlnum, d__4 = ulp * tst1; + if ((d__1 = h__[i__4].r, abs(d__1)) + (d__2 = d_imag(& + h__[k + 1 + k * h_dim1]), abs(d__2)) <= f2cmax( + d__3,d__4)) { +/* Computing MAX */ + i__4 = k + 1 + k * h_dim1; + i__5 = k + (k + 1) * h_dim1; + d__5 = (d__1 = h__[i__4].r, abs(d__1)) + (d__2 = + d_imag(&h__[k + 1 + k * h_dim1]), abs( + d__2)), d__6 = (d__3 = h__[i__5].r, abs( + d__3)) + (d__4 = d_imag(&h__[k + (k + 1) * + h_dim1]), abs(d__4)); + h12 = f2cmax(d__5,d__6); +/* Computing MIN */ + i__4 = k + 1 + k * h_dim1; + i__5 = k + (k + 1) * h_dim1; + d__5 = (d__1 = h__[i__4].r, abs(d__1)) + (d__2 = + d_imag(&h__[k + 1 + k * h_dim1]), abs( + d__2)), d__6 = (d__3 = h__[i__5].r, abs( + d__3)) + (d__4 = d_imag(&h__[k + (k + 1) * + h_dim1]), abs(d__4)); + h21 = f2cmin(d__5,d__6); + i__4 = k + k * h_dim1; + i__5 = k + 1 + (k + 1) * h_dim1; + z__2.r = h__[i__4].r - h__[i__5].r, z__2.i = h__[ + i__4].i - h__[i__5].i; + z__1.r = z__2.r, z__1.i = z__2.i; +/* Computing MAX */ + i__6 = k + 1 + (k + 1) * h_dim1; + d__5 = (d__1 = h__[i__6].r, abs(d__1)) + (d__2 = + d_imag(&h__[k + 1 + (k + 1) * h_dim1]), + abs(d__2)), d__6 = (d__3 = z__1.r, abs( + d__3)) + (d__4 = d_imag(&z__1), abs(d__4)) + ; + h11 = f2cmax(d__5,d__6); + i__4 = k + k * h_dim1; + i__5 = k + 1 + (k + 1) * h_dim1; + z__2.r = h__[i__4].r - h__[i__5].r, z__2.i = h__[ + i__4].i - h__[i__5].i; + z__1.r = z__2.r, z__1.i = z__2.i; +/* Computing MIN */ + i__6 = k + 1 + (k + 1) * h_dim1; + d__5 = (d__1 = h__[i__6].r, abs(d__1)) + (d__2 = + d_imag(&h__[k + 1 + (k + 1) * h_dim1]), + abs(d__2)), d__6 = (d__3 = z__1.r, abs( + d__3)) + (d__4 = d_imag(&z__1), abs(d__4)) + ; + h22 = f2cmin(d__5,d__6); + scl = h11 + h12; + tst2 = h22 * (h11 / scl); + +/* Computing MAX */ + d__1 = smlnum, d__2 = ulp * tst2; + if (tst2 == 0. || h21 * (h12 / scl) <= f2cmax(d__1, + d__2)) { + i__4 = k + 1 + k * h_dim1; + h__[i__4].r = 0., h__[i__4].i = 0.; + } + } + } + } + +/* ==== Accumulate orthogonal transformations. ==== */ + + if (accum) { + kms = k - incol; +/* Computing MAX */ + i__4 = 1, i__5 = *ktop - incol; + i__6 = kdu; + for (j = f2cmax(i__4,i__5); j <= i__6; ++j) { + i__4 = m22 * v_dim1 + 1; + i__5 = j + (kms + 1) * u_dim1; + i__7 = m22 * v_dim1 + 2; + i__8 = j + (kms + 2) * u_dim1; + z__3.r = v[i__7].r * u[i__8].r - v[i__7].i * u[i__8] + .i, z__3.i = v[i__7].r * u[i__8].i + v[i__7] + .i * u[i__8].r; + z__2.r = u[i__5].r + z__3.r, z__2.i = u[i__5].i + + z__3.i; + z__1.r = v[i__4].r * z__2.r - v[i__4].i * z__2.i, + z__1.i = v[i__4].r * z__2.i + v[i__4].i * + z__2.r; + refsum.r = z__1.r, refsum.i = z__1.i; + i__4 = j + (kms + 1) * u_dim1; + i__5 = j + (kms + 1) * u_dim1; + z__1.r = u[i__5].r - refsum.r, z__1.i = u[i__5].i - + refsum.i; + u[i__4].r = z__1.r, u[i__4].i = z__1.i; + i__4 = j + (kms + 2) * u_dim1; + i__5 = j + (kms + 2) * u_dim1; + d_cnjg(&z__3, &v[m22 * v_dim1 + 2]); + z__2.r = refsum.r * z__3.r - refsum.i * z__3.i, + z__2.i = refsum.r * z__3.i + refsum.i * + z__3.r; + z__1.r = u[i__5].r - z__2.r, z__1.i = u[i__5].i - + z__2.i; + u[i__4].r = z__1.r, u[i__4].i = z__1.i; +/* L50: */ + } + } else if (*wantz) { + i__6 = *ihiz; + for (j = *iloz; j <= i__6; ++j) { + i__4 = m22 * v_dim1 + 1; + i__5 = j + (k + 1) * z_dim1; + i__7 = m22 * v_dim1 + 2; + i__8 = j + (k + 2) * z_dim1; + z__3.r = v[i__7].r * z__[i__8].r - v[i__7].i * z__[ + i__8].i, z__3.i = v[i__7].r * z__[i__8].i + v[ + i__7].i * z__[i__8].r; + z__2.r = z__[i__5].r + z__3.r, z__2.i = z__[i__5].i + + z__3.i; + z__1.r = v[i__4].r * z__2.r - v[i__4].i * z__2.i, + z__1.i = v[i__4].r * z__2.i + v[i__4].i * + z__2.r; + refsum.r = z__1.r, refsum.i = z__1.i; + i__4 = j + (k + 1) * z_dim1; + i__5 = j + (k + 1) * z_dim1; + z__1.r = z__[i__5].r - refsum.r, z__1.i = z__[i__5].i + - refsum.i; + z__[i__4].r = z__1.r, z__[i__4].i = z__1.i; + i__4 = j + (k + 2) * z_dim1; + i__5 = j + (k + 2) * z_dim1; + d_cnjg(&z__3, &v[m22 * v_dim1 + 2]); + z__2.r = refsum.r * z__3.r - refsum.i * z__3.i, + z__2.i = refsum.r * z__3.i + refsum.i * + z__3.r; + z__1.r = z__[i__5].r - z__2.r, z__1.i = z__[i__5].i - + z__2.i; + z__[i__4].r = z__1.r, z__[i__4].i = z__1.i; +/* L60: */ + } + } + } + +/* ==== Normal case: Chain of 3-by-3 reflections ==== */ + + i__6 = mtop; + for (m = mbot; m >= i__6; --m) { + k = krcol + (m - 1 << 1); + if (k == *ktop - 1) { + zlaqr1_(&c__3, &h__[*ktop + *ktop * h_dim1], ldh, &s[(m << + 1) - 1], &s[m * 2], &v[m * v_dim1 + 1]); + i__4 = m * v_dim1 + 1; + alpha.r = v[i__4].r, alpha.i = v[i__4].i; + zlarfg_(&c__3, &alpha, &v[m * v_dim1 + 2], &c__1, &v[m * + v_dim1 + 1]); + } else { + +/* ==== Perform delayed transformation of row below */ +/* . Mth bulge. Exploit fact that first two elements */ +/* . of row are actually zero. ==== */ + + i__4 = m * v_dim1 + 1; + i__5 = m * v_dim1 + 3; + z__2.r = v[i__4].r * v[i__5].r - v[i__4].i * v[i__5].i, + z__2.i = v[i__4].r * v[i__5].i + v[i__4].i * v[ + i__5].r; + i__7 = k + 3 + (k + 2) * h_dim1; + z__1.r = z__2.r * h__[i__7].r - z__2.i * h__[i__7].i, + z__1.i = z__2.r * h__[i__7].i + z__2.i * h__[i__7] + .r; + refsum.r = z__1.r, refsum.i = z__1.i; + i__4 = k + 3 + k * h_dim1; + z__1.r = -refsum.r, z__1.i = -refsum.i; + h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; + i__4 = k + 3 + (k + 1) * h_dim1; + z__2.r = -refsum.r, z__2.i = -refsum.i; + d_cnjg(&z__3, &v[m * v_dim1 + 2]); + z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = + z__2.r * z__3.i + z__2.i * z__3.r; + h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; + i__4 = k + 3 + (k + 2) * h_dim1; + i__5 = k + 3 + (k + 2) * h_dim1; + d_cnjg(&z__3, &v[m * v_dim1 + 3]); + z__2.r = refsum.r * z__3.r - refsum.i * z__3.i, z__2.i = + refsum.r * z__3.i + refsum.i * z__3.r; + z__1.r = h__[i__5].r - z__2.r, z__1.i = h__[i__5].i - + z__2.i; + h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; + +/* ==== Calculate reflection to move */ +/* . Mth bulge one step. ==== */ + + i__4 = k + 1 + k * h_dim1; + beta.r = h__[i__4].r, beta.i = h__[i__4].i; + i__4 = m * v_dim1 + 2; + i__5 = k + 2 + k * h_dim1; + v[i__4].r = h__[i__5].r, v[i__4].i = h__[i__5].i; + i__4 = m * v_dim1 + 3; + i__5 = k + 3 + k * h_dim1; + v[i__4].r = h__[i__5].r, v[i__4].i = h__[i__5].i; + zlarfg_(&c__3, &beta, &v[m * v_dim1 + 2], &c__1, &v[m * + v_dim1 + 1]); + +/* ==== A Bulge may collapse because of vigilant */ +/* . deflation or destructive underflow. In the */ +/* . underflow case, try the two-small-subdiagonals */ +/* . trick to try to reinflate the bulge. ==== */ + + i__4 = k + 3 + k * h_dim1; + i__5 = k + 3 + (k + 1) * h_dim1; + i__7 = k + 3 + (k + 2) * h_dim1; + if (h__[i__4].r != 0. || h__[i__4].i != 0. || (h__[i__5] + .r != 0. || h__[i__5].i != 0.) || h__[i__7].r == + 0. && h__[i__7].i == 0.) { + +/* ==== Typical case: not collapsed (yet). ==== */ + + i__4 = k + 1 + k * h_dim1; + h__[i__4].r = beta.r, h__[i__4].i = beta.i; + i__4 = k + 2 + k * h_dim1; + h__[i__4].r = 0., h__[i__4].i = 0.; + i__4 = k + 3 + k * h_dim1; + h__[i__4].r = 0., h__[i__4].i = 0.; + } else { + +/* ==== Atypical case: collapsed. Attempt to */ +/* . reintroduce ignoring H(K+1,K) and H(K+2,K). */ +/* . If the fill resulting from the new */ +/* . reflector is too large, then abandon it. */ +/* . Otherwise, use the new one. ==== */ + + zlaqr1_(&c__3, &h__[k + 1 + (k + 1) * h_dim1], ldh, & + s[(m << 1) - 1], &s[m * 2], vt); + alpha.r = vt[0].r, alpha.i = vt[0].i; + zlarfg_(&c__3, &alpha, &vt[1], &c__1, vt); + d_cnjg(&z__2, vt); + i__4 = k + 1 + k * h_dim1; + d_cnjg(&z__5, &vt[1]); + i__5 = k + 2 + k * h_dim1; + z__4.r = z__5.r * h__[i__5].r - z__5.i * h__[i__5].i, + z__4.i = z__5.r * h__[i__5].i + z__5.i * h__[ + i__5].r; + z__3.r = h__[i__4].r + z__4.r, z__3.i = h__[i__4].i + + z__4.i; + z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = + z__2.r * z__3.i + z__2.i * z__3.r; + refsum.r = z__1.r, refsum.i = z__1.i; + + i__4 = k + 2 + k * h_dim1; + z__3.r = refsum.r * vt[1].r - refsum.i * vt[1].i, + z__3.i = refsum.r * vt[1].i + refsum.i * vt[1] + .r; + z__2.r = h__[i__4].r - z__3.r, z__2.i = h__[i__4].i - + z__3.i; + z__1.r = z__2.r, z__1.i = z__2.i; + z__5.r = refsum.r * vt[2].r - refsum.i * vt[2].i, + z__5.i = refsum.r * vt[2].i + refsum.i * vt[2] + .r; + z__4.r = z__5.r, z__4.i = z__5.i; + i__5 = k + k * h_dim1; + i__7 = k + 1 + (k + 1) * h_dim1; + i__8 = k + 2 + (k + 2) * h_dim1; + if ((d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1) + , abs(d__2)) + ((d__3 = z__4.r, abs(d__3)) + ( + d__4 = d_imag(&z__4), abs(d__4))) > ulp * (( + d__5 = h__[i__5].r, abs(d__5)) + (d__6 = + d_imag(&h__[k + k * h_dim1]), abs(d__6)) + (( + d__7 = h__[i__7].r, abs(d__7)) + (d__8 = + d_imag(&h__[k + 1 + (k + 1) * h_dim1]), abs( + d__8))) + ((d__9 = h__[i__8].r, abs(d__9)) + ( + d__10 = d_imag(&h__[k + 2 + (k + 2) * h_dim1]) + , abs(d__10))))) { + +/* ==== Starting a new bulge here would */ +/* . create non-negligible fill. Use */ +/* . the old one with trepidation. ==== */ + + i__4 = k + 1 + k * h_dim1; + h__[i__4].r = beta.r, h__[i__4].i = beta.i; + i__4 = k + 2 + k * h_dim1; + h__[i__4].r = 0., h__[i__4].i = 0.; + i__4 = k + 3 + k * h_dim1; + h__[i__4].r = 0., h__[i__4].i = 0.; + } else { + +/* ==== Starting a new bulge here would */ +/* . create only negligible fill. */ +/* . Replace the old reflector with */ +/* . the new one. ==== */ + + i__4 = k + 1 + k * h_dim1; + i__5 = k + 1 + k * h_dim1; + z__1.r = h__[i__5].r - refsum.r, z__1.i = h__[ + i__5].i - refsum.i; + h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; + i__4 = k + 2 + k * h_dim1; + h__[i__4].r = 0., h__[i__4].i = 0.; + i__4 = k + 3 + k * h_dim1; + h__[i__4].r = 0., h__[i__4].i = 0.; + i__4 = m * v_dim1 + 1; + v[i__4].r = vt[0].r, v[i__4].i = vt[0].i; + i__4 = m * v_dim1 + 2; + v[i__4].r = vt[1].r, v[i__4].i = vt[1].i; + i__4 = m * v_dim1 + 3; + v[i__4].r = vt[2].r, v[i__4].i = vt[2].i; + } + } + } + +/* ==== Apply reflection from the right and */ +/* . the first column of update from the left. */ +/* . These updates are required for the vigilant */ +/* . deflation check. We still delay most of the */ +/* . updates from the left for efficiency. ==== */ + +/* Computing MIN */ + i__5 = *kbot, i__7 = k + 3; + i__4 = f2cmin(i__5,i__7); + for (j = jtop; j <= i__4; ++j) { + i__5 = m * v_dim1 + 1; + i__7 = j + (k + 1) * h_dim1; + i__8 = m * v_dim1 + 2; + i__9 = j + (k + 2) * h_dim1; + z__4.r = v[i__8].r * h__[i__9].r - v[i__8].i * h__[i__9] + .i, z__4.i = v[i__8].r * h__[i__9].i + v[i__8].i * + h__[i__9].r; + z__3.r = h__[i__7].r + z__4.r, z__3.i = h__[i__7].i + + z__4.i; + i__10 = m * v_dim1 + 3; + i__11 = j + (k + 3) * h_dim1; + z__5.r = v[i__10].r * h__[i__11].r - v[i__10].i * h__[ + i__11].i, z__5.i = v[i__10].r * h__[i__11].i + v[ + i__10].i * h__[i__11].r; + z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i; + z__1.r = v[i__5].r * z__2.r - v[i__5].i * z__2.i, z__1.i = + v[i__5].r * z__2.i + v[i__5].i * z__2.r; + refsum.r = z__1.r, refsum.i = z__1.i; + i__5 = j + (k + 1) * h_dim1; + i__7 = j + (k + 1) * h_dim1; + z__1.r = h__[i__7].r - refsum.r, z__1.i = h__[i__7].i - + refsum.i; + h__[i__5].r = z__1.r, h__[i__5].i = z__1.i; + i__5 = j + (k + 2) * h_dim1; + i__7 = j + (k + 2) * h_dim1; + d_cnjg(&z__3, &v[m * v_dim1 + 2]); + z__2.r = refsum.r * z__3.r - refsum.i * z__3.i, z__2.i = + refsum.r * z__3.i + refsum.i * z__3.r; + z__1.r = h__[i__7].r - z__2.r, z__1.i = h__[i__7].i - + z__2.i; + h__[i__5].r = z__1.r, h__[i__5].i = z__1.i; + i__5 = j + (k + 3) * h_dim1; + i__7 = j + (k + 3) * h_dim1; + d_cnjg(&z__3, &v[m * v_dim1 + 3]); + z__2.r = refsum.r * z__3.r - refsum.i * z__3.i, z__2.i = + refsum.r * z__3.i + refsum.i * z__3.r; + z__1.r = h__[i__7].r - z__2.r, z__1.i = h__[i__7].i - + z__2.i; + h__[i__5].r = z__1.r, h__[i__5].i = z__1.i; +/* L70: */ + } + +/* ==== Perform update from left for subsequent */ +/* . column. ==== */ + + d_cnjg(&z__2, &v[m * v_dim1 + 1]); + i__4 = k + 1 + (k + 1) * h_dim1; + d_cnjg(&z__6, &v[m * v_dim1 + 2]); + i__5 = k + 2 + (k + 1) * h_dim1; + z__5.r = z__6.r * h__[i__5].r - z__6.i * h__[i__5].i, z__5.i = + z__6.r * h__[i__5].i + z__6.i * h__[i__5].r; + z__4.r = h__[i__4].r + z__5.r, z__4.i = h__[i__4].i + z__5.i; + d_cnjg(&z__8, &v[m * v_dim1 + 3]); + i__7 = k + 3 + (k + 1) * h_dim1; + z__7.r = z__8.r * h__[i__7].r - z__8.i * h__[i__7].i, z__7.i = + z__8.r * h__[i__7].i + z__8.i * h__[i__7].r; + z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i; + z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * + z__3.i + z__2.i * z__3.r; + refsum.r = z__1.r, refsum.i = z__1.i; + i__4 = k + 1 + (k + 1) * h_dim1; + i__5 = k + 1 + (k + 1) * h_dim1; + z__1.r = h__[i__5].r - refsum.r, z__1.i = h__[i__5].i - + refsum.i; + h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; + i__4 = k + 2 + (k + 1) * h_dim1; + i__5 = k + 2 + (k + 1) * h_dim1; + i__7 = m * v_dim1 + 2; + z__2.r = refsum.r * v[i__7].r - refsum.i * v[i__7].i, z__2.i = + refsum.r * v[i__7].i + refsum.i * v[i__7].r; + z__1.r = h__[i__5].r - z__2.r, z__1.i = h__[i__5].i - z__2.i; + h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; + i__4 = k + 3 + (k + 1) * h_dim1; + i__5 = k + 3 + (k + 1) * h_dim1; + i__7 = m * v_dim1 + 3; + z__2.r = refsum.r * v[i__7].r - refsum.i * v[i__7].i, z__2.i = + refsum.r * v[i__7].i + refsum.i * v[i__7].r; + z__1.r = h__[i__5].r - z__2.r, z__1.i = h__[i__5].i - z__2.i; + h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; + +/* ==== The following convergence test requires that */ +/* . the tradition small-compared-to-nearby-diagonals */ +/* . criterion and the Ahues & Tisseur (LAWN 122, 1997) */ +/* . criteria both be satisfied. The latter improves */ +/* . accuracy in some examples. Falling back on an */ +/* . alternate convergence criterion when TST1 or TST2 */ +/* . is zero (as done here) is traditional but probably */ +/* . unnecessary. ==== */ + + if (k < *ktop) { + mycycle_(); + } + i__4 = k + 1 + k * h_dim1; + if (h__[i__4].r != 0. || h__[i__4].i != 0.) { + i__4 = k + k * h_dim1; + i__5 = k + 1 + (k + 1) * h_dim1; + tst1 = (d__1 = h__[i__4].r, abs(d__1)) + (d__2 = d_imag(& + h__[k + k * h_dim1]), abs(d__2)) + ((d__3 = h__[ + i__5].r, abs(d__3)) + (d__4 = d_imag(&h__[k + 1 + + (k + 1) * h_dim1]), abs(d__4))); + if (tst1 == 0.) { + if (k >= *ktop + 1) { + i__4 = k + (k - 1) * h_dim1; + tst1 += (d__1 = h__[i__4].r, abs(d__1)) + (d__2 = + d_imag(&h__[k + (k - 1) * h_dim1]), abs( + d__2)); + } + if (k >= *ktop + 2) { + i__4 = k + (k - 2) * h_dim1; + tst1 += (d__1 = h__[i__4].r, abs(d__1)) + (d__2 = + d_imag(&h__[k + (k - 2) * h_dim1]), abs( + d__2)); + } + if (k >= *ktop + 3) { + i__4 = k + (k - 3) * h_dim1; + tst1 += (d__1 = h__[i__4].r, abs(d__1)) + (d__2 = + d_imag(&h__[k + (k - 3) * h_dim1]), abs( + d__2)); + } + if (k <= *kbot - 2) { + i__4 = k + 2 + (k + 1) * h_dim1; + tst1 += (d__1 = h__[i__4].r, abs(d__1)) + (d__2 = + d_imag(&h__[k + 2 + (k + 1) * h_dim1]), + abs(d__2)); + } + if (k <= *kbot - 3) { + i__4 = k + 3 + (k + 1) * h_dim1; + tst1 += (d__1 = h__[i__4].r, abs(d__1)) + (d__2 = + d_imag(&h__[k + 3 + (k + 1) * h_dim1]), + abs(d__2)); + } + if (k <= *kbot - 4) { + i__4 = k + 4 + (k + 1) * h_dim1; + tst1 += (d__1 = h__[i__4].r, abs(d__1)) + (d__2 = + d_imag(&h__[k + 4 + (k + 1) * h_dim1]), + abs(d__2)); + } + } + i__4 = k + 1 + k * h_dim1; +/* Computing MAX */ + d__3 = smlnum, d__4 = ulp * tst1; + if ((d__1 = h__[i__4].r, abs(d__1)) + (d__2 = d_imag(&h__[ + k + 1 + k * h_dim1]), abs(d__2)) <= f2cmax(d__3,d__4) + ) { +/* Computing MAX */ + i__4 = k + 1 + k * h_dim1; + i__5 = k + (k + 1) * h_dim1; + d__5 = (d__1 = h__[i__4].r, abs(d__1)) + (d__2 = + d_imag(&h__[k + 1 + k * h_dim1]), abs(d__2)), + d__6 = (d__3 = h__[i__5].r, abs(d__3)) + ( + d__4 = d_imag(&h__[k + (k + 1) * h_dim1]), + abs(d__4)); + h12 = f2cmax(d__5,d__6); +/* Computing MIN */ + i__4 = k + 1 + k * h_dim1; + i__5 = k + (k + 1) * h_dim1; + d__5 = (d__1 = h__[i__4].r, abs(d__1)) + (d__2 = + d_imag(&h__[k + 1 + k * h_dim1]), abs(d__2)), + d__6 = (d__3 = h__[i__5].r, abs(d__3)) + ( + d__4 = d_imag(&h__[k + (k + 1) * h_dim1]), + abs(d__4)); + h21 = f2cmin(d__5,d__6); + i__4 = k + k * h_dim1; + i__5 = k + 1 + (k + 1) * h_dim1; + z__2.r = h__[i__4].r - h__[i__5].r, z__2.i = h__[i__4] + .i - h__[i__5].i; + z__1.r = z__2.r, z__1.i = z__2.i; +/* Computing MAX */ + i__7 = k + 1 + (k + 1) * h_dim1; + d__5 = (d__1 = h__[i__7].r, abs(d__1)) + (d__2 = + d_imag(&h__[k + 1 + (k + 1) * h_dim1]), abs( + d__2)), d__6 = (d__3 = z__1.r, abs(d__3)) + ( + d__4 = d_imag(&z__1), abs(d__4)); + h11 = f2cmax(d__5,d__6); + i__4 = k + k * h_dim1; + i__5 = k + 1 + (k + 1) * h_dim1; + z__2.r = h__[i__4].r - h__[i__5].r, z__2.i = h__[i__4] + .i - h__[i__5].i; + z__1.r = z__2.r, z__1.i = z__2.i; +/* Computing MIN */ + i__7 = k + 1 + (k + 1) * h_dim1; + d__5 = (d__1 = h__[i__7].r, abs(d__1)) + (d__2 = + d_imag(&h__[k + 1 + (k + 1) * h_dim1]), abs( + d__2)), d__6 = (d__3 = z__1.r, abs(d__3)) + ( + d__4 = d_imag(&z__1), abs(d__4)); + h22 = f2cmin(d__5,d__6); + scl = h11 + h12; + tst2 = h22 * (h11 / scl); + +/* Computing MAX */ + d__1 = smlnum, d__2 = ulp * tst2; + if (tst2 == 0. || h21 * (h12 / scl) <= f2cmax(d__1,d__2)) + { + i__4 = k + 1 + k * h_dim1; + h__[i__4].r = 0., h__[i__4].i = 0.; + } + } + } +/* L80: */ + } + +/* ==== Multiply H by reflections from the left ==== */ + + if (accum) { + jbot = f2cmin(ndcol,*kbot); + } else if (*wantt) { + jbot = *n; + } else { + jbot = *kbot; + } + + i__6 = mtop; + for (m = mbot; m >= i__6; --m) { + k = krcol + (m - 1 << 1); +/* Computing MAX */ + i__4 = *ktop, i__5 = krcol + (m << 1); + i__7 = jbot; + for (j = f2cmax(i__4,i__5); j <= i__7; ++j) { + d_cnjg(&z__2, &v[m * v_dim1 + 1]); + i__4 = k + 1 + j * h_dim1; + d_cnjg(&z__6, &v[m * v_dim1 + 2]); + i__5 = k + 2 + j * h_dim1; + z__5.r = z__6.r * h__[i__5].r - z__6.i * h__[i__5].i, + z__5.i = z__6.r * h__[i__5].i + z__6.i * h__[i__5] + .r; + z__4.r = h__[i__4].r + z__5.r, z__4.i = h__[i__4].i + + z__5.i; + d_cnjg(&z__8, &v[m * v_dim1 + 3]); + i__8 = k + 3 + j * h_dim1; + z__7.r = z__8.r * h__[i__8].r - z__8.i * h__[i__8].i, + z__7.i = z__8.r * h__[i__8].i + z__8.i * h__[i__8] + .r; + z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i; + z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = + z__2.r * z__3.i + z__2.i * z__3.r; + refsum.r = z__1.r, refsum.i = z__1.i; + i__4 = k + 1 + j * h_dim1; + i__5 = k + 1 + j * h_dim1; + z__1.r = h__[i__5].r - refsum.r, z__1.i = h__[i__5].i - + refsum.i; + h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; + i__4 = k + 2 + j * h_dim1; + i__5 = k + 2 + j * h_dim1; + i__8 = m * v_dim1 + 2; + z__2.r = refsum.r * v[i__8].r - refsum.i * v[i__8].i, + z__2.i = refsum.r * v[i__8].i + refsum.i * v[i__8] + .r; + z__1.r = h__[i__5].r - z__2.r, z__1.i = h__[i__5].i - + z__2.i; + h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; + i__4 = k + 3 + j * h_dim1; + i__5 = k + 3 + j * h_dim1; + i__8 = m * v_dim1 + 3; + z__2.r = refsum.r * v[i__8].r - refsum.i * v[i__8].i, + z__2.i = refsum.r * v[i__8].i + refsum.i * v[i__8] + .r; + z__1.r = h__[i__5].r - z__2.r, z__1.i = h__[i__5].i - + z__2.i; + h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; +/* L90: */ + } +/* L100: */ + } + +/* ==== Accumulate orthogonal transformations. ==== */ + + if (accum) { + +/* ==== Accumulate U. (If needed, update Z later */ +/* . with an efficient matrix-matrix */ +/* . multiply.) ==== */ + + i__6 = mtop; + for (m = mbot; m >= i__6; --m) { + k = krcol + (m - 1 << 1); + kms = k - incol; +/* Computing MAX */ + i__7 = 1, i__4 = *ktop - incol; + i2 = f2cmax(i__7,i__4); +/* Computing MAX */ + i__7 = i2, i__4 = kms - (krcol - incol) + 1; + i2 = f2cmax(i__7,i__4); +/* Computing MIN */ + i__7 = kdu, i__4 = krcol + (mbot - 1 << 1) - incol + 5; + i4 = f2cmin(i__7,i__4); + i__7 = i4; + for (j = i2; j <= i__7; ++j) { + i__4 = m * v_dim1 + 1; + i__5 = j + (kms + 1) * u_dim1; + i__8 = m * v_dim1 + 2; + i__9 = j + (kms + 2) * u_dim1; + z__4.r = v[i__8].r * u[i__9].r - v[i__8].i * u[i__9] + .i, z__4.i = v[i__8].r * u[i__9].i + v[i__8] + .i * u[i__9].r; + z__3.r = u[i__5].r + z__4.r, z__3.i = u[i__5].i + + z__4.i; + i__10 = m * v_dim1 + 3; + i__11 = j + (kms + 3) * u_dim1; + z__5.r = v[i__10].r * u[i__11].r - v[i__10].i * u[ + i__11].i, z__5.i = v[i__10].r * u[i__11].i + + v[i__10].i * u[i__11].r; + z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i; + z__1.r = v[i__4].r * z__2.r - v[i__4].i * z__2.i, + z__1.i = v[i__4].r * z__2.i + v[i__4].i * + z__2.r; + refsum.r = z__1.r, refsum.i = z__1.i; + i__4 = j + (kms + 1) * u_dim1; + i__5 = j + (kms + 1) * u_dim1; + z__1.r = u[i__5].r - refsum.r, z__1.i = u[i__5].i - + refsum.i; + u[i__4].r = z__1.r, u[i__4].i = z__1.i; + i__4 = j + (kms + 2) * u_dim1; + i__5 = j + (kms + 2) * u_dim1; + d_cnjg(&z__3, &v[m * v_dim1 + 2]); + z__2.r = refsum.r * z__3.r - refsum.i * z__3.i, + z__2.i = refsum.r * z__3.i + refsum.i * + z__3.r; + z__1.r = u[i__5].r - z__2.r, z__1.i = u[i__5].i - + z__2.i; + u[i__4].r = z__1.r, u[i__4].i = z__1.i; + i__4 = j + (kms + 3) * u_dim1; + i__5 = j + (kms + 3) * u_dim1; + d_cnjg(&z__3, &v[m * v_dim1 + 3]); + z__2.r = refsum.r * z__3.r - refsum.i * z__3.i, + z__2.i = refsum.r * z__3.i + refsum.i * + z__3.r; + z__1.r = u[i__5].r - z__2.r, z__1.i = u[i__5].i - + z__2.i; + u[i__4].r = z__1.r, u[i__4].i = z__1.i; +/* L110: */ + } +/* L120: */ + } + } else if (*wantz) { + +/* ==== U is not accumulated, so update Z */ +/* . now by multiplying by reflections */ +/* . from the right. ==== */ + + i__6 = mtop; + for (m = mbot; m >= i__6; --m) { + k = krcol + (m - 1 << 1); + i__7 = *ihiz; + for (j = *iloz; j <= i__7; ++j) { + i__4 = m * v_dim1 + 1; + i__5 = j + (k + 1) * z_dim1; + i__8 = m * v_dim1 + 2; + i__9 = j + (k + 2) * z_dim1; + z__4.r = v[i__8].r * z__[i__9].r - v[i__8].i * z__[ + i__9].i, z__4.i = v[i__8].r * z__[i__9].i + v[ + i__8].i * z__[i__9].r; + z__3.r = z__[i__5].r + z__4.r, z__3.i = z__[i__5].i + + z__4.i; + i__10 = m * v_dim1 + 3; + i__11 = j + (k + 3) * z_dim1; + z__5.r = v[i__10].r * z__[i__11].r - v[i__10].i * z__[ + i__11].i, z__5.i = v[i__10].r * z__[i__11].i + + v[i__10].i * z__[i__11].r; + z__2.r = z__3.r + z__5.r, z__2.i = z__3.i + z__5.i; + z__1.r = v[i__4].r * z__2.r - v[i__4].i * z__2.i, + z__1.i = v[i__4].r * z__2.i + v[i__4].i * + z__2.r; + refsum.r = z__1.r, refsum.i = z__1.i; + i__4 = j + (k + 1) * z_dim1; + i__5 = j + (k + 1) * z_dim1; + z__1.r = z__[i__5].r - refsum.r, z__1.i = z__[i__5].i + - refsum.i; + z__[i__4].r = z__1.r, z__[i__4].i = z__1.i; + i__4 = j + (k + 2) * z_dim1; + i__5 = j + (k + 2) * z_dim1; + d_cnjg(&z__3, &v[m * v_dim1 + 2]); + z__2.r = refsum.r * z__3.r - refsum.i * z__3.i, + z__2.i = refsum.r * z__3.i + refsum.i * + z__3.r; + z__1.r = z__[i__5].r - z__2.r, z__1.i = z__[i__5].i - + z__2.i; + z__[i__4].r = z__1.r, z__[i__4].i = z__1.i; + i__4 = j + (k + 3) * z_dim1; + i__5 = j + (k + 3) * z_dim1; + d_cnjg(&z__3, &v[m * v_dim1 + 3]); + z__2.r = refsum.r * z__3.r - refsum.i * z__3.i, + z__2.i = refsum.r * z__3.i + refsum.i * + z__3.r; + z__1.r = z__[i__5].r - z__2.r, z__1.i = z__[i__5].i - + z__2.i; + z__[i__4].r = z__1.r, z__[i__4].i = z__1.i; +/* L130: */ + } +/* L140: */ + } + } + +/* ==== End of near-the-diagonal bulge chase. ==== */ + +/* L145: */ + } + +/* ==== Use U (if accumulated) to update far-from-diagonal */ +/* . entries in H. If required, use U to update Z as */ +/* . well. ==== */ + + if (accum) { + if (*wantt) { + jtop = 1; + jbot = *n; + } else { + jtop = *ktop; + jbot = *kbot; + } +/* Computing MAX */ + i__3 = 1, i__6 = *ktop - incol; + k1 = f2cmax(i__3,i__6); +/* Computing MAX */ + i__3 = 0, i__6 = ndcol - *kbot; + nu = kdu - f2cmax(i__3,i__6) - k1 + 1; + +/* ==== Horizontal Multiply ==== */ + + i__3 = jbot; + i__6 = *nh; + for (jcol = f2cmin(ndcol,*kbot) + 1; i__6 < 0 ? jcol >= i__3 : jcol + <= i__3; jcol += i__6) { +/* Computing MIN */ + i__7 = *nh, i__4 = jbot - jcol + 1; + jlen = f2cmin(i__7,i__4); + zgemm_("C", "N", &nu, &jlen, &nu, &c_b2, &u[k1 + k1 * u_dim1], + ldu, &h__[incol + k1 + jcol * h_dim1], ldh, &c_b1, & + wh[wh_offset], ldwh); + zlacpy_("ALL", &nu, &jlen, &wh[wh_offset], ldwh, &h__[incol + + k1 + jcol * h_dim1], ldh); +/* L150: */ + } + +/* ==== Vertical multiply ==== */ + + i__6 = f2cmax(*ktop,incol) - 1; + i__3 = *nv; + for (jrow = jtop; i__3 < 0 ? jrow >= i__6 : jrow <= i__6; jrow += + i__3) { +/* Computing MIN */ + i__7 = *nv, i__4 = f2cmax(*ktop,incol) - jrow; + jlen = f2cmin(i__7,i__4); + zgemm_("N", "N", &jlen, &nu, &nu, &c_b2, &h__[jrow + (incol + + k1) * h_dim1], ldh, &u[k1 + k1 * u_dim1], ldu, &c_b1, + &wv[wv_offset], ldwv); + zlacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &h__[jrow + ( + incol + k1) * h_dim1], ldh); +/* L160: */ + } + +/* ==== Z multiply (also vertical) ==== */ + + if (*wantz) { + i__3 = *ihiz; + i__6 = *nv; + for (jrow = *iloz; i__6 < 0 ? jrow >= i__3 : jrow <= i__3; + jrow += i__6) { +/* Computing MIN */ + i__7 = *nv, i__4 = *ihiz - jrow + 1; + jlen = f2cmin(i__7,i__4); + zgemm_("N", "N", &jlen, &nu, &nu, &c_b2, &z__[jrow + ( + incol + k1) * z_dim1], ldz, &u[k1 + k1 * u_dim1], + ldu, &c_b1, &wv[wv_offset], ldwv); + zlacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &z__[ + jrow + (incol + k1) * z_dim1], ldz); +/* L170: */ + } + } + } +/* L180: */ + } + +/* ==== End of ZLAQR5 ==== */ + + return 0; +} /* zlaqr5_ */ + diff --git a/lapack-netlib/SRC/zlaqsb.c b/lapack-netlib/SRC/zlaqsb.c new file mode 100644 index 000000000..5898c0e7f --- /dev/null +++ b/lapack-netlib/SRC/zlaqsb.c @@ -0,0 +1,632 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAQSB scales a symmetric/Hermitian band matrix, using scaling factors computed by spbequ. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAQSB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) */ + +/* CHARACTER EQUED, UPLO */ +/* INTEGER KD, LDAB, N */ +/* DOUBLE PRECISION AMAX, SCOND */ +/* DOUBLE PRECISION S( * ) */ +/* COMPLEX*16 AB( LDAB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAQSB equilibrates a symmetric band matrix A using the scaling */ +/* > factors in the vector S. */ +/* > \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] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of super-diagonals of the matrix A if UPLO = 'U', */ +/* > or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is COMPLEX*16 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, if INFO = 0, the triangular factor U or L from the */ +/* > Cholesky factorization A = U**H *U or A = L*L**H of the band */ +/* > matrix A, in the same storage format as A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is DOUBLE PRECISION array, dimension (N) */ +/* > The scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SCOND */ +/* > \verbatim */ +/* > SCOND is DOUBLE PRECISION */ +/* > Ratio of the smallest S(i) to the largest S(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AMAX */ +/* > \verbatim */ +/* > AMAX is DOUBLE PRECISION */ +/* > Absolute value of largest matrix entry. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies whether or not equilibration was done. */ +/* > = 'N': No equilibration. */ +/* > = 'Y': Equilibration was done, i.e., A has been replaced by */ +/* > diag(S) * A * diag(S). */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > THRESH is a threshold value used to decide if scaling should be done */ +/* > based on the ratio of the scaling factors. If SCOND < THRESH, */ +/* > scaling is done. */ +/* > */ +/* > LARGE and SMALL are threshold values used to decide if scaling should */ +/* > be done based on the absolute size of the largest matrix element. */ +/* > If AMAX > LARGE or AMAX < SMALL, scaling is done. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlaqsb_(char *uplo, integer *n, integer *kd, + doublecomplex *ab, integer *ldab, doublereal *s, doublereal *scond, + doublereal *amax, char *equed) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; + doublereal d__1; + doublecomplex z__1; + + /* Local variables */ + integer i__, j; + doublereal large; + extern logical lsame_(char *, char *); + doublereal small, cj; + extern doublereal dlamch_(char *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --s; + + /* Function Body */ + if (*n <= 0) { + *(unsigned char *)equed = 'N'; + return 0; + } + +/* Initialize LARGE and SMALL. */ + + small = dlamch_("Safe minimum") / dlamch_("Precision"); + large = 1. / small; + + if (*scond >= .1 && *amax >= small && *amax <= large) { + +/* No equilibration */ + + *(unsigned char *)equed = 'N'; + } else { + +/* Replace A by diag(S) * A * diag(S). */ + + if (lsame_(uplo, "U")) { + +/* Upper triangle of A is stored in band format. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; +/* Computing MAX */ + i__2 = 1, i__3 = j - *kd; + i__4 = j; + for (i__ = f2cmax(i__2,i__3); i__ <= i__4; ++i__) { + i__2 = *kd + 1 + i__ - j + j * ab_dim1; + d__1 = cj * s[i__]; + i__3 = *kd + 1 + i__ - j + j * ab_dim1; + z__1.r = d__1 * ab[i__3].r, z__1.i = d__1 * ab[i__3].i; + ab[i__2].r = z__1.r, ab[i__2].i = z__1.i; +/* L10: */ + } +/* L20: */ + } + } else { + +/* Lower triangle of A is stored. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; +/* Computing MIN */ + i__2 = *n, i__3 = j + *kd; + i__4 = f2cmin(i__2,i__3); + for (i__ = j; i__ <= i__4; ++i__) { + i__2 = i__ + 1 - j + j * ab_dim1; + d__1 = cj * s[i__]; + i__3 = i__ + 1 - j + j * ab_dim1; + z__1.r = d__1 * ab[i__3].r, z__1.i = d__1 * ab[i__3].i; + ab[i__2].r = z__1.r, ab[i__2].i = z__1.i; +/* L30: */ + } +/* L40: */ + } + } + *(unsigned char *)equed = 'Y'; + } + + return 0; + +/* End of ZLAQSB */ + +} /* zlaqsb_ */ + diff --git a/lapack-netlib/SRC/zlaqsp.c b/lapack-netlib/SRC/zlaqsp.c new file mode 100644 index 000000000..8df78f785 --- /dev/null +++ b/lapack-netlib/SRC/zlaqsp.c @@ -0,0 +1,617 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAQSP scales a symmetric/Hermitian matrix in packed storage, using scaling factors computed by + sppequ. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAQSP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) */ + +/* CHARACTER EQUED, UPLO */ +/* INTEGER N */ +/* DOUBLE PRECISION AMAX, SCOND */ +/* DOUBLE PRECISION S( * ) */ +/* COMPLEX*16 AP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAQSP equilibrates a symmetric matrix A using the scaling factors */ +/* > in the vector S. */ +/* > \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] AP */ +/* > \verbatim */ +/* > AP is COMPLEX*16 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, the equilibrated matrix: diag(S) * A * diag(S), in */ +/* > the same storage format as A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is DOUBLE PRECISION array, dimension (N) */ +/* > The scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SCOND */ +/* > \verbatim */ +/* > SCOND is DOUBLE PRECISION */ +/* > Ratio of the smallest S(i) to the largest S(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AMAX */ +/* > \verbatim */ +/* > AMAX is DOUBLE PRECISION */ +/* > Absolute value of largest matrix entry. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies whether or not equilibration was done. */ +/* > = 'N': No equilibration. */ +/* > = 'Y': Equilibration was done, i.e., A has been replaced by */ +/* > diag(S) * A * diag(S). */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > THRESH is a threshold value used to decide if scaling should be done */ +/* > based on the ratio of the scaling factors. If SCOND < THRESH, */ +/* > scaling is done. */ +/* > */ +/* > LARGE and SMALL are threshold values used to decide if scaling should */ +/* > be done based on the absolute size of the largest matrix element. */ +/* > If AMAX > LARGE or AMAX < SMALL, scaling is done. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlaqsp_(char *uplo, integer *n, doublecomplex *ap, + doublereal *s, doublereal *scond, doublereal *amax, char *equed) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4; + doublereal d__1; + doublecomplex z__1; + + /* Local variables */ + integer i__, j; + doublereal large; + extern logical lsame_(char *, char *); + doublereal small; + integer jc; + doublereal cj; + extern doublereal dlamch_(char *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + --s; + --ap; + + /* Function Body */ + if (*n <= 0) { + *(unsigned char *)equed = 'N'; + return 0; + } + +/* Initialize LARGE and SMALL. */ + + small = dlamch_("Safe minimum") / dlamch_("Precision"); + large = 1. / small; + + if (*scond >= .1 && *amax >= small && *amax <= large) { + +/* No equilibration */ + + *(unsigned char *)equed = 'N'; + } else { + +/* Replace A by diag(S) * A * diag(S). */ + + if (lsame_(uplo, "U")) { + +/* Upper triangle of A is stored. */ + + jc = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = jc + i__ - 1; + d__1 = cj * s[i__]; + i__4 = jc + i__ - 1; + z__1.r = d__1 * ap[i__4].r, z__1.i = d__1 * ap[i__4].i; + ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; +/* L10: */ + } + jc += j; +/* L20: */ + } + } else { + +/* Lower triangle of A is stored. */ + + jc = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = jc + i__ - j; + d__1 = cj * s[i__]; + i__4 = jc + i__ - j; + z__1.r = d__1 * ap[i__4].r, z__1.i = d__1 * ap[i__4].i; + ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; +/* L30: */ + } + jc = jc + *n - j + 1; +/* L40: */ + } + } + *(unsigned char *)equed = 'Y'; + } + + return 0; + +/* End of ZLAQSP */ + +} /* zlaqsp_ */ + diff --git a/lapack-netlib/SRC/zlaqsy.c b/lapack-netlib/SRC/zlaqsy.c new file mode 100644 index 000000000..0ee5953ce --- /dev/null +++ b/lapack-netlib/SRC/zlaqsy.c @@ -0,0 +1,621 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAQSY scales a symmetric/Hermitian matrix, using scaling factors computed by spoequ. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAQSY + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) */ + +/* CHARACTER EQUED, UPLO */ +/* INTEGER LDA, N */ +/* DOUBLE PRECISION AMAX, SCOND */ +/* DOUBLE PRECISION S( * ) */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAQSY equilibrates a symmetric matrix A using the scaling factors */ +/* > in the vector S. */ +/* > \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 COMPLEX*16 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 EQUED = 'Y', the equilibrated matrix: */ +/* > diag(S) * A * diag(S). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(N,1). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is DOUBLE PRECISION array, dimension (N) */ +/* > The scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SCOND */ +/* > \verbatim */ +/* > SCOND is DOUBLE PRECISION */ +/* > Ratio of the smallest S(i) to the largest S(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AMAX */ +/* > \verbatim */ +/* > AMAX is DOUBLE PRECISION */ +/* > Absolute value of largest matrix entry. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies whether or not equilibration was done. */ +/* > = 'N': No equilibration. */ +/* > = 'Y': Equilibration was done, i.e., A has been replaced by */ +/* > diag(S) * A * diag(S). */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > THRESH is a threshold value used to decide if scaling should be done */ +/* > based on the ratio of the scaling factors. If SCOND < THRESH, */ +/* > scaling is done. */ +/* > */ +/* > LARGE and SMALL are threshold values used to decide if scaling should */ +/* > be done based on the absolute size of the largest matrix element. */ +/* > If AMAX > LARGE or AMAX < SMALL, scaling is done. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16SYauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlaqsy_(char *uplo, integer *n, doublecomplex *a, + integer *lda, doublereal *s, doublereal *scond, doublereal *amax, + char *equed) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + doublereal d__1; + doublecomplex z__1; + + /* Local variables */ + integer i__, j; + doublereal large; + extern logical lsame_(char *, char *); + doublereal small, cj; + extern doublereal dlamch_(char *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --s; + + /* Function Body */ + if (*n <= 0) { + *(unsigned char *)equed = 'N'; + return 0; + } + +/* Initialize LARGE and SMALL. */ + + small = dlamch_("Safe minimum") / dlamch_("Precision"); + large = 1. / small; + + if (*scond >= .1 && *amax >= small && *amax <= large) { + +/* No equilibration */ + + *(unsigned char *)equed = 'N'; + } else { + +/* Replace A by diag(S) * A * diag(S). */ + + if (lsame_(uplo, "U")) { + +/* Upper triangle of A is stored. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + d__1 = cj * s[i__]; + i__4 = i__ + j * a_dim1; + z__1.r = d__1 * a[i__4].r, z__1.i = d__1 * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L10: */ + } +/* L20: */ + } + } else { + +/* Lower triangle of A is stored. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + d__1 = cj * s[i__]; + i__4 = i__ + j * a_dim1; + z__1.r = d__1 * a[i__4].r, z__1.i = d__1 * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L30: */ + } +/* L40: */ + } + } + *(unsigned char *)equed = 'Y'; + } + + return 0; + +/* End of ZLAQSY */ + +} /* zlaqsy_ */ + diff --git a/lapack-netlib/SRC/zlar1v.c b/lapack-netlib/SRC/zlar1v.c new file mode 100644 index 000000000..0f0eeb27d --- /dev/null +++ b/lapack-netlib/SRC/zlar1v.c @@ -0,0 +1,975 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAR1V computes the (scaled) r-th column of the inverse of the submatrix in rows b1 through bn +of the tridiagonal matrix LDLT - λI. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAR1V + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, */ +/* PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, */ +/* R, ISUPPZ, NRMINV, RESID, RQCORR, WORK ) */ + +/* LOGICAL WANTNC */ +/* INTEGER B1, BN, N, NEGCNT, R */ +/* DOUBLE PRECISION GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID, */ +/* $ RQCORR, ZTZ */ +/* INTEGER ISUPPZ( * ) */ +/* DOUBLE PRECISION D( * ), L( * ), LD( * ), LLD( * ), */ +/* $ WORK( * ) */ +/* COMPLEX*16 Z( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAR1V computes the (scaled) r-th column of the inverse of */ +/* > the sumbmatrix in rows B1 through BN of the tridiagonal matrix */ +/* > L D L**T - sigma I. When sigma is close to an eigenvalue, the */ +/* > computed vector is an accurate eigenvector. Usually, r corresponds */ +/* > to the index where the eigenvector is largest in magnitude. */ +/* > The following steps accomplish this computation : */ +/* > (a) Stationary qd transform, L D L**T - sigma I = L(+) D(+) L(+)**T, */ +/* > (b) Progressive qd transform, L D L**T - sigma I = U(-) D(-) U(-)**T, */ +/* > (c) Computation of the diagonal elements of the inverse of */ +/* > L D L**T - sigma I by combining the above transforms, and choosing */ +/* > r as the index where the diagonal of the inverse is (one of the) */ +/* > largest in magnitude. */ +/* > (d) Computation of the (scaled) r-th column of the inverse using the */ +/* > twisted factorization obtained by combining the top part of the */ +/* > the stationary and the bottom part of the progressive transform. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix L D L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B1 */ +/* > \verbatim */ +/* > B1 is INTEGER */ +/* > First index of the submatrix of L D L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BN */ +/* > \verbatim */ +/* > BN is INTEGER */ +/* > Last index of the submatrix of L D L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LAMBDA */ +/* > \verbatim */ +/* > LAMBDA is DOUBLE PRECISION */ +/* > The shift. In order to compute an accurate eigenvector, */ +/* > LAMBDA should be a good approximation to an eigenvalue */ +/* > of L D L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is DOUBLE PRECISION array, dimension (N-1) */ +/* > The (n-1) subdiagonal elements of the unit bidiagonal matrix */ +/* > L, in elements 1 to N-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The n diagonal elements of the diagonal matrix D. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LD */ +/* > \verbatim */ +/* > LD is DOUBLE PRECISION array, dimension (N-1) */ +/* > The n-1 elements L(i)*D(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LLD */ +/* > \verbatim */ +/* > LLD is DOUBLE PRECISION array, dimension (N-1) */ +/* > The n-1 elements L(i)*L(i)*D(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PIVMIN */ +/* > \verbatim */ +/* > PIVMIN is DOUBLE PRECISION */ +/* > The minimum pivot in the Sturm sequence. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GAPTOL */ +/* > \verbatim */ +/* > GAPTOL is DOUBLE PRECISION */ +/* > Tolerance that indicates when eigenvector entries are negligible */ +/* > w.r.t. their contribution to the residual. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX*16 array, dimension (N) */ +/* > On input, all entries of Z must be set to 0. */ +/* > On output, Z contains the (scaled) r-th column of the */ +/* > inverse. The scaling is such that Z(R) equals 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTNC */ +/* > \verbatim */ +/* > WANTNC is LOGICAL */ +/* > Specifies whether NEGCNT has to be computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] NEGCNT */ +/* > \verbatim */ +/* > NEGCNT is INTEGER */ +/* > If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin */ +/* > in the matrix factorization L D L**T, and NEGCNT = -1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ZTZ */ +/* > \verbatim */ +/* > ZTZ is DOUBLE PRECISION */ +/* > The square of the 2-norm of Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] MINGMA */ +/* > \verbatim */ +/* > MINGMA is DOUBLE PRECISION */ +/* > The reciprocal of the largest (in magnitude) diagonal */ +/* > element of the inverse of L D L**T - sigma I. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] R */ +/* > \verbatim */ +/* > R is INTEGER */ +/* > The twist index for the twisted factorization used to */ +/* > compute Z. */ +/* > On input, 0 <= R <= N. If R is input as 0, R is set to */ +/* > the index where (L D L**T - sigma I)^{-1} is largest */ +/* > in magnitude. If 1 <= R <= N, R is unchanged. */ +/* > On output, R contains the twist index used to compute Z. */ +/* > Ideally, R designates the position of the maximum entry in the */ +/* > eigenvector. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ISUPPZ */ +/* > \verbatim */ +/* > ISUPPZ is INTEGER array, dimension (2) */ +/* > The support of the vector in Z, i.e., the vector Z is */ +/* > nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] NRMINV */ +/* > \verbatim */ +/* > NRMINV is DOUBLE PRECISION */ +/* > NRMINV = 1/SQRT( ZTZ ) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RESID */ +/* > \verbatim */ +/* > RESID is DOUBLE PRECISION */ +/* > The residual of the FP vector. */ +/* > RESID = ABS( MINGMA )/SQRT( ZTZ ) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RQCORR */ +/* > \verbatim */ +/* > RQCORR is DOUBLE PRECISION */ +/* > The Rayleigh Quotient correction to LAMBDA. */ +/* > RQCORR = MINGMA*TMP */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (4*N) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Beresford Parlett, University of California, Berkeley, USA \n */ +/* > Jim Demmel, University of California, Berkeley, USA \n */ +/* > Inderjit Dhillon, University of Texas, Austin, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ +/* > Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ +/* Subroutine */ int zlar1v_(integer *n, integer *b1, integer *bn, doublereal + *lambda, doublereal *d__, doublereal *l, doublereal *ld, doublereal * + lld, doublereal *pivmin, doublereal *gaptol, doublecomplex *z__, + logical *wantnc, integer *negcnt, doublereal *ztz, doublereal *mingma, + integer *r__, integer *isuppz, doublereal *nrminv, doublereal *resid, + doublereal *rqcorr, doublereal *work) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4; + doublereal d__1; + doublecomplex z__1, z__2; + + /* Local variables */ + integer indp, inds, i__; + doublereal s, dplus; + integer r1, r2; + extern doublereal dlamch_(char *); + extern logical disnan_(doublereal *); + integer indlpl, indumn; + doublereal dminus; + logical sawnan1, sawnan2; + doublereal eps, tmp; + integer neg1, neg2; + + +/* -- 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 */ + --work; + --isuppz; + --z__; + --lld; + --ld; + --l; + --d__; + + /* Function Body */ + eps = dlamch_("Precision"); + if (*r__ == 0) { + r1 = *b1; + r2 = *bn; + } else { + r1 = *r__; + r2 = *r__; + } +/* Storage for LPLUS */ + indlpl = 0; +/* Storage for UMINUS */ + indumn = *n; + inds = (*n << 1) + 1; + indp = *n * 3 + 1; + if (*b1 == 1) { + work[inds] = 0.; + } else { + work[inds + *b1 - 1] = lld[*b1 - 1]; + } + +/* Compute the stationary transform (using the differential form) */ +/* until the index R2. */ + + sawnan1 = FALSE_; + neg1 = 0; + s = work[inds + *b1 - 1] - *lambda; + i__1 = r1 - 1; + for (i__ = *b1; i__ <= i__1; ++i__) { + dplus = d__[i__] + s; + work[indlpl + i__] = ld[i__] / dplus; + if (dplus < 0.) { + ++neg1; + } + work[inds + i__] = s * work[indlpl + i__] * l[i__]; + s = work[inds + i__] - *lambda; +/* L50: */ + } + sawnan1 = disnan_(&s); + if (sawnan1) { + goto L60; + } + i__1 = r2 - 1; + for (i__ = r1; i__ <= i__1; ++i__) { + dplus = d__[i__] + s; + work[indlpl + i__] = ld[i__] / dplus; + work[inds + i__] = s * work[indlpl + i__] * l[i__]; + s = work[inds + i__] - *lambda; +/* L51: */ + } + sawnan1 = disnan_(&s); + +L60: + if (sawnan1) { +/* Runs a slower version of the above loop if a NaN is detected */ + neg1 = 0; + s = work[inds + *b1 - 1] - *lambda; + i__1 = r1 - 1; + for (i__ = *b1; i__ <= i__1; ++i__) { + dplus = d__[i__] + s; + if (abs(dplus) < *pivmin) { + dplus = -(*pivmin); + } + work[indlpl + i__] = ld[i__] / dplus; + if (dplus < 0.) { + ++neg1; + } + work[inds + i__] = s * work[indlpl + i__] * l[i__]; + if (work[indlpl + i__] == 0.) { + work[inds + i__] = lld[i__]; + } + s = work[inds + i__] - *lambda; +/* L70: */ + } + i__1 = r2 - 1; + for (i__ = r1; i__ <= i__1; ++i__) { + dplus = d__[i__] + s; + if (abs(dplus) < *pivmin) { + dplus = -(*pivmin); + } + work[indlpl + i__] = ld[i__] / dplus; + work[inds + i__] = s * work[indlpl + i__] * l[i__]; + if (work[indlpl + i__] == 0.) { + work[inds + i__] = lld[i__]; + } + s = work[inds + i__] - *lambda; +/* L71: */ + } + } + +/* Compute the progressive transform (using the differential form) */ +/* until the index R1 */ + + sawnan2 = FALSE_; + neg2 = 0; + work[indp + *bn - 1] = d__[*bn] - *lambda; + i__1 = r1; + for (i__ = *bn - 1; i__ >= i__1; --i__) { + dminus = lld[i__] + work[indp + i__]; + tmp = d__[i__] / dminus; + if (dminus < 0.) { + ++neg2; + } + work[indumn + i__] = l[i__] * tmp; + work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda; +/* L80: */ + } + tmp = work[indp + r1 - 1]; + sawnan2 = disnan_(&tmp); + if (sawnan2) { +/* Runs a slower version of the above loop if a NaN is detected */ + neg2 = 0; + i__1 = r1; + for (i__ = *bn - 1; i__ >= i__1; --i__) { + dminus = lld[i__] + work[indp + i__]; + if (abs(dminus) < *pivmin) { + dminus = -(*pivmin); + } + tmp = d__[i__] / dminus; + if (dminus < 0.) { + ++neg2; + } + work[indumn + i__] = l[i__] * tmp; + work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda; + if (tmp == 0.) { + work[indp + i__ - 1] = d__[i__] - *lambda; + } +/* L100: */ + } + } + +/* Find the index (from R1 to R2) of the largest (in magnitude) */ +/* diagonal element of the inverse */ + + *mingma = work[inds + r1 - 1] + work[indp + r1 - 1]; + if (*mingma < 0.) { + ++neg1; + } + if (*wantnc) { + *negcnt = neg1 + neg2; + } else { + *negcnt = -1; + } + if (abs(*mingma) == 0.) { + *mingma = eps * work[inds + r1 - 1]; + } + *r__ = r1; + i__1 = r2 - 1; + for (i__ = r1; i__ <= i__1; ++i__) { + tmp = work[inds + i__] + work[indp + i__]; + if (tmp == 0.) { + tmp = eps * work[inds + i__]; + } + if (abs(tmp) <= abs(*mingma)) { + *mingma = tmp; + *r__ = i__ + 1; + } +/* L110: */ + } + +/* Compute the FP vector: solve N^T v = e_r */ + + isuppz[1] = *b1; + isuppz[2] = *bn; + i__1 = *r__; + z__[i__1].r = 1., z__[i__1].i = 0.; + *ztz = 1.; + +/* Compute the FP vector upwards from R */ + + if (! sawnan1 && ! sawnan2) { + i__1 = *b1; + for (i__ = *r__ - 1; i__ >= i__1; --i__) { + i__2 = i__; + i__3 = indlpl + i__; + i__4 = i__ + 1; + z__2.r = work[i__3] * z__[i__4].r, z__2.i = work[i__3] * z__[i__4] + .i; + z__1.r = -z__2.r, z__1.i = -z__2.i; + z__[i__2].r = z__1.r, z__[i__2].i = z__1.i; + if ((z_abs(&z__[i__]) + z_abs(&z__[i__ + 1])) * (d__1 = ld[i__], + abs(d__1)) < *gaptol) { + i__2 = i__; + z__[i__2].r = 0., z__[i__2].i = 0.; + isuppz[1] = i__ + 1; + goto L220; + } + i__2 = i__; + i__3 = i__; + z__1.r = z__[i__2].r * z__[i__3].r - z__[i__2].i * z__[i__3].i, + z__1.i = z__[i__2].r * z__[i__3].i + z__[i__2].i * z__[ + i__3].r; + *ztz += z__1.r; +/* L210: */ + } +L220: + ; + } else { +/* Run slower loop if NaN occurred. */ + i__1 = *b1; + for (i__ = *r__ - 1; i__ >= i__1; --i__) { + i__2 = i__ + 1; + if (z__[i__2].r == 0. && z__[i__2].i == 0.) { + i__2 = i__; + d__1 = -(ld[i__ + 1] / ld[i__]); + i__3 = i__ + 2; + z__1.r = d__1 * z__[i__3].r, z__1.i = d__1 * z__[i__3].i; + z__[i__2].r = z__1.r, z__[i__2].i = z__1.i; + } else { + i__2 = i__; + i__3 = indlpl + i__; + i__4 = i__ + 1; + z__2.r = work[i__3] * z__[i__4].r, z__2.i = work[i__3] * z__[ + i__4].i; + z__1.r = -z__2.r, z__1.i = -z__2.i; + z__[i__2].r = z__1.r, z__[i__2].i = z__1.i; + } + if ((z_abs(&z__[i__]) + z_abs(&z__[i__ + 1])) * (d__1 = ld[i__], + abs(d__1)) < *gaptol) { + i__2 = i__; + z__[i__2].r = 0., z__[i__2].i = 0.; + isuppz[1] = i__ + 1; + goto L240; + } + i__2 = i__; + i__3 = i__; + z__1.r = z__[i__2].r * z__[i__3].r - z__[i__2].i * z__[i__3].i, + z__1.i = z__[i__2].r * z__[i__3].i + z__[i__2].i * z__[ + i__3].r; + *ztz += z__1.r; +/* L230: */ + } +L240: + ; + } +/* Compute the FP vector downwards from R in blocks of size BLKSIZ */ + if (! sawnan1 && ! sawnan2) { + i__1 = *bn - 1; + for (i__ = *r__; i__ <= i__1; ++i__) { + i__2 = i__ + 1; + i__3 = indumn + i__; + i__4 = i__; + z__2.r = work[i__3] * z__[i__4].r, z__2.i = work[i__3] * z__[i__4] + .i; + z__1.r = -z__2.r, z__1.i = -z__2.i; + z__[i__2].r = z__1.r, z__[i__2].i = z__1.i; + if ((z_abs(&z__[i__]) + z_abs(&z__[i__ + 1])) * (d__1 = ld[i__], + abs(d__1)) < *gaptol) { + i__2 = i__ + 1; + z__[i__2].r = 0., z__[i__2].i = 0.; + isuppz[2] = i__; + goto L260; + } + i__2 = i__ + 1; + i__3 = i__ + 1; + z__1.r = z__[i__2].r * z__[i__3].r - z__[i__2].i * z__[i__3].i, + z__1.i = z__[i__2].r * z__[i__3].i + z__[i__2].i * z__[ + i__3].r; + *ztz += z__1.r; +/* L250: */ + } +L260: + ; + } else { +/* Run slower loop if NaN occurred. */ + i__1 = *bn - 1; + for (i__ = *r__; i__ <= i__1; ++i__) { + i__2 = i__; + if (z__[i__2].r == 0. && z__[i__2].i == 0.) { + i__2 = i__ + 1; + d__1 = -(ld[i__ - 1] / ld[i__]); + i__3 = i__ - 1; + z__1.r = d__1 * z__[i__3].r, z__1.i = d__1 * z__[i__3].i; + z__[i__2].r = z__1.r, z__[i__2].i = z__1.i; + } else { + i__2 = i__ + 1; + i__3 = indumn + i__; + i__4 = i__; + z__2.r = work[i__3] * z__[i__4].r, z__2.i = work[i__3] * z__[ + i__4].i; + z__1.r = -z__2.r, z__1.i = -z__2.i; + z__[i__2].r = z__1.r, z__[i__2].i = z__1.i; + } + if ((z_abs(&z__[i__]) + z_abs(&z__[i__ + 1])) * (d__1 = ld[i__], + abs(d__1)) < *gaptol) { + i__2 = i__ + 1; + z__[i__2].r = 0., z__[i__2].i = 0.; + isuppz[2] = i__; + goto L280; + } + i__2 = i__ + 1; + i__3 = i__ + 1; + z__1.r = z__[i__2].r * z__[i__3].r - z__[i__2].i * z__[i__3].i, + z__1.i = z__[i__2].r * z__[i__3].i + z__[i__2].i * z__[ + i__3].r; + *ztz += z__1.r; +/* L270: */ + } +L280: + ; + } + +/* Compute quantities for convergence test */ + + tmp = 1. / *ztz; + *nrminv = sqrt(tmp); + *resid = abs(*mingma) * *nrminv; + *rqcorr = *mingma * tmp; + + + return 0; + +/* End of ZLAR1V */ + +} /* zlar1v_ */ + diff --git a/lapack-netlib/SRC/zlar2v.c b/lapack-netlib/SRC/zlar2v.c new file mode 100644 index 000000000..09d9254e7 --- /dev/null +++ b/lapack-netlib/SRC/zlar2v.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 +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAR2V applies a vector of plane rotations with real cosines and complex sines from both sides +to a sequence of 2-by-2 symmetric/Hermitian matrices. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAR2V + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAR2V( N, X, Y, Z, INCX, C, S, INCC ) */ + +/* INTEGER INCC, INCX, N */ +/* DOUBLE PRECISION C( * ) */ +/* COMPLEX*16 S( * ), X( * ), Y( * ), Z( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAR2V applies a vector of complex plane rotations with real cosines */ +/* > from both sides to a sequence of 2-by-2 complex Hermitian matrices, */ +/* > defined by the elements of the vectors x, y and z. For i = 1,2,...,n */ +/* > */ +/* > ( x(i) z(i) ) := */ +/* > ( conjg(z(i)) y(i) ) */ +/* > */ +/* > ( c(i) conjg(s(i)) ) ( x(i) z(i) ) ( c(i) -conjg(s(i)) ) */ +/* > ( -s(i) c(i) ) ( conjg(z(i)) y(i) ) ( s(i) c(i) ) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of plane rotations to be applied. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (1+(N-1)*INCX) */ +/* > The vector x; the elements of x are assumed to be real. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is COMPLEX*16 array, dimension (1+(N-1)*INCX) */ +/* > The vector y; the elements of y are assumed to be real. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX*16 array, dimension (1+(N-1)*INCX) */ +/* > The vector z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The increment between elements of X, Y and Z. INCX > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (1+(N-1)*INCC) */ +/* > The cosines of the plane rotations. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is COMPLEX*16 array, dimension (1+(N-1)*INCC) */ +/* > The sines of the plane rotations. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCC */ +/* > \verbatim */ +/* > INCC is INTEGER */ +/* > The increment between elements of C and S. INCC > 0. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlar2v_(integer *n, doublecomplex *x, doublecomplex *y, + doublecomplex *z__, integer *incx, doublereal *c__, doublecomplex *s, + integer *incc) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal d__1; + doublecomplex z__1, z__2, z__3, z__4, z__5; + + /* Local variables */ + integer i__; + doublecomplex t2, t3, t4; + doublereal t5, t6; + integer ic; + doublereal ci; + doublecomplex si; + integer ix; + doublereal xi, yi; + doublecomplex zi; + doublereal t1i, t1r, sii, zii, sir, zir; + + +/* -- 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 */ + --s; + --c__; + --z__; + --y; + --x; + + /* Function Body */ + ix = 1; + ic = 1; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ix; + xi = x[i__2].r; + i__2 = ix; + yi = y[i__2].r; + i__2 = ix; + zi.r = z__[i__2].r, zi.i = z__[i__2].i; + zir = zi.r; + zii = d_imag(&zi); + ci = c__[ic]; + i__2 = ic; + si.r = s[i__2].r, si.i = s[i__2].i; + sir = si.r; + sii = d_imag(&si); + t1r = sir * zir - sii * zii; + t1i = sir * zii + sii * zir; + z__1.r = ci * zi.r, z__1.i = ci * zi.i; + t2.r = z__1.r, t2.i = z__1.i; + d_cnjg(&z__3, &si); + z__2.r = xi * z__3.r, z__2.i = xi * z__3.i; + z__1.r = t2.r - z__2.r, z__1.i = t2.i - z__2.i; + t3.r = z__1.r, t3.i = z__1.i; + d_cnjg(&z__2, &t2); + z__3.r = yi * si.r, z__3.i = yi * si.i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + t4.r = z__1.r, t4.i = z__1.i; + t5 = ci * xi + t1r; + t6 = ci * yi - t1r; + i__2 = ix; + d__1 = ci * t5 + (sir * t4.r + sii * d_imag(&t4)); + x[i__2].r = d__1, x[i__2].i = 0.; + i__2 = ix; + d__1 = ci * t6 - (sir * t3.r - sii * d_imag(&t3)); + y[i__2].r = d__1, y[i__2].i = 0.; + i__2 = ix; + z__2.r = ci * t3.r, z__2.i = ci * t3.i; + d_cnjg(&z__4, &si); + z__5.r = t6, z__5.i = t1i; + z__3.r = z__4.r * z__5.r - z__4.i * z__5.i, z__3.i = z__4.r * z__5.i + + z__4.i * z__5.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + z__[i__2].r = z__1.r, z__[i__2].i = z__1.i; + ix += *incx; + ic += *incc; +/* L10: */ + } + return 0; + +/* End of ZLAR2V */ + +} /* zlar2v_ */ + diff --git a/lapack-netlib/SRC/zlarcm.c b/lapack-netlib/SRC/zlarcm.c new file mode 100644 index 000000000..e34c5efce --- /dev/null +++ b/lapack-netlib/SRC/zlarcm.c @@ -0,0 +1,609 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLARCM copies all or part of a real two-dimensional array to a complex array. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLARCM + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLARCM( M, N, A, LDA, B, LDB, C, LDC, RWORK ) */ + +/* INTEGER LDA, LDB, LDC, M, N */ +/* DOUBLE PRECISION A( LDA, * ), RWORK( * ) */ +/* COMPLEX*16 B( LDB, * ), C( LDC, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLARCM performs a very simple matrix-matrix multiplication: */ +/* > C := A * B, */ +/* > where A is M by M and real; B is M by N and complex; */ +/* > C is M by N and complex. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A and of the matrix C. */ +/* > M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns and rows of the matrix B and */ +/* > the number of columns of the matrix C. */ +/* > N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, M) */ +/* > On entry, A contains the M by M matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >=f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB, N) */ +/* > On entry, B contains the M by N matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >=f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] C */ +/* > \verbatim */ +/* > C is COMPLEX*16 array, dimension (LDC, N) */ +/* > On exit, C contains the M by N matrix C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >=f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (2*M*N) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlarcm_(integer *m, integer *n, doublereal *a, integer * + lda, doublecomplex *b, integer *ldb, doublecomplex *c__, integer *ldc, + doublereal *rwork) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4, i__5; + doublereal d__1; + doublecomplex z__1; + + /* Local variables */ + integer i__, j, l; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --rwork; + + /* Function Body */ + if (*m == 0 || *n == 0) { + return 0; + } + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + rwork[(j - 1) * *m + i__] = b[i__3].r; +/* L10: */ + } +/* L20: */ + } + + l = *m * *n + 1; + dgemm_("N", "N", m, n, m, &c_b6, &a[a_offset], lda, &rwork[1], m, &c_b7, & + rwork[l], m); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = l + (j - 1) * *m + i__ - 1; + c__[i__3].r = rwork[i__4], c__[i__3].i = 0.; +/* L30: */ + } +/* L40: */ + } + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + rwork[(j - 1) * *m + i__] = d_imag(&b[i__ + j * b_dim1]); +/* L50: */ + } +/* L60: */ + } + dgemm_("N", "N", m, n, m, &c_b6, &a[a_offset], lda, &rwork[1], m, &c_b7, & + rwork[l], m); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + d__1 = c__[i__4].r; + i__5 = l + (j - 1) * *m + i__ - 1; + z__1.r = d__1, z__1.i = rwork[i__5]; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L70: */ + } +/* L80: */ + } + + return 0; + +/* End of ZLARCM */ + +} /* zlarcm_ */ + diff --git a/lapack-netlib/SRC/zlarf.c b/lapack-netlib/SRC/zlarf.c new file mode 100644 index 000000000..806a41fdb --- /dev/null +++ b/lapack-netlib/SRC/zlarf.c @@ -0,0 +1,636 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLARF applies an elementary reflector to a general rectangular matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLARF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) */ + +/* CHARACTER SIDE */ +/* INTEGER INCV, LDC, M, N */ +/* COMPLEX*16 TAU */ +/* COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLARF applies a complex elementary reflector H to a complex M-by-N */ +/* > matrix C, from either the left or the right. H is represented in the */ +/* > form */ +/* > */ +/* > H = I - tau * v * v**H */ +/* > */ +/* > where tau is a complex scalar and v is a complex vector. */ +/* > */ +/* > If tau = 0, then H is taken to be the unit matrix. */ +/* > */ +/* > To apply H**H, supply conjg(tau) instead */ +/* > tau. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': form H * C */ +/* > = 'R': form C * H */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is COMPLEX*16 array, dimension */ +/* > (1 + (M-1)*abs(INCV)) if SIDE = 'L' */ +/* > or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */ +/* > The vector v in the representation of H. V is not used if */ +/* > TAU = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCV */ +/* > \verbatim */ +/* > INCV is INTEGER */ +/* > The increment between elements of v. INCV <> 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 */ +/* > The value tau in the representation of H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX*16 array, dimension (LDC,N) */ +/* > On entry, the M-by-N matrix C. */ +/* > On exit, C is overwritten by the matrix H * C if SIDE = 'L', */ +/* > or C * H if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension */ +/* > (N) if SIDE = 'L' */ +/* > or (M) if SIDE = 'R' */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlarf_(char *side, integer *m, integer *n, doublecomplex + *v, integer *incv, doublecomplex *tau, doublecomplex *c__, integer * + ldc, doublecomplex *work) +{ + /* System generated locals */ + integer c_dim1, c_offset, i__1; + doublecomplex z__1; + + /* Local variables */ + integer i__; + extern logical lsame_(char *, char *); + integer lastc; + extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + integer lastv; + logical applyleft; + extern integer ilazlc_(integer *, integer *, doublecomplex *, integer *), + ilazlr_(integer *, integer *, doublecomplex *, integer *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --v; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + applyleft = lsame_(side, "L"); + lastv = 0; + lastc = 0; + if (tau->r != 0. || tau->i != 0.) { +/* Set up variables for scanning V. LASTV begins pointing to the end */ +/* of V. */ + if (applyleft) { + lastv = *m; + } else { + lastv = *n; + } + if (*incv > 0) { + i__ = (lastv - 1) * *incv + 1; + } else { + i__ = 1; + } +/* Look for the last non-zero row in V. */ + for(;;) { /* while(complicated condition) */ + i__1 = i__; + if (!(lastv > 0 && (v[i__1].r == 0. && v[i__1].i == 0.))) + break; + --lastv; + i__ -= *incv; + } + if (applyleft) { +/* Scan for the last non-zero column in C(1:lastv,:). */ + lastc = ilazlc_(&lastv, n, &c__[c_offset], ldc); + } else { +/* Scan for the last non-zero row in C(:,1:lastv). */ + lastc = ilazlr_(m, &lastv, &c__[c_offset], ldc); + } + } +/* Note that lastc.eq.0 renders the BLAS operations null; no special */ +/* case is needed at this level. */ + if (applyleft) { + +/* Form H * C */ + + if (lastv > 0) { + +/* w(1:lastc,1) := C(1:lastv,1:lastc)**H * v(1:lastv,1) */ + + zgemv_("Conjugate transpose", &lastv, &lastc, &c_b1, &c__[ + c_offset], ldc, &v[1], incv, &c_b2, &work[1], &c__1); + +/* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**H */ + + z__1.r = -tau->r, z__1.i = -tau->i; + zgerc_(&lastv, &lastc, &z__1, &v[1], incv, &work[1], &c__1, &c__[ + c_offset], ldc); + } + } else { + +/* Form C * H */ + + if (lastv > 0) { + +/* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) */ + + zgemv_("No transpose", &lastc, &lastv, &c_b1, &c__[c_offset], ldc, + &v[1], incv, &c_b2, &work[1], &c__1); + +/* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**H */ + + z__1.r = -tau->r, z__1.i = -tau->i; + zgerc_(&lastc, &lastv, &z__1, &work[1], &c__1, &v[1], incv, &c__[ + c_offset], ldc); + } + } + return 0; + +/* End of ZLARF */ + +} /* zlarf_ */ + diff --git a/lapack-netlib/SRC/zlarfb.c b/lapack-netlib/SRC/zlarfb.c new file mode 100644 index 000000000..442fb4e04 --- /dev/null +++ b/lapack-netlib/SRC/zlarfb.c @@ -0,0 +1,1266 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLARFB applies a block reflector or its conjugate-transpose to a general rectangular matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLARFB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, */ +/* T, LDT, C, LDC, WORK, LDWORK ) */ + +/* CHARACTER DIRECT, SIDE, STOREV, TRANS */ +/* INTEGER K, LDC, LDT, LDV, LDWORK, M, N */ +/* COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), */ +/* $ WORK( LDWORK, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLARFB applies a complex block reflector H or its transpose H**H to a */ +/* > complex M-by-N matrix C, from either the left or the right. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply H or H**H from the Left */ +/* > = 'R': apply H or H**H from the Right */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': apply H (No transpose) */ +/* > = 'C': apply H**H (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIRECT */ +/* > \verbatim */ +/* > DIRECT is CHARACTER*1 */ +/* > Indicates how H is formed from a product of elementary */ +/* > reflectors */ +/* > = 'F': H = H(1) H(2) . . . H(k) (Forward) */ +/* > = 'B': H = H(k) . . . H(2) H(1) (Backward) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] STOREV */ +/* > \verbatim */ +/* > STOREV is CHARACTER*1 */ +/* > Indicates how the vectors which define the elementary */ +/* > reflectors are stored: */ +/* > = 'C': Columnwise */ +/* > = 'R': Rowwise */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The order of the matrix T (= the number of elementary */ +/* > reflectors whose product defines the block reflector). */ +/* > If SIDE = 'L', M >= K >= 0; */ +/* > if SIDE = 'R', N >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is COMPLEX*16 array, dimension */ +/* > (LDV,K) if STOREV = 'C' */ +/* > (LDV,M) if STOREV = 'R' and SIDE = 'L' */ +/* > (LDV,N) if STOREV = 'R' and SIDE = 'R' */ +/* > See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. */ +/* > If STOREV = 'C' and SIDE = 'L', LDV >= f2cmax(1,M); */ +/* > if STOREV = 'C' and SIDE = 'R', LDV >= f2cmax(1,N); */ +/* > if STOREV = 'R', LDV >= K. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is COMPLEX*16 array, dimension (LDT,K) */ +/* > The triangular K-by-K matrix T in the representation of the */ +/* > block reflector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= K. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX*16 array, dimension (LDC,N) */ +/* > On entry, the M-by-N matrix C. */ +/* > On exit, C is overwritten by H*C or H**H*C or C*H or C*H**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (LDWORK,K) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDWORK */ +/* > \verbatim */ +/* > LDWORK is INTEGER */ +/* > The leading dimension of the array WORK. */ +/* > If SIDE = 'L', LDWORK >= f2cmax(1,N); */ +/* > if SIDE = 'R', LDWORK >= f2cmax(1,M). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2013 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The shape of the matrix V and the storage of the vectors which define */ +/* > the H(i) is best illustrated by the following example with n = 5 and */ +/* > k = 3. The elements equal to 1 are not stored; the corresponding */ +/* > array elements are modified but restored on exit. The rest of the */ +/* > array is not used. */ +/* > */ +/* > DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */ +/* > */ +/* > V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */ +/* > ( v1 1 ) ( 1 v2 v2 v2 ) */ +/* > ( v1 v2 1 ) ( 1 v3 v3 ) */ +/* > ( v1 v2 v3 ) */ +/* > ( v1 v2 v3 ) */ +/* > */ +/* > DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */ +/* > */ +/* > V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */ +/* > ( v1 v2 v3 ) ( v2 v2 v2 1 ) */ +/* > ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */ +/* > ( 1 v3 ) */ +/* > ( 1 ) */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlarfb_(char *side, char *trans, char *direct, char * + storev, integer *m, integer *n, integer *k, doublecomplex *v, integer + *ldv, doublecomplex *t, integer *ldt, doublecomplex *c__, integer * + ldc, doublecomplex *work, integer *ldwork) +{ + /* System generated locals */ + integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, + work_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1, z__2; + + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *), zcopy_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *), ztrmm_(char *, char *, + char *, char *, integer *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *), zlacgv_(integer *, doublecomplex *, + integer *); + char transt[1]; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2013 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + work_dim1 = *ldwork; + work_offset = 1 + work_dim1 * 1; + work -= work_offset; + + /* Function Body */ + if (*m <= 0 || *n <= 0) { + return 0; + } + + if (lsame_(trans, "N")) { + *(unsigned char *)transt = 'C'; + } else { + *(unsigned char *)transt = 'N'; + } + + if (lsame_(storev, "C")) { + + if (lsame_(direct, "F")) { + +/* Let V = ( V1 ) (first K rows) */ +/* ( V2 ) */ +/* where V1 is unit lower triangular. */ + + if (lsame_(side, "L")) { + +/* Form H * C or H**H * C where C = ( C1 ) */ +/* ( C2 ) */ + +/* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) */ + +/* W := C1**H */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], + &c__1); + zlacgv_(n, &work[j * work_dim1 + 1], &c__1); +/* L10: */ + } + +/* W := W * V1 */ + + ztrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b1, + &v[v_offset], ldv, &work[work_offset], ldwork); + if (*m > *k) { + +/* W := W + C2**H * V2 */ + + i__1 = *m - *k; + zgemm_("Conjugate transpose", "No transpose", n, k, &i__1, + &c_b1, &c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + + v_dim1], ldv, &c_b1, &work[work_offset], ldwork); + } + +/* W := W * T**H or W * T */ + + ztrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b1, &t[ + t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - V * W**H */ + + if (*m > *k) { + +/* C2 := C2 - V2 * W**H */ + + i__1 = *m - *k; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Conjugate transpose", &i__1, n, k, + &z__1, &v[*k + 1 + v_dim1], ldv, &work[ + work_offset], ldwork, &c_b1, &c__[*k + 1 + c_dim1] + , ldc); + } + +/* W := W * V1**H */ + + ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", n, k, + &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork); + +/* C1 := C1 - W**H */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = j + i__ * c_dim1; + i__4 = j + i__ * c_dim1; + d_cnjg(&z__2, &work[i__ + j * work_dim1]); + z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - + z__2.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L20: */ + } +/* L30: */ + } + + } else if (lsame_(side, "R")) { + +/* Form C * H or C * H**H where C = ( C1 C2 ) */ + +/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ + +/* W := C1 */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * + work_dim1 + 1], &c__1); +/* L40: */ + } + +/* W := W * V1 */ + + ztrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b1, + &v[v_offset], ldv, &work[work_offset], ldwork); + if (*n > *k) { + +/* W := W + C2 * V2 */ + + i__1 = *n - *k; + zgemm_("No transpose", "No transpose", m, k, &i__1, &c_b1, + &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + 1 + + v_dim1], ldv, &c_b1, &work[work_offset], ldwork); + } + +/* W := W * T or W * T**H */ + + ztrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b1, &t[ + t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - W * V**H */ + + if (*n > *k) { + +/* C2 := C2 - W * V2**H */ + + i__1 = *n - *k; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Conjugate transpose", m, &i__1, k, + &z__1, &work[work_offset], ldwork, &v[*k + 1 + + v_dim1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 + 1], + ldc); + } + +/* W := W * V1**H */ + + ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", m, k, + &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork); + +/* C1 := C1 - W */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * work_dim1; + z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[ + i__4].i - work[i__5].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L50: */ + } +/* L60: */ + } + } + + } else { + +/* Let V = ( V1 ) */ +/* ( V2 ) (last K rows) */ +/* where V2 is unit upper triangular. */ + + if (lsame_(side, "L")) { + +/* Form H * C or H**H * C where C = ( C1 ) */ +/* ( C2 ) */ + +/* W := C**H * V = (C1**H * V1 + C2**H * V2) (stored in WORK) */ + +/* W := C2**H */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * + work_dim1 + 1], &c__1); + zlacgv_(n, &work[j * work_dim1 + 1], &c__1); +/* L70: */ + } + +/* W := W * V2 */ + + ztrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b1, + &v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], + ldwork); + if (*m > *k) { + +/* W := W + C1**H * V1 */ + + i__1 = *m - *k; + zgemm_("Conjugate transpose", "No transpose", n, k, &i__1, + &c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, & + c_b1, &work[work_offset], ldwork); + } + +/* W := W * T**H or W * T */ + + ztrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b1, &t[ + t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - V * W**H */ + + if (*m > *k) { + +/* C1 := C1 - V1 * W**H */ + + i__1 = *m - *k; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Conjugate transpose", &i__1, n, k, + &z__1, &v[v_offset], ldv, &work[work_offset], + ldwork, &c_b1, &c__[c_offset], ldc); + } + +/* W := W * V2**H */ + + ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", n, k, + &c_b1, &v[*m - *k + 1 + v_dim1], ldv, &work[ + work_offset], ldwork); + +/* C2 := C2 - W**H */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = *m - *k + j + i__ * c_dim1; + i__4 = *m - *k + j + i__ * c_dim1; + d_cnjg(&z__2, &work[i__ + j * work_dim1]); + z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - + z__2.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L80: */ + } +/* L90: */ + } + + } else if (lsame_(side, "R")) { + +/* Form C * H or C * H**H where C = ( C1 C2 ) */ + +/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ + +/* W := C2 */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[ + j * work_dim1 + 1], &c__1); +/* L100: */ + } + +/* W := W * V2 */ + + ztrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b1, + &v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], + ldwork); + if (*n > *k) { + +/* W := W + C1 * V1 */ + + i__1 = *n - *k; + zgemm_("No transpose", "No transpose", m, k, &i__1, &c_b1, + &c__[c_offset], ldc, &v[v_offset], ldv, &c_b1, & + work[work_offset], ldwork) + ; + } + +/* W := W * T or W * T**H */ + + ztrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b1, &t[ + t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - W * V**H */ + + if (*n > *k) { + +/* C1 := C1 - W * V1**H */ + + i__1 = *n - *k; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Conjugate transpose", m, &i__1, k, + &z__1, &work[work_offset], ldwork, &v[v_offset], + ldv, &c_b1, &c__[c_offset], ldc); + } + +/* W := W * V2**H */ + + ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", m, k, + &c_b1, &v[*n - *k + 1 + v_dim1], ldv, &work[ + work_offset], ldwork); + +/* C2 := C2 - W */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (*n - *k + j) * c_dim1; + i__4 = i__ + (*n - *k + j) * c_dim1; + i__5 = i__ + j * work_dim1; + z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[ + i__4].i - work[i__5].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L110: */ + } +/* L120: */ + } + } + } + + } else if (lsame_(storev, "R")) { + + if (lsame_(direct, "F")) { + +/* Let V = ( V1 V2 ) (V1: first K columns) */ +/* where V1 is unit upper triangular. */ + + if (lsame_(side, "L")) { + +/* Form H * C or H**H * C where C = ( C1 ) */ +/* ( C2 ) */ + +/* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) */ + +/* W := C1**H */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], + &c__1); + zlacgv_(n, &work[j * work_dim1 + 1], &c__1); +/* L130: */ + } + +/* W := W * V1**H */ + + ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", n, k, + &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork); + if (*m > *k) { + +/* W := W + C2**H * V2**H */ + + i__1 = *m - *k; + zgemm_("Conjugate transpose", "Conjugate transpose", n, k, + &i__1, &c_b1, &c__[*k + 1 + c_dim1], ldc, &v[(*k + + 1) * v_dim1 + 1], ldv, &c_b1, &work[work_offset] + , ldwork); + } + +/* W := W * T**H or W * T */ + + ztrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b1, &t[ + t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - V**H * W**H */ + + if (*m > *k) { + +/* C2 := C2 - V2**H * W**H */ + + i__1 = *m - *k; + z__1.r = -1., z__1.i = 0.; + zgemm_("Conjugate transpose", "Conjugate transpose", & + i__1, n, k, &z__1, &v[(*k + 1) * v_dim1 + 1], ldv, + &work[work_offset], ldwork, &c_b1, &c__[*k + 1 + + c_dim1], ldc); + } + +/* W := W * V1 */ + + ztrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b1, + &v[v_offset], ldv, &work[work_offset], ldwork); + +/* C1 := C1 - W**H */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = j + i__ * c_dim1; + i__4 = j + i__ * c_dim1; + d_cnjg(&z__2, &work[i__ + j * work_dim1]); + z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - + z__2.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L140: */ + } +/* L150: */ + } + + } else if (lsame_(side, "R")) { + +/* Form C * H or C * H**H where C = ( C1 C2 ) */ + +/* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) */ + +/* W := C1 */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * + work_dim1 + 1], &c__1); +/* L160: */ + } + +/* W := W * V1**H */ + + ztrmm_("Right", "Upper", "Conjugate transpose", "Unit", m, k, + &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork); + if (*n > *k) { + +/* W := W + C2 * V2**H */ + + i__1 = *n - *k; + zgemm_("No transpose", "Conjugate transpose", m, k, &i__1, + &c_b1, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k + + 1) * v_dim1 + 1], ldv, &c_b1, &work[work_offset] + , ldwork); + } + +/* W := W * T or W * T**H */ + + ztrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b1, &t[ + t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - W * V */ + + if (*n > *k) { + +/* C2 := C2 - W * V2 */ + + i__1 = *n - *k; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "No transpose", m, &i__1, k, &z__1, + &work[work_offset], ldwork, &v[(*k + 1) * v_dim1 + + 1], ldv, &c_b1, &c__[(*k + 1) * c_dim1 + 1], + ldc); + } + +/* W := W * V1 */ + + ztrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b1, + &v[v_offset], ldv, &work[work_offset], ldwork); + +/* C1 := C1 - W */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * work_dim1; + z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[ + i__4].i - work[i__5].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L170: */ + } +/* L180: */ + } + + } + + } else { + +/* Let V = ( V1 V2 ) (V2: last K columns) */ +/* where V2 is unit lower triangular. */ + + if (lsame_(side, "L")) { + +/* Form H * C or H**H * C where C = ( C1 ) */ +/* ( C2 ) */ + +/* W := C**H * V**H = (C1**H * V1**H + C2**H * V2**H) (stored in WORK) */ + +/* W := C2**H */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * + work_dim1 + 1], &c__1); + zlacgv_(n, &work[j * work_dim1 + 1], &c__1); +/* L190: */ + } + +/* W := W * V2**H */ + + ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", n, k, + &c_b1, &v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[ + work_offset], ldwork); + if (*m > *k) { + +/* W := W + C1**H * V1**H */ + + i__1 = *m - *k; + zgemm_("Conjugate transpose", "Conjugate transpose", n, k, + &i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], + ldv, &c_b1, &work[work_offset], ldwork); + } + +/* W := W * T**H or W * T */ + + ztrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b1, &t[ + t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - V**H * W**H */ + + if (*m > *k) { + +/* C1 := C1 - V1**H * W**H */ + + i__1 = *m - *k; + z__1.r = -1., z__1.i = 0.; + zgemm_("Conjugate transpose", "Conjugate transpose", & + i__1, n, k, &z__1, &v[v_offset], ldv, &work[ + work_offset], ldwork, &c_b1, &c__[c_offset], ldc); + } + +/* W := W * V2 */ + + ztrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b1, + &v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[ + work_offset], ldwork); + +/* C2 := C2 - W**H */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = *m - *k + j + i__ * c_dim1; + i__4 = *m - *k + j + i__ * c_dim1; + d_cnjg(&z__2, &work[i__ + j * work_dim1]); + z__1.r = c__[i__4].r - z__2.r, z__1.i = c__[i__4].i - + z__2.i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L200: */ + } +/* L210: */ + } + + } else if (lsame_(side, "R")) { + +/* Form C * H or C * H**H where C = ( C1 C2 ) */ + +/* W := C * V**H = (C1*V1**H + C2*V2**H) (stored in WORK) */ + +/* W := C2 */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[ + j * work_dim1 + 1], &c__1); +/* L220: */ + } + +/* W := W * V2**H */ + + ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", m, k, + &c_b1, &v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[ + work_offset], ldwork); + if (*n > *k) { + +/* W := W + C1 * V1**H */ + + i__1 = *n - *k; + zgemm_("No transpose", "Conjugate transpose", m, k, &i__1, + &c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, & + c_b1, &work[work_offset], ldwork); + } + +/* W := W * T or W * T**H */ + + ztrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b1, &t[ + t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - W * V */ + + if (*n > *k) { + +/* C1 := C1 - W * V1 */ + + i__1 = *n - *k; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "No transpose", m, &i__1, k, &z__1, + &work[work_offset], ldwork, &v[v_offset], ldv, & + c_b1, &c__[c_offset], ldc) + ; + } + +/* W := W * V2 */ + + ztrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b1, + &v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[ + work_offset], ldwork); + +/* C1 := C1 - W */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (*n - *k + j) * c_dim1; + i__4 = i__ + (*n - *k + j) * c_dim1; + i__5 = i__ + j * work_dim1; + z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[ + i__4].i - work[i__5].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L230: */ + } +/* L240: */ + } + + } + + } + } + + return 0; + +/* End of ZLARFB */ + +} /* zlarfb_ */ + diff --git a/lapack-netlib/SRC/zlarfb_gett.c b/lapack-netlib/SRC/zlarfb_gett.c new file mode 100644 index 000000000..43e26f21f --- /dev/null +++ b/lapack-netlib/SRC/zlarfb_gett.c @@ -0,0 +1,1033 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLARFB_GETT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLARFB_GETT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLARFB_GETT( IDENT, M, N, K, T, LDT, A, LDA, B, LDB, */ +/* $ WORK, LDWORK ) */ +/* IMPLICIT NONE */ + +/* CHARACTER IDENT */ +/* INTEGER K, LDA, LDB, LDT, LDWORK, M, N */ +/* COMPLEX*16 A( LDA, * ), B( LDB, * ), T( LDT, * ), */ +/* $ WORK( LDWORK, * ) */ + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLARFB_GETT applies a complex Householder block reflector H from the */ +/* > left to a complex (K+M)-by-N "triangular-pentagonal" matrix */ +/* > composed of two block matrices: an upper trapezoidal K-by-N matrix A */ +/* > stored in the array A, and a rectangular M-by-(N-K) matrix B, stored */ +/* > in the array B. The block reflector H is stored in a compact */ +/* > WY-representation, where the elementary reflectors are in the */ +/* > arrays A, B and T. See Further Details section. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] IDENT */ +/* > \verbatim */ +/* > IDENT is CHARACTER*1 */ +/* > If IDENT = not 'I', or not 'i', then V1 is unit */ +/* > lower-triangular and stored in the left K-by-K block of */ +/* > the input matrix A, */ +/* > If IDENT = 'I' or 'i', then V1 is an identity matrix and */ +/* > not stored. */ +/* > See Further Details section. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix B. */ +/* > M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrices A and B. */ +/* > N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number or rows of the matrix A. */ +/* > K is also order of the matrix T, i.e. the number of */ +/* > elementary reflectors whose product defines the block */ +/* > reflector. 0 <= K <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is COMPLEX*16 array, dimension (LDT,K) */ +/* > The upper-triangular K-by-K matrix T in the representation */ +/* > of the block reflector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= K. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > */ +/* > On entry: */ +/* > a) In the K-by-N upper-trapezoidal part A: input matrix A. */ +/* > b) In the columns below the diagonal: columns of V1 */ +/* > (ones are not stored on the diagonal). */ +/* > */ +/* > On exit: */ +/* > A is overwritten by rectangular K-by-N product H*A. */ +/* > */ +/* > See Further Details section. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,K). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,N) */ +/* > */ +/* > On entry: */ +/* > a) In the M-by-(N-K) right block: input matrix B. */ +/* > b) In the M-by-N left block: columns of V2. */ +/* > */ +/* > On exit: */ +/* > B is overwritten by rectangular M-by-N product H*B. */ +/* > */ +/* > See Further Details section. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, */ +/* > dimension (LDWORK,f2cmax(K,N-K)) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDWORK */ +/* > \verbatim */ +/* > LDWORK is INTEGER */ +/* > The leading dimension of the array WORK. LDWORK>=f2cmax(1,K). */ +/* > */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2020, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > \endverbatim */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > (1) Description of the Algebraic Operation. */ +/* > */ +/* > The matrix A is a K-by-N matrix composed of two column block */ +/* > matrices, A1, which is K-by-K, and A2, which is K-by-(N-K): */ +/* > A = ( A1, A2 ). */ +/* > The matrix B is an M-by-N matrix composed of two column block */ +/* > matrices, B1, which is M-by-K, and B2, which is M-by-(N-K): */ +/* > B = ( B1, B2 ). */ +/* > */ +/* > Perform the operation: */ +/* > */ +/* > ( A_out ) := H * ( A_in ) = ( I - V * T * V**H ) * ( A_in ) = */ +/* > ( B_out ) ( B_in ) ( B_in ) */ +/* > = ( I - ( V1 ) * T * ( V1**H, V2**H ) ) * ( A_in ) */ +/* > ( V2 ) ( B_in ) */ +/* > On input: */ +/* > */ +/* > a) ( A_in ) consists of two block columns: */ +/* > ( B_in ) */ +/* > */ +/* > ( A_in ) = (( A1_in ) ( A2_in )) = (( A1_in ) ( A2_in )) */ +/* > ( B_in ) (( B1_in ) ( B2_in )) (( 0 ) ( B2_in )), */ +/* > */ +/* > where the column blocks are: */ +/* > */ +/* > ( A1_in ) is a K-by-K upper-triangular matrix stored in the */ +/* > upper triangular part of the array A(1:K,1:K). */ +/* > ( B1_in ) is an M-by-K rectangular ZERO matrix and not stored. */ +/* > */ +/* > ( A2_in ) is a K-by-(N-K) rectangular matrix stored */ +/* > in the array A(1:K,K+1:N). */ +/* > ( B2_in ) is an M-by-(N-K) rectangular matrix stored */ +/* > in the array B(1:M,K+1:N). */ +/* > */ +/* > b) V = ( V1 ) */ +/* > ( V2 ) */ +/* > */ +/* > where: */ +/* > 1) if IDENT == 'I',V1 is a K-by-K identity matrix, not stored; */ +/* > 2) if IDENT != 'I',V1 is a K-by-K unit lower-triangular matrix, */ +/* > stored in the lower-triangular part of the array */ +/* > A(1:K,1:K) (ones are not stored), */ +/* > and V2 is an M-by-K rectangular stored the array B(1:M,1:K), */ +/* > (because on input B1_in is a rectangular zero */ +/* > matrix that is not stored and the space is */ +/* > used to store V2). */ +/* > */ +/* > c) T is a K-by-K upper-triangular matrix stored */ +/* > in the array T(1:K,1:K). */ +/* > */ +/* > On output: */ +/* > */ +/* > a) ( A_out ) consists of two block columns: */ +/* > ( B_out ) */ +/* > */ +/* > ( A_out ) = (( A1_out ) ( A2_out )) */ +/* > ( B_out ) (( B1_out ) ( B2_out )), */ +/* > */ +/* > where the column blocks are: */ +/* > */ +/* > ( A1_out ) is a K-by-K square matrix, or a K-by-K */ +/* > upper-triangular matrix, if V1 is an */ +/* > identity matrix. AiOut is stored in */ +/* > the array A(1:K,1:K). */ +/* > ( B1_out ) is an M-by-K rectangular matrix stored */ +/* > in the array B(1:M,K:N). */ +/* > */ +/* > ( A2_out ) is a K-by-(N-K) rectangular matrix stored */ +/* > in the array A(1:K,K+1:N). */ +/* > ( B2_out ) is an M-by-(N-K) rectangular matrix stored */ +/* > in the array B(1:M,K+1:N). */ +/* > */ +/* > */ +/* > The operation above can be represented as the same operation */ +/* > on each block column: */ +/* > */ +/* > ( A1_out ) := H * ( A1_in ) = ( I - V * T * V**H ) * ( A1_in ) */ +/* > ( B1_out ) ( 0 ) ( 0 ) */ +/* > */ +/* > ( A2_out ) := H * ( A2_in ) = ( I - V * T * V**H ) * ( A2_in ) */ +/* > ( B2_out ) ( B2_in ) ( B2_in ) */ +/* > */ +/* > If IDENT != 'I': */ +/* > */ +/* > The computation for column block 1: */ +/* > */ +/* > A1_out: = A1_in - V1*T*(V1**H)*A1_in */ +/* > */ +/* > B1_out: = - V2*T*(V1**H)*A1_in */ +/* > */ +/* > The computation for column block 2, which exists if N > K: */ +/* > */ +/* > A2_out: = A2_in - V1*T*( (V1**H)*A2_in + (V2**H)*B2_in ) */ +/* > */ +/* > B2_out: = B2_in - V2*T*( (V1**H)*A2_in + (V2**H)*B2_in ) */ +/* > */ +/* > If IDENT == 'I': */ +/* > */ +/* > The operation for column block 1: */ +/* > */ +/* > A1_out: = A1_in - V1*T*A1_in */ +/* > */ +/* > B1_out: = - V2*T*A1_in */ +/* > */ +/* > The computation for column block 2, which exists if N > K: */ +/* > */ +/* > A2_out: = A2_in - T*( A2_in + (V2**H)*B2_in ) */ +/* > */ +/* > B2_out: = B2_in - V2*T*( A2_in + (V2**H)*B2_in ) */ +/* > */ +/* > (2) Description of the Algorithmic Computation. */ +/* > */ +/* > In the first step, we compute column block 2, i.e. A2 and B2. */ +/* > Here, we need to use the K-by-(N-K) rectangular workspace */ +/* > matrix W2 that is of the same size as the matrix A2. */ +/* > W2 is stored in the array WORK(1:K,1:(N-K)). */ +/* > */ +/* > In the second step, we compute column block 1, i.e. A1 and B1. */ +/* > Here, we need to use the K-by-K square workspace matrix W1 */ +/* > that is of the same size as the as the matrix A1. */ +/* > W1 is stored in the array WORK(1:K,1:K). */ +/* > */ +/* > NOTE: Hence, in this routine, we need the workspace array WORK */ +/* > only of size WORK(1:K,1:f2cmax(K,N-K)) so it can hold both W2 from */ +/* > the first step and W1 from the second step. */ +/* > */ +/* > Case (A), when V1 is unit lower-triangular, i.e. IDENT != 'I', */ +/* > more computations than in the Case (B). */ +/* > */ +/* > if( IDENT != 'I' ) then */ +/* > if ( N > K ) then */ +/* > (First Step - column block 2) */ +/* > col2_(1) W2: = A2 */ +/* > col2_(2) W2: = (V1**H) * W2 = (unit_lower_tr_of_(A1)**H) * W2 */ +/* > col2_(3) W2: = W2 + (V2**H) * B2 = W2 + (B1**H) * B2 */ +/* > col2_(4) W2: = T * W2 */ +/* > col2_(5) B2: = B2 - V2 * W2 = B2 - B1 * W2 */ +/* > col2_(6) W2: = V1 * W2 = unit_lower_tr_of_(A1) * W2 */ +/* > col2_(7) A2: = A2 - W2 */ +/* > else */ +/* > (Second Step - column block 1) */ +/* > col1_(1) W1: = A1 */ +/* > col1_(2) W1: = (V1**H) * W1 = (unit_lower_tr_of_(A1)**H) * W1 */ +/* > col1_(3) W1: = T * W1 */ +/* > col1_(4) B1: = - V2 * W1 = - B1 * W1 */ +/* > col1_(5) square W1: = V1 * W1 = unit_lower_tr_of_(A1) * W1 */ +/* > col1_(6) square A1: = A1 - W1 */ +/* > end if */ +/* > end if */ +/* > */ +/* > Case (B), when V1 is an identity matrix, i.e. IDENT == 'I', */ +/* > less computations than in the Case (A) */ +/* > */ +/* > if( IDENT == 'I' ) then */ +/* > if ( N > K ) then */ +/* > (First Step - column block 2) */ +/* > col2_(1) W2: = A2 */ +/* > col2_(3) W2: = W2 + (V2**H) * B2 = W2 + (B1**H) * B2 */ +/* > col2_(4) W2: = T * W2 */ +/* > col2_(5) B2: = B2 - V2 * W2 = B2 - B1 * W2 */ +/* > col2_(7) A2: = A2 - W2 */ +/* > else */ +/* > (Second Step - column block 1) */ +/* > col1_(1) W1: = A1 */ +/* > col1_(3) W1: = T * W1 */ +/* > col1_(4) B1: = - V2 * W1 = - B1 * W1 */ +/* > col1_(6) upper-triangular_of_(A1): = A1 - W1 */ +/* > end if */ +/* > end if */ +/* > */ +/* > Combine these cases (A) and (B) together, this is the resulting */ +/* > algorithm: */ +/* > */ +/* > if ( N > K ) then */ +/* > */ +/* > (First Step - column block 2) */ +/* > */ +/* > col2_(1) W2: = A2 */ +/* > if( IDENT != 'I' ) then */ +/* > col2_(2) W2: = (V1**H) * W2 */ +/* > = (unit_lower_tr_of_(A1)**H) * W2 */ +/* > end if */ +/* > col2_(3) W2: = W2 + (V2**H) * B2 = W2 + (B1**H) * B2] */ +/* > col2_(4) W2: = T * W2 */ +/* > col2_(5) B2: = B2 - V2 * W2 = B2 - B1 * W2 */ +/* > if( IDENT != 'I' ) then */ +/* > col2_(6) W2: = V1 * W2 = unit_lower_tr_of_(A1) * W2 */ +/* > end if */ +/* > col2_(7) A2: = A2 - W2 */ +/* > */ +/* > else */ +/* > */ +/* > (Second Step - column block 1) */ +/* > */ +/* > col1_(1) W1: = A1 */ +/* > if( IDENT != 'I' ) then */ +/* > col1_(2) W1: = (V1**H) * W1 */ +/* > = (unit_lower_tr_of_(A1)**H) * W1 */ +/* > end if */ +/* > col1_(3) W1: = T * W1 */ +/* > col1_(4) B1: = - V2 * W1 = - B1 * W1 */ +/* > if( IDENT != 'I' ) then */ +/* > col1_(5) square W1: = V1 * W1 = unit_lower_tr_of_(A1) * W1 */ +/* > col1_(6_a) below_diag_of_(A1): = - below_diag_of_(W1) */ +/* > end if */ +/* > col1_(6_b) up_tr_of_(A1): = up_tr_of_(A1) - up_tr_of_(W1) */ +/* > */ +/* > end if */ +/* > */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlarfb_gett_(char *ident, integer *m, integer *n, + integer *k, doublecomplex *t, integer *ldt, doublecomplex *a, integer + *lda, doublecomplex *b, integer *ldb, doublecomplex *work, integer * + ldwork) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, t_dim1, t_offset, work_dim1, + work_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1; + + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *), zcopy_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *), ztrmm_(char *, char *, + char *, char *, integer *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *); + logical lnotident; + + +/* -- LAPACK auxiliary routine -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + work_dim1 = *ldwork; + work_offset = 1 + work_dim1 * 1; + work -= work_offset; + + /* Function Body */ + if (*m < 0 || *n <= 0 || *k == 0 || *k > *n) { + return 0; + } + + lnotident = ! lsame_(ident, "I"); + +/* ------------------------------------------------------------------ */ + +/* First Step. Computation of the Column Block 2: */ + +/* ( A2 ) := H * ( A2 ) */ +/* ( B2 ) ( B2 ) */ + +/* ------------------------------------------------------------------ */ + + if (*n > *k) { + +/* col2_(1) Compute W2: = A2. Therefore, copy A2 = A(1:K, K+1:N) */ +/* into W2=WORK(1:K, 1:N-K) column-by-column. */ + + i__1 = *n - *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(k, &a[(*k + j) * a_dim1 + 1], &c__1, &work[j * work_dim1 + + 1], &c__1); + } + if (lnotident) { + +/* col2_(2) Compute W2: = (V1**H) * W2 = (A1**H) * W2, */ +/* V1 is not an identy matrix, but unit lower-triangular */ +/* V1 stored in A1 (diagonal ones are not stored). */ + + + i__1 = *n - *k; + ztrmm_("L", "L", "C", "U", k, &i__1, &c_b1, &a[a_offset], lda, & + work[work_offset], ldwork); + } + +/* col2_(3) Compute W2: = W2 + (V2**H) * B2 = W2 + (B1**H) * B2 */ +/* V2 stored in B1. */ + + if (*m > 0) { + i__1 = *n - *k; + zgemm_("C", "N", k, &i__1, m, &c_b1, &b[b_offset], ldb, &b[(*k + + 1) * b_dim1 + 1], ldb, &c_b1, &work[work_offset], ldwork); + } + +/* col2_(4) Compute W2: = T * W2, */ +/* T is upper-triangular. */ + + i__1 = *n - *k; + ztrmm_("L", "U", "N", "N", k, &i__1, &c_b1, &t[t_offset], ldt, &work[ + work_offset], ldwork); + +/* col2_(5) Compute B2: = B2 - V2 * W2 = B2 - B1 * W2, */ +/* V2 stored in B1. */ + + if (*m > 0) { + i__1 = *n - *k; + z__1.r = -1., z__1.i = 0.; + zgemm_("N", "N", m, &i__1, k, &z__1, &b[b_offset], ldb, &work[ + work_offset], ldwork, &c_b1, &b[(*k + 1) * b_dim1 + 1], + ldb); + } + + if (lnotident) { + +/* col2_(6) Compute W2: = V1 * W2 = A1 * W2, */ +/* V1 is not an identity matrix, but unit lower-triangular, */ +/* V1 stored in A1 (diagonal ones are not stored). */ + + i__1 = *n - *k; + ztrmm_("L", "L", "N", "U", k, &i__1, &c_b1, &a[a_offset], lda, & + work[work_offset], ldwork); + } + +/* col2_(7) Compute A2: = A2 - W2 = */ +/* = A(1:K, K+1:N-K) - WORK(1:K, 1:N-K), */ +/* column-by-column. */ + + i__1 = *n - *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (*k + j) * a_dim1; + i__4 = i__ + (*k + j) * a_dim1; + i__5 = i__ + j * work_dim1; + z__1.r = a[i__4].r - work[i__5].r, z__1.i = a[i__4].i - work[ + i__5].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + + } + +/* ------------------------------------------------------------------ */ + +/* Second Step. Computation of the Column Block 1: */ + +/* ( A1 ) := H * ( A1 ) */ +/* ( B1 ) ( 0 ) */ + +/* ------------------------------------------------------------------ */ + +/* col1_(1) Compute W1: = A1. Copy the upper-triangular */ +/* A1 = A(1:K, 1:K) into the upper-triangular */ +/* W1 = WORK(1:K, 1:K) column-by-column. */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(&j, &a[j * a_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1) + ; + } + +/* Set the subdiagonal elements of W1 to zero column-by-column. */ + + i__1 = *k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * work_dim1; + work[i__3].r = 0., work[i__3].i = 0.; + } + } + + if (lnotident) { + +/* col1_(2) Compute W1: = (V1**H) * W1 = (A1**H) * W1, */ +/* V1 is not an identity matrix, but unit lower-triangular */ +/* V1 stored in A1 (diagonal ones are not stored), */ +/* W1 is upper-triangular with zeroes below the diagonal. */ + + ztrmm_("L", "L", "C", "U", k, k, &c_b1, &a[a_offset], lda, &work[ + work_offset], ldwork); + } + +/* col1_(3) Compute W1: = T * W1, */ +/* T is upper-triangular, */ +/* W1 is upper-triangular with zeroes below the diagonal. */ + + ztrmm_("L", "U", "N", "N", k, k, &c_b1, &t[t_offset], ldt, &work[ + work_offset], ldwork); + +/* col1_(4) Compute B1: = - V2 * W1 = - B1 * W1, */ +/* V2 = B1, W1 is upper-triangular with zeroes below the diagonal. */ + + if (*m > 0) { + z__1.r = -1., z__1.i = 0.; + ztrmm_("R", "U", "N", "N", m, k, &z__1, &work[work_offset], ldwork, & + b[b_offset], ldb); + } + + if (lnotident) { + +/* col1_(5) Compute W1: = V1 * W1 = A1 * W1, */ +/* V1 is not an identity matrix, but unit lower-triangular */ +/* V1 stored in A1 (diagonal ones are not stored), */ +/* W1 is upper-triangular on input with zeroes below the diagonal, */ +/* and square on output. */ + + ztrmm_("L", "L", "N", "U", k, k, &c_b1, &a[a_offset], lda, &work[ + work_offset], ldwork); + +/* col1_(6) Compute A1: = A1 - W1 = A(1:K, 1:K) - WORK(1:K, 1:K) */ +/* column-by-column. A1 is upper-triangular on input. */ +/* If IDENT, A1 is square on output, and W1 is square, */ +/* if NOT IDENT, A1 is upper-triangular on output, */ +/* W1 is upper-triangular. */ + +/* col1_(6)_a Compute elements of A1 below the diagonal. */ + + i__1 = *k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * work_dim1; + z__1.r = -work[i__4].r, z__1.i = -work[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + + } + +/* col1_(6)_b Compute elements of A1 on and above the diagonal. */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + i__5 = i__ + j * work_dim1; + z__1.r = a[i__4].r - work[i__5].r, z__1.i = a[i__4].i - work[i__5] + .i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + + return 0; + +/* End of ZLARFB_GETT */ + +} /* zlarfb_gett__ */ + diff --git a/lapack-netlib/SRC/zlarfg.c b/lapack-netlib/SRC/zlarfg.c new file mode 100644 index 000000000..4e17bc68d --- /dev/null +++ b/lapack-netlib/SRC/zlarfg.c @@ -0,0 +1,611 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLARFG generates an elementary reflector (Householder matrix). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLARFG + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU ) */ + +/* INTEGER INCX, N */ +/* COMPLEX*16 ALPHA, TAU */ +/* COMPLEX*16 X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLARFG generates a complex elementary reflector H of order n, such */ +/* > that */ +/* > */ +/* > H**H * ( alpha ) = ( beta ), H**H * H = I. */ +/* > ( x ) ( 0 ) */ +/* > */ +/* > where alpha and beta are scalars, with beta real, and x is an */ +/* > (n-1)-element complex vector. H is represented in the form */ +/* > */ +/* > H = I - tau * ( 1 ) * ( 1 v**H ) , */ +/* > ( v ) */ +/* > */ +/* > where tau is a complex scalar and v is a complex (n-1)-element */ +/* > vector. Note that H is not hermitian. */ +/* > */ +/* > If the elements of x are all zero and alpha is real, then tau = 0 */ +/* > and H is taken to be the unit matrix. */ +/* > */ +/* > Otherwise 1 <= real(tau) <= 2 and abs(tau-1) <= 1 . */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the elementary reflector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ALPHA */ +/* > \verbatim */ +/* > ALPHA is COMPLEX*16 */ +/* > On entry, the value alpha. */ +/* > On exit, it is overwritten with the value beta. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension */ +/* > (1+(N-2)*abs(INCX)) */ +/* > On entry, the vector x. */ +/* > On exit, it is overwritten with the vector v. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The increment between elements of X. INCX > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 */ +/* > The value tau. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlarfg_(integer *n, doublecomplex *alpha, doublecomplex * + x, integer *incx, doublecomplex *tau) +{ + /* System generated locals */ + integer i__1; + doublereal d__1, d__2; + doublecomplex z__1, z__2; + + /* Local variables */ + doublereal beta; + integer j; + doublereal alphi, alphr; + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *); + doublereal xnorm; + extern doublereal dlapy3_(doublereal *, doublereal *, doublereal *), + dznrm2_(integer *, doublecomplex *, integer *), dlamch_(char *); + doublereal safmin; + extern /* Subroutine */ int zdscal_(integer *, doublereal *, + doublecomplex *, integer *); + doublereal rsafmn; + extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *, + doublecomplex *); + integer knt; + + +/* -- LAPACK auxiliary 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 */ + --x; + + /* Function Body */ + if (*n <= 0) { + tau->r = 0., tau->i = 0.; + return 0; + } + + i__1 = *n - 1; + xnorm = dznrm2_(&i__1, &x[1], incx); + alphr = alpha->r; + alphi = d_imag(alpha); + + if (xnorm == 0. && alphi == 0.) { + +/* H = I */ + + tau->r = 0., tau->i = 0.; + } else { + +/* general case */ + + d__1 = dlapy3_(&alphr, &alphi, &xnorm); + beta = -d_sign(&d__1, &alphr); + safmin = dlamch_("S") / dlamch_("E"); + rsafmn = 1. / safmin; + + knt = 0; + if (abs(beta) < safmin) { + +/* XNORM, BETA may be inaccurate; scale X and recompute them */ + +L10: + ++knt; + i__1 = *n - 1; + zdscal_(&i__1, &rsafmn, &x[1], incx); + beta *= rsafmn; + alphi *= rsafmn; + alphr *= rsafmn; + if (abs(beta) < safmin && knt < 20) { + goto L10; + } + +/* New BETA is at most 1, at least SAFMIN */ + + i__1 = *n - 1; + xnorm = dznrm2_(&i__1, &x[1], incx); + z__1.r = alphr, z__1.i = alphi; + alpha->r = z__1.r, alpha->i = z__1.i; + d__1 = dlapy3_(&alphr, &alphi, &xnorm); + beta = -d_sign(&d__1, &alphr); + } + d__1 = (beta - alphr) / beta; + d__2 = -alphi / beta; + z__1.r = d__1, z__1.i = d__2; + tau->r = z__1.r, tau->i = z__1.i; + z__2.r = alpha->r - beta, z__2.i = alpha->i; + zladiv_(&z__1, &c_b5, &z__2); + alpha->r = z__1.r, alpha->i = z__1.i; + i__1 = *n - 1; + zscal_(&i__1, alpha, &x[1], incx); + +/* If ALPHA is subnormal, it may lose relative accuracy */ + + i__1 = knt; + for (j = 1; j <= i__1; ++j) { + beta *= safmin; +/* L20: */ + } + alpha->r = beta, alpha->i = 0.; + } + + return 0; + +/* End of ZLARFG */ + +} /* zlarfg_ */ + diff --git a/lapack-netlib/SRC/zlarfgp.c b/lapack-netlib/SRC/zlarfgp.c new file mode 100644 index 000000000..54dcc0080 --- /dev/null +++ b/lapack-netlib/SRC/zlarfgp.c @@ -0,0 +1,701 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLARFGP generates an elementary reflector (Householder matrix) with non-negative beta. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLARFGP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLARFGP( N, ALPHA, X, INCX, TAU ) */ + +/* INTEGER INCX, N */ +/* COMPLEX*16 ALPHA, TAU */ +/* COMPLEX*16 X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLARFGP generates a complex elementary reflector H of order n, such */ +/* > that */ +/* > */ +/* > H**H * ( alpha ) = ( beta ), H**H * H = I. */ +/* > ( x ) ( 0 ) */ +/* > */ +/* > where alpha and beta are scalars, beta is real and non-negative, and */ +/* > x is an (n-1)-element complex vector. H is represented in the form */ +/* > */ +/* > H = I - tau * ( 1 ) * ( 1 v**H ) , */ +/* > ( v ) */ +/* > */ +/* > where tau is a complex scalar and v is a complex (n-1)-element */ +/* > vector. Note that H is not hermitian. */ +/* > */ +/* > If the elements of x are all zero and alpha is real, then tau = 0 */ +/* > and H is taken to be the unit matrix. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the elementary reflector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ALPHA */ +/* > \verbatim */ +/* > ALPHA is COMPLEX*16 */ +/* > On entry, the value alpha. */ +/* > On exit, it is overwritten with the value beta. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension */ +/* > (1+(N-2)*abs(INCX)) */ +/* > On entry, the vector x. */ +/* > On exit, it is overwritten with the vector v. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The increment between elements of X. INCX > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 */ +/* > The value tau. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlarfgp_(integer *n, doublecomplex *alpha, doublecomplex + *x, integer *incx, doublecomplex *tau) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal d__1, d__2; + doublecomplex z__1, z__2; + + /* Local variables */ + doublereal beta; + integer j; + doublereal alphi, alphr; + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *); + doublecomplex savealpha; + doublereal xnorm; + extern doublereal dlapy2_(doublereal *, doublereal *), dlapy3_(doublereal + *, doublereal *, doublereal *), dznrm2_(integer *, doublecomplex * + , integer *), dlamch_(char *); + extern /* Subroutine */ int zdscal_(integer *, doublereal *, + doublecomplex *, integer *); + doublereal bignum; + extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *, + doublecomplex *); + doublereal smlnum; + integer knt; + + +/* -- LAPACK auxiliary 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 */ + --x; + + /* Function Body */ + if (*n <= 0) { + tau->r = 0., tau->i = 0.; + return 0; + } + + i__1 = *n - 1; + xnorm = dznrm2_(&i__1, &x[1], incx); + alphr = alpha->r; + alphi = d_imag(alpha); + + if (xnorm == 0.) { + +/* H = [1-alpha/abs(alpha) 0; 0 I], sign chosen so ALPHA >= 0. */ + + if (alphi == 0.) { + if (alphr >= 0.) { +/* When TAU.eq.ZERO, the vector is special-cased to be */ +/* all zeros in the application routines. We do not need */ +/* to clear it. */ + tau->r = 0., tau->i = 0.; + } else { +/* However, the application routines rely on explicit */ +/* zero checks when TAU.ne.ZERO, and we must clear X. */ + tau->r = 2., tau->i = 0.; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = (j - 1) * *incx + 1; + x[i__2].r = 0., x[i__2].i = 0.; + } + z__1.r = -alpha->r, z__1.i = -alpha->i; + alpha->r = z__1.r, alpha->i = z__1.i; + } + } else { +/* Only "reflecting" the diagonal entry to be real and non-negative. */ + xnorm = dlapy2_(&alphr, &alphi); + d__1 = 1. - alphr / xnorm; + d__2 = -alphi / xnorm; + z__1.r = d__1, z__1.i = d__2; + tau->r = z__1.r, tau->i = z__1.i; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = (j - 1) * *incx + 1; + x[i__2].r = 0., x[i__2].i = 0.; + } + alpha->r = xnorm, alpha->i = 0.; + } + } else { + +/* general case */ + + d__1 = dlapy3_(&alphr, &alphi, &xnorm); + beta = d_sign(&d__1, &alphr); + smlnum = dlamch_("S") / dlamch_("E"); + bignum = 1. / smlnum; + + knt = 0; + if (abs(beta) < smlnum) { + +/* XNORM, BETA may be inaccurate; scale X and recompute them */ + +L10: + ++knt; + i__1 = *n - 1; + zdscal_(&i__1, &bignum, &x[1], incx); + beta *= bignum; + alphi *= bignum; + alphr *= bignum; + if (abs(beta) < smlnum && knt < 20) { + goto L10; + } + +/* New BETA is at most 1, at least SMLNUM */ + + i__1 = *n - 1; + xnorm = dznrm2_(&i__1, &x[1], incx); + z__1.r = alphr, z__1.i = alphi; + alpha->r = z__1.r, alpha->i = z__1.i; + d__1 = dlapy3_(&alphr, &alphi, &xnorm); + beta = d_sign(&d__1, &alphr); + } + savealpha.r = alpha->r, savealpha.i = alpha->i; + z__1.r = alpha->r + beta, z__1.i = alpha->i; + alpha->r = z__1.r, alpha->i = z__1.i; + if (beta < 0.) { + beta = -beta; + z__2.r = -alpha->r, z__2.i = -alpha->i; + z__1.r = z__2.r / beta, z__1.i = z__2.i / beta; + tau->r = z__1.r, tau->i = z__1.i; + } else { + alphr = alphi * (alphi / alpha->r); + alphr += xnorm * (xnorm / alpha->r); + d__1 = alphr / beta; + d__2 = -alphi / beta; + z__1.r = d__1, z__1.i = d__2; + tau->r = z__1.r, tau->i = z__1.i; + d__1 = -alphr; + z__1.r = d__1, z__1.i = alphi; + alpha->r = z__1.r, alpha->i = z__1.i; + } + zladiv_(&z__1, &c_b5, alpha); + alpha->r = z__1.r, alpha->i = z__1.i; + + if (z_abs(tau) <= smlnum) { + +/* In the case where the computed TAU ends up being a denormalized number, */ +/* it loses relative accuracy. This is a BIG problem. Solution: flush TAU */ +/* to ZERO (or TWO or whatever makes a nonnegative real number for BETA). */ + +/* (Bug report provided by Pat Quillen from MathWorks on Jul 29, 2009.) */ +/* (Thanks Pat. Thanks MathWorks.) */ + + alphr = savealpha.r; + alphi = d_imag(&savealpha); + if (alphi == 0.) { + if (alphr >= 0.) { + tau->r = 0., tau->i = 0.; + } else { + tau->r = 2., tau->i = 0.; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = (j - 1) * *incx + 1; + x[i__2].r = 0., x[i__2].i = 0.; + } + z__1.r = -savealpha.r, z__1.i = -savealpha.i; + beta = z__1.r; + } + } else { + xnorm = dlapy2_(&alphr, &alphi); + d__1 = 1. - alphr / xnorm; + d__2 = -alphi / xnorm; + z__1.r = d__1, z__1.i = d__2; + tau->r = z__1.r, tau->i = z__1.i; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = (j - 1) * *incx + 1; + x[i__2].r = 0., x[i__2].i = 0.; + } + beta = xnorm; + } + + } else { + +/* This is the general case. */ + + i__1 = *n - 1; + zscal_(&i__1, alpha, &x[1], incx); + + } + +/* If BETA is subnormal, it may lose relative accuracy */ + + i__1 = knt; + for (j = 1; j <= i__1; ++j) { + beta *= smlnum; +/* L20: */ + } + alpha->r = beta, alpha->i = 0.; + } + + return 0; + +/* End of ZLARFGP */ + +} /* zlarfgp_ */ + diff --git a/lapack-netlib/SRC/zlarft.c b/lapack-netlib/SRC/zlarft.c new file mode 100644 index 000000000..22aea26f5 --- /dev/null +++ b/lapack-netlib/SRC/zlarft.c @@ -0,0 +1,809 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLARFT forms the triangular factor T of a block reflector H = I - vtvH */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLARFT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) */ + +/* CHARACTER DIRECT, STOREV */ +/* INTEGER K, LDT, LDV, N */ +/* COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLARFT forms the triangular factor T of a complex block reflector H */ +/* > of order n, which is defined as a product of k elementary reflectors. */ +/* > */ +/* > If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */ +/* > */ +/* > If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */ +/* > */ +/* > If STOREV = 'C', the vector which defines the elementary reflector */ +/* > H(i) is stored in the i-th column of the array V, and */ +/* > */ +/* > H = I - V * T * V**H */ +/* > */ +/* > If STOREV = 'R', the vector which defines the elementary reflector */ +/* > H(i) is stored in the i-th row of the array V, and */ +/* > */ +/* > H = I - V**H * T * V */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] DIRECT */ +/* > \verbatim */ +/* > DIRECT is CHARACTER*1 */ +/* > Specifies the order in which the elementary reflectors are */ +/* > multiplied to form the block reflector: */ +/* > = 'F': H = H(1) H(2) . . . H(k) (Forward) */ +/* > = 'B': H = H(k) . . . H(2) H(1) (Backward) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] STOREV */ +/* > \verbatim */ +/* > STOREV is CHARACTER*1 */ +/* > Specifies how the vectors which define the elementary */ +/* > reflectors are stored (see also Further Details): */ +/* > = 'C': columnwise */ +/* > = 'R': rowwise */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the block reflector H. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The order of the triangular factor T (= the number of */ +/* > elementary reflectors). K >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is COMPLEX*16 array, dimension */ +/* > (LDV,K) if STOREV = 'C' */ +/* > (LDV,N) if STOREV = 'R' */ +/* > The matrix V. See further details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. */ +/* > If STOREV = 'C', LDV >= f2cmax(1,N); if STOREV = 'R', LDV >= K. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 array, dimension (K) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is COMPLEX*16 array, dimension (LDT,K) */ +/* > The k by k triangular factor T of the block reflector. */ +/* > If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */ +/* > lower triangular. The rest of the array is not used. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= K. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The shape of the matrix V and the storage of the vectors which define */ +/* > the H(i) is best illustrated by the following example with n = 5 and */ +/* > k = 3. The elements equal to 1 are not stored. */ +/* > */ +/* > DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */ +/* > */ +/* > V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */ +/* > ( v1 1 ) ( 1 v2 v2 v2 ) */ +/* > ( v1 v2 1 ) ( 1 v3 v3 ) */ +/* > ( v1 v2 v3 ) */ +/* > ( v1 v2 v3 ) */ +/* > */ +/* > DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */ +/* > */ +/* > V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */ +/* > ( v1 v2 v3 ) ( v2 v2 v2 1 ) */ +/* > ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */ +/* > ( 1 v3 ) */ +/* > ( 1 ) */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlarft_(char *direct, char *storev, integer *n, integer * + k, doublecomplex *v, integer *ldv, doublecomplex *tau, doublecomplex * + t, integer *ldt) +{ + /* System generated locals */ + integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *), zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + integer lastv; + extern /* Subroutine */ int ztrmv_(char *, char *, char *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + integer prevlastv; + extern /* Subroutine */ int mecago_(); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + --tau; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + + /* Function Body */ + if (*n == 0) { + return 0; + } + + if (lsame_(direct, "F")) { + prevlastv = *n; + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + prevlastv = f2cmax(prevlastv,i__); + i__2 = i__; + if (tau[i__2].r == 0. && tau[i__2].i == 0.) { + +/* H(i) = I */ + + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * t_dim1; + t[i__3].r = 0., t[i__3].i = 0.; + } + } else { + +/* general case */ + + if (lsame_(storev, "C")) { +/* Skip any trailing zeros. */ + i__2 = i__ + 1; + for (lastv = *n; lastv >= i__2; --lastv) { + i__3 = lastv + i__ * v_dim1; + if (v[i__3].r != 0. || v[i__3].i != 0.) { + myexit_(); + } + } + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * t_dim1; + i__4 = i__; + z__2.r = -tau[i__4].r, z__2.i = -tau[i__4].i; + d_cnjg(&z__3, &v[i__ + j * v_dim1]); + z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = + z__2.r * z__3.i + z__2.i * z__3.r; + t[i__3].r = z__1.r, t[i__3].i = z__1.i; + } + j = f2cmin(lastv,prevlastv); + +/* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**H * V(i:j,i) */ + + i__2 = j - i__; + i__3 = i__ - 1; + i__4 = i__; + z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i; + zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &v[i__ + + 1 + v_dim1], ldv, &v[i__ + 1 + i__ * v_dim1], & + c__1, &c_b1, &t[i__ * t_dim1 + 1], &c__1); + } else { +/* Skip any trailing zeros. */ + i__2 = i__ + 1; + for (lastv = *n; lastv >= i__2; --lastv) { + i__3 = i__ + lastv * v_dim1; + if (v[i__3].r != 0. || v[i__3].i != 0.) { + myexit_(); + } + } + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * t_dim1; + i__4 = i__; + z__2.r = -tau[i__4].r, z__2.i = -tau[i__4].i; + i__5 = j + i__ * v_dim1; + z__1.r = z__2.r * v[i__5].r - z__2.i * v[i__5].i, + z__1.i = z__2.r * v[i__5].i + z__2.i * v[i__5] + .r; + t[i__3].r = z__1.r, t[i__3].i = z__1.i; + } + j = f2cmin(lastv,prevlastv); + +/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**H */ + + i__2 = i__ - 1; + i__3 = j - i__; + i__4 = i__; + z__1.r = -tau[i__4].r, z__1.i = -tau[i__4].i; + zgemm_("N", "C", &i__2, &c__1, &i__3, &z__1, &v[(i__ + 1) + * v_dim1 + 1], ldv, &v[i__ + (i__ + 1) * v_dim1], + ldv, &c_b1, &t[i__ * t_dim1 + 1], ldt); + } + +/* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */ + + i__2 = i__ - 1; + ztrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[ + t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1); + i__2 = i__ + i__ * t_dim1; + i__3 = i__; + t[i__2].r = tau[i__3].r, t[i__2].i = tau[i__3].i; + if (i__ > 1) { + prevlastv = f2cmax(prevlastv,lastv); + } else { + prevlastv = lastv; + } + } + } + } else { + prevlastv = 1; + for (i__ = *k; i__ >= 1; --i__) { + i__1 = i__; + if (tau[i__1].r == 0. && tau[i__1].i == 0.) { + +/* H(i) = I */ + + i__1 = *k; + for (j = i__; j <= i__1; ++j) { + i__2 = j + i__ * t_dim1; + t[i__2].r = 0., t[i__2].i = 0.; + } + } else { + +/* general case */ + + if (i__ < *k) { + if (lsame_(storev, "C")) { +/* Skip any leading zeros. */ + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + i__2 = lastv + i__ * v_dim1; + if (v[i__2].r != 0. || v[i__2].i != 0.) { + myexit_(); + } + } + i__1 = *k; + for (j = i__ + 1; j <= i__1; ++j) { + i__2 = j + i__ * t_dim1; + i__3 = i__; + z__2.r = -tau[i__3].r, z__2.i = -tau[i__3].i; + d_cnjg(&z__3, &v[*n - *k + i__ + j * v_dim1]); + z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, + z__1.i = z__2.r * z__3.i + z__2.i * + z__3.r; + t[i__2].r = z__1.r, t[i__2].i = z__1.i; + } + j = f2cmax(lastv,prevlastv); + +/* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**H * V(j:n-k+i,i) */ + + i__1 = *n - *k + i__ - j; + i__2 = *k - i__; + i__3 = i__; + z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; + zgemv_("Conjugate transpose", &i__1, &i__2, &z__1, &v[ + j + (i__ + 1) * v_dim1], ldv, &v[j + i__ * + v_dim1], &c__1, &c_b1, &t[i__ + 1 + i__ * + t_dim1], &c__1); + } else { +/* Skip any leading zeros. */ + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + i__2 = i__ + lastv * v_dim1; + if (v[i__2].r != 0. || v[i__2].i != 0.) { + myexit_(); + } + } + i__1 = *k; + for (j = i__ + 1; j <= i__1; ++j) { + i__2 = j + i__ * t_dim1; + i__3 = i__; + z__2.r = -tau[i__3].r, z__2.i = -tau[i__3].i; + i__4 = j + (*n - *k + i__) * v_dim1; + z__1.r = z__2.r * v[i__4].r - z__2.i * v[i__4].i, + z__1.i = z__2.r * v[i__4].i + z__2.i * v[ + i__4].r; + t[i__2].r = z__1.r, t[i__2].i = z__1.i; + } + j = f2cmax(lastv,prevlastv); + +/* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**H */ + + i__1 = *k - i__; + i__2 = *n - *k + i__ - j; + i__3 = i__; + z__1.r = -tau[i__3].r, z__1.i = -tau[i__3].i; + zgemm_("N", "C", &i__1, &c__1, &i__2, &z__1, &v[i__ + + 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], + ldv, &c_b1, &t[i__ + 1 + i__ * t_dim1], ldt); + } + +/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */ + + i__1 = *k - i__; + ztrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ + + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * + t_dim1], &c__1) + ; + if (i__ > 1) { + prevlastv = f2cmin(prevlastv,lastv); + } else { + prevlastv = lastv; + } + } + i__1 = i__ + i__ * t_dim1; + i__2 = i__; + t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i; + } + } + } + return 0; + +/* End of ZLARFT */ + +} /* zlarft_ */ + diff --git a/lapack-netlib/SRC/zlarfx.c b/lapack-netlib/SRC/zlarfx.c new file mode 100644 index 000000000..f3dfdc65f --- /dev/null +++ b/lapack-netlib/SRC/zlarfx.c @@ -0,0 +1,2479 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLARFX applies an elementary reflector to a general rectangular matrix, with loop unrolling whe +n the reflector has order ≤ 10. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLARFX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) */ + +/* CHARACTER SIDE */ +/* INTEGER LDC, M, N */ +/* COMPLEX*16 TAU */ +/* COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLARFX applies a complex elementary reflector H to a complex m by n */ +/* > matrix C, from either the left or the right. H is represented in the */ +/* > form */ +/* > */ +/* > H = I - tau * v * v**H */ +/* > */ +/* > where tau is a complex scalar and v is a complex vector. */ +/* > */ +/* > If tau = 0, then H is taken to be the unit matrix */ +/* > */ +/* > This version uses inline code if H has order < 11. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': form H * C */ +/* > = 'R': form C * H */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is COMPLEX*16 array, dimension (M) if SIDE = 'L' */ +/* > or (N) if SIDE = 'R' */ +/* > The vector v in the representation of H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 */ +/* > The value tau in the representation of H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX*16 array, dimension (LDC,N) */ +/* > On entry, the m by n matrix C. */ +/* > On exit, C is overwritten by the matrix H * C if SIDE = 'L', */ +/* > or C * H if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (N) if SIDE = 'L' */ +/* > or (M) if SIDE = 'R' */ +/* > WORK is not referenced if H has order < 11. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlarfx_(char *side, integer *m, integer *n, + doublecomplex *v, doublecomplex *tau, doublecomplex *c__, integer * + ldc, doublecomplex *work) +{ + /* System generated locals */ + integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7, i__8, + i__9, i__10, i__11; + doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7, z__8, z__9, z__10, + z__11, z__12, z__13, z__14, z__15, z__16, z__17, z__18, z__19; + + /* Local variables */ + integer j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int zlarf_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *); + doublecomplex t1, t2, t3, t4, t5, t6, t7, t8, t9, v1, v2, v3, v4, v5, v6, + v7, v8, v9, t10, v10, sum; + + +/* -- 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 */ + --v; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + if (tau->r == 0. && tau->i == 0.) { + return 0; + } + if (lsame_(side, "L")) { + +/* Form H * C, where H has order m. */ + + switch (*m) { + case 1: goto L10; + case 2: goto L30; + case 3: goto L50; + case 4: goto L70; + case 5: goto L90; + case 6: goto L110; + case 7: goto L130; + case 8: goto L150; + case 9: goto L170; + case 10: goto L190; + } + +/* Code for general M */ + + zlarf_(side, m, n, &v[1], &c__1, tau, &c__[c_offset], ldc, &work[1]); + goto L410; +L10: + +/* Special code for 1 x 1 Householder */ + + z__3.r = tau->r * v[1].r - tau->i * v[1].i, z__3.i = tau->r * v[1].i + + tau->i * v[1].r; + d_cnjg(&z__4, &v[1]); + z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * z__4.i + + z__3.i * z__4.r; + z__1.r = 1. - z__2.r, z__1.i = 0. - z__2.i; + t1.r = z__1.r, t1.i = z__1.i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j * c_dim1 + 1; + i__3 = j * c_dim1 + 1; + z__1.r = t1.r * c__[i__3].r - t1.i * c__[i__3].i, z__1.i = t1.r * + c__[i__3].i + t1.i * c__[i__3].r; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; +/* L20: */ + } + goto L410; +L30: + +/* Special code for 2 x 2 Householder */ + + d_cnjg(&z__1, &v[1]); + v1.r = z__1.r, v1.i = z__1.i; + d_cnjg(&z__2, &v1); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t1.r = z__1.r, t1.i = z__1.i; + d_cnjg(&z__1, &v[2]); + v2.r = z__1.r, v2.i = z__1.i; + d_cnjg(&z__2, &v2); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t2.r = z__1.r, t2.i = z__1.i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j * c_dim1 + 1; + z__2.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__2.i = v1.r * + c__[i__2].i + v1.i * c__[i__2].r; + i__3 = j * c_dim1 + 2; + z__3.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__3.i = v2.r * + c__[i__3].i + v2.i * c__[i__3].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + sum.r = z__1.r, sum.i = z__1.i; + i__2 = j * c_dim1 + 1; + i__3 = j * c_dim1 + 1; + z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + + sum.i * t1.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 2; + i__3 = j * c_dim1 + 2; + z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + + sum.i * t2.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; +/* L40: */ + } + goto L410; +L50: + +/* Special code for 3 x 3 Householder */ + + d_cnjg(&z__1, &v[1]); + v1.r = z__1.r, v1.i = z__1.i; + d_cnjg(&z__2, &v1); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t1.r = z__1.r, t1.i = z__1.i; + d_cnjg(&z__1, &v[2]); + v2.r = z__1.r, v2.i = z__1.i; + d_cnjg(&z__2, &v2); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t2.r = z__1.r, t2.i = z__1.i; + d_cnjg(&z__1, &v[3]); + v3.r = z__1.r, v3.i = z__1.i; + d_cnjg(&z__2, &v3); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t3.r = z__1.r, t3.i = z__1.i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j * c_dim1 + 1; + z__3.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__3.i = v1.r * + c__[i__2].i + v1.i * c__[i__2].r; + i__3 = j * c_dim1 + 2; + z__4.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__4.i = v2.r * + c__[i__3].i + v2.i * c__[i__3].r; + z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i; + i__4 = j * c_dim1 + 3; + z__5.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__5.i = v3.r * + c__[i__4].i + v3.i * c__[i__4].r; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; + sum.r = z__1.r, sum.i = z__1.i; + i__2 = j * c_dim1 + 1; + i__3 = j * c_dim1 + 1; + z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + + sum.i * t1.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 2; + i__3 = j * c_dim1 + 2; + z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + + sum.i * t2.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 3; + i__3 = j * c_dim1 + 3; + z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + + sum.i * t3.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; +/* L60: */ + } + goto L410; +L70: + +/* Special code for 4 x 4 Householder */ + + d_cnjg(&z__1, &v[1]); + v1.r = z__1.r, v1.i = z__1.i; + d_cnjg(&z__2, &v1); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t1.r = z__1.r, t1.i = z__1.i; + d_cnjg(&z__1, &v[2]); + v2.r = z__1.r, v2.i = z__1.i; + d_cnjg(&z__2, &v2); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t2.r = z__1.r, t2.i = z__1.i; + d_cnjg(&z__1, &v[3]); + v3.r = z__1.r, v3.i = z__1.i; + d_cnjg(&z__2, &v3); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t3.r = z__1.r, t3.i = z__1.i; + d_cnjg(&z__1, &v[4]); + v4.r = z__1.r, v4.i = z__1.i; + d_cnjg(&z__2, &v4); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t4.r = z__1.r, t4.i = z__1.i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j * c_dim1 + 1; + z__4.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__4.i = v1.r * + c__[i__2].i + v1.i * c__[i__2].r; + i__3 = j * c_dim1 + 2; + z__5.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__5.i = v2.r * + c__[i__3].i + v2.i * c__[i__3].r; + z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i; + i__4 = j * c_dim1 + 3; + z__6.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__6.i = v3.r * + c__[i__4].i + v3.i * c__[i__4].r; + z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i; + i__5 = j * c_dim1 + 4; + z__7.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__7.i = v4.r * + c__[i__5].i + v4.i * c__[i__5].r; + z__1.r = z__2.r + z__7.r, z__1.i = z__2.i + z__7.i; + sum.r = z__1.r, sum.i = z__1.i; + i__2 = j * c_dim1 + 1; + i__3 = j * c_dim1 + 1; + z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + + sum.i * t1.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 2; + i__3 = j * c_dim1 + 2; + z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + + sum.i * t2.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 3; + i__3 = j * c_dim1 + 3; + z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + + sum.i * t3.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 4; + i__3 = j * c_dim1 + 4; + z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + + sum.i * t4.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; +/* L80: */ + } + goto L410; +L90: + +/* Special code for 5 x 5 Householder */ + + d_cnjg(&z__1, &v[1]); + v1.r = z__1.r, v1.i = z__1.i; + d_cnjg(&z__2, &v1); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t1.r = z__1.r, t1.i = z__1.i; + d_cnjg(&z__1, &v[2]); + v2.r = z__1.r, v2.i = z__1.i; + d_cnjg(&z__2, &v2); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t2.r = z__1.r, t2.i = z__1.i; + d_cnjg(&z__1, &v[3]); + v3.r = z__1.r, v3.i = z__1.i; + d_cnjg(&z__2, &v3); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t3.r = z__1.r, t3.i = z__1.i; + d_cnjg(&z__1, &v[4]); + v4.r = z__1.r, v4.i = z__1.i; + d_cnjg(&z__2, &v4); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t4.r = z__1.r, t4.i = z__1.i; + d_cnjg(&z__1, &v[5]); + v5.r = z__1.r, v5.i = z__1.i; + d_cnjg(&z__2, &v5); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t5.r = z__1.r, t5.i = z__1.i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j * c_dim1 + 1; + z__5.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__5.i = v1.r * + c__[i__2].i + v1.i * c__[i__2].r; + i__3 = j * c_dim1 + 2; + z__6.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__6.i = v2.r * + c__[i__3].i + v2.i * c__[i__3].r; + z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i; + i__4 = j * c_dim1 + 3; + z__7.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__7.i = v3.r * + c__[i__4].i + v3.i * c__[i__4].r; + z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i; + i__5 = j * c_dim1 + 4; + z__8.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__8.i = v4.r * + c__[i__5].i + v4.i * c__[i__5].r; + z__2.r = z__3.r + z__8.r, z__2.i = z__3.i + z__8.i; + i__6 = j * c_dim1 + 5; + z__9.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__9.i = v5.r * + c__[i__6].i + v5.i * c__[i__6].r; + z__1.r = z__2.r + z__9.r, z__1.i = z__2.i + z__9.i; + sum.r = z__1.r, sum.i = z__1.i; + i__2 = j * c_dim1 + 1; + i__3 = j * c_dim1 + 1; + z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + + sum.i * t1.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 2; + i__3 = j * c_dim1 + 2; + z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + + sum.i * t2.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 3; + i__3 = j * c_dim1 + 3; + z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + + sum.i * t3.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 4; + i__3 = j * c_dim1 + 4; + z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + + sum.i * t4.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 5; + i__3 = j * c_dim1 + 5; + z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + + sum.i * t5.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; +/* L100: */ + } + goto L410; +L110: + +/* Special code for 6 x 6 Householder */ + + d_cnjg(&z__1, &v[1]); + v1.r = z__1.r, v1.i = z__1.i; + d_cnjg(&z__2, &v1); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t1.r = z__1.r, t1.i = z__1.i; + d_cnjg(&z__1, &v[2]); + v2.r = z__1.r, v2.i = z__1.i; + d_cnjg(&z__2, &v2); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t2.r = z__1.r, t2.i = z__1.i; + d_cnjg(&z__1, &v[3]); + v3.r = z__1.r, v3.i = z__1.i; + d_cnjg(&z__2, &v3); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t3.r = z__1.r, t3.i = z__1.i; + d_cnjg(&z__1, &v[4]); + v4.r = z__1.r, v4.i = z__1.i; + d_cnjg(&z__2, &v4); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t4.r = z__1.r, t4.i = z__1.i; + d_cnjg(&z__1, &v[5]); + v5.r = z__1.r, v5.i = z__1.i; + d_cnjg(&z__2, &v5); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t5.r = z__1.r, t5.i = z__1.i; + d_cnjg(&z__1, &v[6]); + v6.r = z__1.r, v6.i = z__1.i; + d_cnjg(&z__2, &v6); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t6.r = z__1.r, t6.i = z__1.i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j * c_dim1 + 1; + z__6.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__6.i = v1.r * + c__[i__2].i + v1.i * c__[i__2].r; + i__3 = j * c_dim1 + 2; + z__7.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__7.i = v2.r * + c__[i__3].i + v2.i * c__[i__3].r; + z__5.r = z__6.r + z__7.r, z__5.i = z__6.i + z__7.i; + i__4 = j * c_dim1 + 3; + z__8.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__8.i = v3.r * + c__[i__4].i + v3.i * c__[i__4].r; + z__4.r = z__5.r + z__8.r, z__4.i = z__5.i + z__8.i; + i__5 = j * c_dim1 + 4; + z__9.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__9.i = v4.r * + c__[i__5].i + v4.i * c__[i__5].r; + z__3.r = z__4.r + z__9.r, z__3.i = z__4.i + z__9.i; + i__6 = j * c_dim1 + 5; + z__10.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__10.i = v5.r + * c__[i__6].i + v5.i * c__[i__6].r; + z__2.r = z__3.r + z__10.r, z__2.i = z__3.i + z__10.i; + i__7 = j * c_dim1 + 6; + z__11.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__11.i = v6.r + * c__[i__7].i + v6.i * c__[i__7].r; + z__1.r = z__2.r + z__11.r, z__1.i = z__2.i + z__11.i; + sum.r = z__1.r, sum.i = z__1.i; + i__2 = j * c_dim1 + 1; + i__3 = j * c_dim1 + 1; + z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + + sum.i * t1.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 2; + i__3 = j * c_dim1 + 2; + z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + + sum.i * t2.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 3; + i__3 = j * c_dim1 + 3; + z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + + sum.i * t3.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 4; + i__3 = j * c_dim1 + 4; + z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + + sum.i * t4.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 5; + i__3 = j * c_dim1 + 5; + z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + + sum.i * t5.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 6; + i__3 = j * c_dim1 + 6; + z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i + + sum.i * t6.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; +/* L120: */ + } + goto L410; +L130: + +/* Special code for 7 x 7 Householder */ + + d_cnjg(&z__1, &v[1]); + v1.r = z__1.r, v1.i = z__1.i; + d_cnjg(&z__2, &v1); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t1.r = z__1.r, t1.i = z__1.i; + d_cnjg(&z__1, &v[2]); + v2.r = z__1.r, v2.i = z__1.i; + d_cnjg(&z__2, &v2); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t2.r = z__1.r, t2.i = z__1.i; + d_cnjg(&z__1, &v[3]); + v3.r = z__1.r, v3.i = z__1.i; + d_cnjg(&z__2, &v3); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t3.r = z__1.r, t3.i = z__1.i; + d_cnjg(&z__1, &v[4]); + v4.r = z__1.r, v4.i = z__1.i; + d_cnjg(&z__2, &v4); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t4.r = z__1.r, t4.i = z__1.i; + d_cnjg(&z__1, &v[5]); + v5.r = z__1.r, v5.i = z__1.i; + d_cnjg(&z__2, &v5); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t5.r = z__1.r, t5.i = z__1.i; + d_cnjg(&z__1, &v[6]); + v6.r = z__1.r, v6.i = z__1.i; + d_cnjg(&z__2, &v6); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t6.r = z__1.r, t6.i = z__1.i; + d_cnjg(&z__1, &v[7]); + v7.r = z__1.r, v7.i = z__1.i; + d_cnjg(&z__2, &v7); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t7.r = z__1.r, t7.i = z__1.i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j * c_dim1 + 1; + z__7.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__7.i = v1.r * + c__[i__2].i + v1.i * c__[i__2].r; + i__3 = j * c_dim1 + 2; + z__8.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__8.i = v2.r * + c__[i__3].i + v2.i * c__[i__3].r; + z__6.r = z__7.r + z__8.r, z__6.i = z__7.i + z__8.i; + i__4 = j * c_dim1 + 3; + z__9.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__9.i = v3.r * + c__[i__4].i + v3.i * c__[i__4].r; + z__5.r = z__6.r + z__9.r, z__5.i = z__6.i + z__9.i; + i__5 = j * c_dim1 + 4; + z__10.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__10.i = v4.r + * c__[i__5].i + v4.i * c__[i__5].r; + z__4.r = z__5.r + z__10.r, z__4.i = z__5.i + z__10.i; + i__6 = j * c_dim1 + 5; + z__11.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__11.i = v5.r + * c__[i__6].i + v5.i * c__[i__6].r; + z__3.r = z__4.r + z__11.r, z__3.i = z__4.i + z__11.i; + i__7 = j * c_dim1 + 6; + z__12.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__12.i = v6.r + * c__[i__7].i + v6.i * c__[i__7].r; + z__2.r = z__3.r + z__12.r, z__2.i = z__3.i + z__12.i; + i__8 = j * c_dim1 + 7; + z__13.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__13.i = v7.r + * c__[i__8].i + v7.i * c__[i__8].r; + z__1.r = z__2.r + z__13.r, z__1.i = z__2.i + z__13.i; + sum.r = z__1.r, sum.i = z__1.i; + i__2 = j * c_dim1 + 1; + i__3 = j * c_dim1 + 1; + z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + + sum.i * t1.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 2; + i__3 = j * c_dim1 + 2; + z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + + sum.i * t2.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 3; + i__3 = j * c_dim1 + 3; + z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + + sum.i * t3.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 4; + i__3 = j * c_dim1 + 4; + z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + + sum.i * t4.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 5; + i__3 = j * c_dim1 + 5; + z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + + sum.i * t5.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 6; + i__3 = j * c_dim1 + 6; + z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i + + sum.i * t6.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 7; + i__3 = j * c_dim1 + 7; + z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i + + sum.i * t7.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; +/* L140: */ + } + goto L410; +L150: + +/* Special code for 8 x 8 Householder */ + + d_cnjg(&z__1, &v[1]); + v1.r = z__1.r, v1.i = z__1.i; + d_cnjg(&z__2, &v1); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t1.r = z__1.r, t1.i = z__1.i; + d_cnjg(&z__1, &v[2]); + v2.r = z__1.r, v2.i = z__1.i; + d_cnjg(&z__2, &v2); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t2.r = z__1.r, t2.i = z__1.i; + d_cnjg(&z__1, &v[3]); + v3.r = z__1.r, v3.i = z__1.i; + d_cnjg(&z__2, &v3); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t3.r = z__1.r, t3.i = z__1.i; + d_cnjg(&z__1, &v[4]); + v4.r = z__1.r, v4.i = z__1.i; + d_cnjg(&z__2, &v4); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t4.r = z__1.r, t4.i = z__1.i; + d_cnjg(&z__1, &v[5]); + v5.r = z__1.r, v5.i = z__1.i; + d_cnjg(&z__2, &v5); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t5.r = z__1.r, t5.i = z__1.i; + d_cnjg(&z__1, &v[6]); + v6.r = z__1.r, v6.i = z__1.i; + d_cnjg(&z__2, &v6); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t6.r = z__1.r, t6.i = z__1.i; + d_cnjg(&z__1, &v[7]); + v7.r = z__1.r, v7.i = z__1.i; + d_cnjg(&z__2, &v7); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t7.r = z__1.r, t7.i = z__1.i; + d_cnjg(&z__1, &v[8]); + v8.r = z__1.r, v8.i = z__1.i; + d_cnjg(&z__2, &v8); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t8.r = z__1.r, t8.i = z__1.i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j * c_dim1 + 1; + z__8.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__8.i = v1.r * + c__[i__2].i + v1.i * c__[i__2].r; + i__3 = j * c_dim1 + 2; + z__9.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__9.i = v2.r * + c__[i__3].i + v2.i * c__[i__3].r; + z__7.r = z__8.r + z__9.r, z__7.i = z__8.i + z__9.i; + i__4 = j * c_dim1 + 3; + z__10.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__10.i = v3.r + * c__[i__4].i + v3.i * c__[i__4].r; + z__6.r = z__7.r + z__10.r, z__6.i = z__7.i + z__10.i; + i__5 = j * c_dim1 + 4; + z__11.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__11.i = v4.r + * c__[i__5].i + v4.i * c__[i__5].r; + z__5.r = z__6.r + z__11.r, z__5.i = z__6.i + z__11.i; + i__6 = j * c_dim1 + 5; + z__12.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__12.i = v5.r + * c__[i__6].i + v5.i * c__[i__6].r; + z__4.r = z__5.r + z__12.r, z__4.i = z__5.i + z__12.i; + i__7 = j * c_dim1 + 6; + z__13.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__13.i = v6.r + * c__[i__7].i + v6.i * c__[i__7].r; + z__3.r = z__4.r + z__13.r, z__3.i = z__4.i + z__13.i; + i__8 = j * c_dim1 + 7; + z__14.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__14.i = v7.r + * c__[i__8].i + v7.i * c__[i__8].r; + z__2.r = z__3.r + z__14.r, z__2.i = z__3.i + z__14.i; + i__9 = j * c_dim1 + 8; + z__15.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__15.i = v8.r + * c__[i__9].i + v8.i * c__[i__9].r; + z__1.r = z__2.r + z__15.r, z__1.i = z__2.i + z__15.i; + sum.r = z__1.r, sum.i = z__1.i; + i__2 = j * c_dim1 + 1; + i__3 = j * c_dim1 + 1; + z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + + sum.i * t1.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 2; + i__3 = j * c_dim1 + 2; + z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + + sum.i * t2.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 3; + i__3 = j * c_dim1 + 3; + z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + + sum.i * t3.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 4; + i__3 = j * c_dim1 + 4; + z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + + sum.i * t4.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 5; + i__3 = j * c_dim1 + 5; + z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + + sum.i * t5.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 6; + i__3 = j * c_dim1 + 6; + z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i + + sum.i * t6.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 7; + i__3 = j * c_dim1 + 7; + z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i + + sum.i * t7.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 8; + i__3 = j * c_dim1 + 8; + z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i + + sum.i * t8.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; +/* L160: */ + } + goto L410; +L170: + +/* Special code for 9 x 9 Householder */ + + d_cnjg(&z__1, &v[1]); + v1.r = z__1.r, v1.i = z__1.i; + d_cnjg(&z__2, &v1); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t1.r = z__1.r, t1.i = z__1.i; + d_cnjg(&z__1, &v[2]); + v2.r = z__1.r, v2.i = z__1.i; + d_cnjg(&z__2, &v2); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t2.r = z__1.r, t2.i = z__1.i; + d_cnjg(&z__1, &v[3]); + v3.r = z__1.r, v3.i = z__1.i; + d_cnjg(&z__2, &v3); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t3.r = z__1.r, t3.i = z__1.i; + d_cnjg(&z__1, &v[4]); + v4.r = z__1.r, v4.i = z__1.i; + d_cnjg(&z__2, &v4); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t4.r = z__1.r, t4.i = z__1.i; + d_cnjg(&z__1, &v[5]); + v5.r = z__1.r, v5.i = z__1.i; + d_cnjg(&z__2, &v5); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t5.r = z__1.r, t5.i = z__1.i; + d_cnjg(&z__1, &v[6]); + v6.r = z__1.r, v6.i = z__1.i; + d_cnjg(&z__2, &v6); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t6.r = z__1.r, t6.i = z__1.i; + d_cnjg(&z__1, &v[7]); + v7.r = z__1.r, v7.i = z__1.i; + d_cnjg(&z__2, &v7); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t7.r = z__1.r, t7.i = z__1.i; + d_cnjg(&z__1, &v[8]); + v8.r = z__1.r, v8.i = z__1.i; + d_cnjg(&z__2, &v8); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t8.r = z__1.r, t8.i = z__1.i; + d_cnjg(&z__1, &v[9]); + v9.r = z__1.r, v9.i = z__1.i; + d_cnjg(&z__2, &v9); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t9.r = z__1.r, t9.i = z__1.i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j * c_dim1 + 1; + z__9.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__9.i = v1.r * + c__[i__2].i + v1.i * c__[i__2].r; + i__3 = j * c_dim1 + 2; + z__10.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__10.i = v2.r + * c__[i__3].i + v2.i * c__[i__3].r; + z__8.r = z__9.r + z__10.r, z__8.i = z__9.i + z__10.i; + i__4 = j * c_dim1 + 3; + z__11.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__11.i = v3.r + * c__[i__4].i + v3.i * c__[i__4].r; + z__7.r = z__8.r + z__11.r, z__7.i = z__8.i + z__11.i; + i__5 = j * c_dim1 + 4; + z__12.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__12.i = v4.r + * c__[i__5].i + v4.i * c__[i__5].r; + z__6.r = z__7.r + z__12.r, z__6.i = z__7.i + z__12.i; + i__6 = j * c_dim1 + 5; + z__13.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__13.i = v5.r + * c__[i__6].i + v5.i * c__[i__6].r; + z__5.r = z__6.r + z__13.r, z__5.i = z__6.i + z__13.i; + i__7 = j * c_dim1 + 6; + z__14.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__14.i = v6.r + * c__[i__7].i + v6.i * c__[i__7].r; + z__4.r = z__5.r + z__14.r, z__4.i = z__5.i + z__14.i; + i__8 = j * c_dim1 + 7; + z__15.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__15.i = v7.r + * c__[i__8].i + v7.i * c__[i__8].r; + z__3.r = z__4.r + z__15.r, z__3.i = z__4.i + z__15.i; + i__9 = j * c_dim1 + 8; + z__16.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__16.i = v8.r + * c__[i__9].i + v8.i * c__[i__9].r; + z__2.r = z__3.r + z__16.r, z__2.i = z__3.i + z__16.i; + i__10 = j * c_dim1 + 9; + z__17.r = v9.r * c__[i__10].r - v9.i * c__[i__10].i, z__17.i = + v9.r * c__[i__10].i + v9.i * c__[i__10].r; + z__1.r = z__2.r + z__17.r, z__1.i = z__2.i + z__17.i; + sum.r = z__1.r, sum.i = z__1.i; + i__2 = j * c_dim1 + 1; + i__3 = j * c_dim1 + 1; + z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + + sum.i * t1.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 2; + i__3 = j * c_dim1 + 2; + z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + + sum.i * t2.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 3; + i__3 = j * c_dim1 + 3; + z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + + sum.i * t3.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 4; + i__3 = j * c_dim1 + 4; + z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + + sum.i * t4.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 5; + i__3 = j * c_dim1 + 5; + z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + + sum.i * t5.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 6; + i__3 = j * c_dim1 + 6; + z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i + + sum.i * t6.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 7; + i__3 = j * c_dim1 + 7; + z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i + + sum.i * t7.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 8; + i__3 = j * c_dim1 + 8; + z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i + + sum.i * t8.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 9; + i__3 = j * c_dim1 + 9; + z__2.r = sum.r * t9.r - sum.i * t9.i, z__2.i = sum.r * t9.i + + sum.i * t9.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; +/* L180: */ + } + goto L410; +L190: + +/* Special code for 10 x 10 Householder */ + + d_cnjg(&z__1, &v[1]); + v1.r = z__1.r, v1.i = z__1.i; + d_cnjg(&z__2, &v1); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t1.r = z__1.r, t1.i = z__1.i; + d_cnjg(&z__1, &v[2]); + v2.r = z__1.r, v2.i = z__1.i; + d_cnjg(&z__2, &v2); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t2.r = z__1.r, t2.i = z__1.i; + d_cnjg(&z__1, &v[3]); + v3.r = z__1.r, v3.i = z__1.i; + d_cnjg(&z__2, &v3); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t3.r = z__1.r, t3.i = z__1.i; + d_cnjg(&z__1, &v[4]); + v4.r = z__1.r, v4.i = z__1.i; + d_cnjg(&z__2, &v4); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t4.r = z__1.r, t4.i = z__1.i; + d_cnjg(&z__1, &v[5]); + v5.r = z__1.r, v5.i = z__1.i; + d_cnjg(&z__2, &v5); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t5.r = z__1.r, t5.i = z__1.i; + d_cnjg(&z__1, &v[6]); + v6.r = z__1.r, v6.i = z__1.i; + d_cnjg(&z__2, &v6); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t6.r = z__1.r, t6.i = z__1.i; + d_cnjg(&z__1, &v[7]); + v7.r = z__1.r, v7.i = z__1.i; + d_cnjg(&z__2, &v7); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t7.r = z__1.r, t7.i = z__1.i; + d_cnjg(&z__1, &v[8]); + v8.r = z__1.r, v8.i = z__1.i; + d_cnjg(&z__2, &v8); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t8.r = z__1.r, t8.i = z__1.i; + d_cnjg(&z__1, &v[9]); + v9.r = z__1.r, v9.i = z__1.i; + d_cnjg(&z__2, &v9); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t9.r = z__1.r, t9.i = z__1.i; + d_cnjg(&z__1, &v[10]); + v10.r = z__1.r, v10.i = z__1.i; + d_cnjg(&z__2, &v10); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t10.r = z__1.r, t10.i = z__1.i; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j * c_dim1 + 1; + z__10.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__10.i = v1.r + * c__[i__2].i + v1.i * c__[i__2].r; + i__3 = j * c_dim1 + 2; + z__11.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__11.i = v2.r + * c__[i__3].i + v2.i * c__[i__3].r; + z__9.r = z__10.r + z__11.r, z__9.i = z__10.i + z__11.i; + i__4 = j * c_dim1 + 3; + z__12.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__12.i = v3.r + * c__[i__4].i + v3.i * c__[i__4].r; + z__8.r = z__9.r + z__12.r, z__8.i = z__9.i + z__12.i; + i__5 = j * c_dim1 + 4; + z__13.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__13.i = v4.r + * c__[i__5].i + v4.i * c__[i__5].r; + z__7.r = z__8.r + z__13.r, z__7.i = z__8.i + z__13.i; + i__6 = j * c_dim1 + 5; + z__14.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__14.i = v5.r + * c__[i__6].i + v5.i * c__[i__6].r; + z__6.r = z__7.r + z__14.r, z__6.i = z__7.i + z__14.i; + i__7 = j * c_dim1 + 6; + z__15.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__15.i = v6.r + * c__[i__7].i + v6.i * c__[i__7].r; + z__5.r = z__6.r + z__15.r, z__5.i = z__6.i + z__15.i; + i__8 = j * c_dim1 + 7; + z__16.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__16.i = v7.r + * c__[i__8].i + v7.i * c__[i__8].r; + z__4.r = z__5.r + z__16.r, z__4.i = z__5.i + z__16.i; + i__9 = j * c_dim1 + 8; + z__17.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__17.i = v8.r + * c__[i__9].i + v8.i * c__[i__9].r; + z__3.r = z__4.r + z__17.r, z__3.i = z__4.i + z__17.i; + i__10 = j * c_dim1 + 9; + z__18.r = v9.r * c__[i__10].r - v9.i * c__[i__10].i, z__18.i = + v9.r * c__[i__10].i + v9.i * c__[i__10].r; + z__2.r = z__3.r + z__18.r, z__2.i = z__3.i + z__18.i; + i__11 = j * c_dim1 + 10; + z__19.r = v10.r * c__[i__11].r - v10.i * c__[i__11].i, z__19.i = + v10.r * c__[i__11].i + v10.i * c__[i__11].r; + z__1.r = z__2.r + z__19.r, z__1.i = z__2.i + z__19.i; + sum.r = z__1.r, sum.i = z__1.i; + i__2 = j * c_dim1 + 1; + i__3 = j * c_dim1 + 1; + z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + + sum.i * t1.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 2; + i__3 = j * c_dim1 + 2; + z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + + sum.i * t2.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 3; + i__3 = j * c_dim1 + 3; + z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + + sum.i * t3.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 4; + i__3 = j * c_dim1 + 4; + z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + + sum.i * t4.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 5; + i__3 = j * c_dim1 + 5; + z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + + sum.i * t5.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 6; + i__3 = j * c_dim1 + 6; + z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i + + sum.i * t6.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 7; + i__3 = j * c_dim1 + 7; + z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i + + sum.i * t7.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 8; + i__3 = j * c_dim1 + 8; + z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i + + sum.i * t8.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 9; + i__3 = j * c_dim1 + 9; + z__2.r = sum.r * t9.r - sum.i * t9.i, z__2.i = sum.r * t9.i + + sum.i * t9.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j * c_dim1 + 10; + i__3 = j * c_dim1 + 10; + z__2.r = sum.r * t10.r - sum.i * t10.i, z__2.i = sum.r * t10.i + + sum.i * t10.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; +/* L200: */ + } + goto L410; + } else { + +/* Form C * H, where H has order n. */ + + switch (*n) { + case 1: goto L210; + case 2: goto L230; + case 3: goto L250; + case 4: goto L270; + case 5: goto L290; + case 6: goto L310; + case 7: goto L330; + case 8: goto L350; + case 9: goto L370; + case 10: goto L390; + } + +/* Code for general N */ + + zlarf_(side, m, n, &v[1], &c__1, tau, &c__[c_offset], ldc, &work[1]); + goto L410; +L210: + +/* Special code for 1 x 1 Householder */ + + z__3.r = tau->r * v[1].r - tau->i * v[1].i, z__3.i = tau->r * v[1].i + + tau->i * v[1].r; + d_cnjg(&z__4, &v[1]); + z__2.r = z__3.r * z__4.r - z__3.i * z__4.i, z__2.i = z__3.r * z__4.i + + z__3.i * z__4.r; + z__1.r = 1. - z__2.r, z__1.i = 0. - z__2.i; + t1.r = z__1.r, t1.i = z__1.i; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = j + c_dim1; + i__3 = j + c_dim1; + z__1.r = t1.r * c__[i__3].r - t1.i * c__[i__3].i, z__1.i = t1.r * + c__[i__3].i + t1.i * c__[i__3].r; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; +/* L220: */ + } + goto L410; +L230: + +/* Special code for 2 x 2 Householder */ + + v1.r = v[1].r, v1.i = v[1].i; + d_cnjg(&z__2, &v1); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t1.r = z__1.r, t1.i = z__1.i; + v2.r = v[2].r, v2.i = v[2].i; + d_cnjg(&z__2, &v2); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t2.r = z__1.r, t2.i = z__1.i; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = j + c_dim1; + z__2.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__2.i = v1.r * + c__[i__2].i + v1.i * c__[i__2].r; + i__3 = j + (c_dim1 << 1); + z__3.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__3.i = v2.r * + c__[i__3].i + v2.i * c__[i__3].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + sum.r = z__1.r, sum.i = z__1.i; + i__2 = j + c_dim1; + i__3 = j + c_dim1; + z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + + sum.i * t1.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + (c_dim1 << 1); + i__3 = j + (c_dim1 << 1); + z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + + sum.i * t2.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; +/* L240: */ + } + goto L410; +L250: + +/* Special code for 3 x 3 Householder */ + + v1.r = v[1].r, v1.i = v[1].i; + d_cnjg(&z__2, &v1); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t1.r = z__1.r, t1.i = z__1.i; + v2.r = v[2].r, v2.i = v[2].i; + d_cnjg(&z__2, &v2); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t2.r = z__1.r, t2.i = z__1.i; + v3.r = v[3].r, v3.i = v[3].i; + d_cnjg(&z__2, &v3); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t3.r = z__1.r, t3.i = z__1.i; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = j + c_dim1; + z__3.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__3.i = v1.r * + c__[i__2].i + v1.i * c__[i__2].r; + i__3 = j + (c_dim1 << 1); + z__4.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__4.i = v2.r * + c__[i__3].i + v2.i * c__[i__3].r; + z__2.r = z__3.r + z__4.r, z__2.i = z__3.i + z__4.i; + i__4 = j + c_dim1 * 3; + z__5.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__5.i = v3.r * + c__[i__4].i + v3.i * c__[i__4].r; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; + sum.r = z__1.r, sum.i = z__1.i; + i__2 = j + c_dim1; + i__3 = j + c_dim1; + z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + + sum.i * t1.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + (c_dim1 << 1); + i__3 = j + (c_dim1 << 1); + z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + + sum.i * t2.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 3; + i__3 = j + c_dim1 * 3; + z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + + sum.i * t3.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; +/* L260: */ + } + goto L410; +L270: + +/* Special code for 4 x 4 Householder */ + + v1.r = v[1].r, v1.i = v[1].i; + d_cnjg(&z__2, &v1); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t1.r = z__1.r, t1.i = z__1.i; + v2.r = v[2].r, v2.i = v[2].i; + d_cnjg(&z__2, &v2); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t2.r = z__1.r, t2.i = z__1.i; + v3.r = v[3].r, v3.i = v[3].i; + d_cnjg(&z__2, &v3); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t3.r = z__1.r, t3.i = z__1.i; + v4.r = v[4].r, v4.i = v[4].i; + d_cnjg(&z__2, &v4); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t4.r = z__1.r, t4.i = z__1.i; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = j + c_dim1; + z__4.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__4.i = v1.r * + c__[i__2].i + v1.i * c__[i__2].r; + i__3 = j + (c_dim1 << 1); + z__5.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__5.i = v2.r * + c__[i__3].i + v2.i * c__[i__3].r; + z__3.r = z__4.r + z__5.r, z__3.i = z__4.i + z__5.i; + i__4 = j + c_dim1 * 3; + z__6.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__6.i = v3.r * + c__[i__4].i + v3.i * c__[i__4].r; + z__2.r = z__3.r + z__6.r, z__2.i = z__3.i + z__6.i; + i__5 = j + (c_dim1 << 2); + z__7.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__7.i = v4.r * + c__[i__5].i + v4.i * c__[i__5].r; + z__1.r = z__2.r + z__7.r, z__1.i = z__2.i + z__7.i; + sum.r = z__1.r, sum.i = z__1.i; + i__2 = j + c_dim1; + i__3 = j + c_dim1; + z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + + sum.i * t1.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + (c_dim1 << 1); + i__3 = j + (c_dim1 << 1); + z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + + sum.i * t2.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 3; + i__3 = j + c_dim1 * 3; + z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + + sum.i * t3.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + (c_dim1 << 2); + i__3 = j + (c_dim1 << 2); + z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + + sum.i * t4.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; +/* L280: */ + } + goto L410; +L290: + +/* Special code for 5 x 5 Householder */ + + v1.r = v[1].r, v1.i = v[1].i; + d_cnjg(&z__2, &v1); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t1.r = z__1.r, t1.i = z__1.i; + v2.r = v[2].r, v2.i = v[2].i; + d_cnjg(&z__2, &v2); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t2.r = z__1.r, t2.i = z__1.i; + v3.r = v[3].r, v3.i = v[3].i; + d_cnjg(&z__2, &v3); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t3.r = z__1.r, t3.i = z__1.i; + v4.r = v[4].r, v4.i = v[4].i; + d_cnjg(&z__2, &v4); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t4.r = z__1.r, t4.i = z__1.i; + v5.r = v[5].r, v5.i = v[5].i; + d_cnjg(&z__2, &v5); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t5.r = z__1.r, t5.i = z__1.i; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = j + c_dim1; + z__5.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__5.i = v1.r * + c__[i__2].i + v1.i * c__[i__2].r; + i__3 = j + (c_dim1 << 1); + z__6.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__6.i = v2.r * + c__[i__3].i + v2.i * c__[i__3].r; + z__4.r = z__5.r + z__6.r, z__4.i = z__5.i + z__6.i; + i__4 = j + c_dim1 * 3; + z__7.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__7.i = v3.r * + c__[i__4].i + v3.i * c__[i__4].r; + z__3.r = z__4.r + z__7.r, z__3.i = z__4.i + z__7.i; + i__5 = j + (c_dim1 << 2); + z__8.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__8.i = v4.r * + c__[i__5].i + v4.i * c__[i__5].r; + z__2.r = z__3.r + z__8.r, z__2.i = z__3.i + z__8.i; + i__6 = j + c_dim1 * 5; + z__9.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__9.i = v5.r * + c__[i__6].i + v5.i * c__[i__6].r; + z__1.r = z__2.r + z__9.r, z__1.i = z__2.i + z__9.i; + sum.r = z__1.r, sum.i = z__1.i; + i__2 = j + c_dim1; + i__3 = j + c_dim1; + z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + + sum.i * t1.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + (c_dim1 << 1); + i__3 = j + (c_dim1 << 1); + z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + + sum.i * t2.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 3; + i__3 = j + c_dim1 * 3; + z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + + sum.i * t3.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + (c_dim1 << 2); + i__3 = j + (c_dim1 << 2); + z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + + sum.i * t4.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 5; + i__3 = j + c_dim1 * 5; + z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + + sum.i * t5.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; +/* L300: */ + } + goto L410; +L310: + +/* Special code for 6 x 6 Householder */ + + v1.r = v[1].r, v1.i = v[1].i; + d_cnjg(&z__2, &v1); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t1.r = z__1.r, t1.i = z__1.i; + v2.r = v[2].r, v2.i = v[2].i; + d_cnjg(&z__2, &v2); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t2.r = z__1.r, t2.i = z__1.i; + v3.r = v[3].r, v3.i = v[3].i; + d_cnjg(&z__2, &v3); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t3.r = z__1.r, t3.i = z__1.i; + v4.r = v[4].r, v4.i = v[4].i; + d_cnjg(&z__2, &v4); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t4.r = z__1.r, t4.i = z__1.i; + v5.r = v[5].r, v5.i = v[5].i; + d_cnjg(&z__2, &v5); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t5.r = z__1.r, t5.i = z__1.i; + v6.r = v[6].r, v6.i = v[6].i; + d_cnjg(&z__2, &v6); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t6.r = z__1.r, t6.i = z__1.i; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = j + c_dim1; + z__6.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__6.i = v1.r * + c__[i__2].i + v1.i * c__[i__2].r; + i__3 = j + (c_dim1 << 1); + z__7.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__7.i = v2.r * + c__[i__3].i + v2.i * c__[i__3].r; + z__5.r = z__6.r + z__7.r, z__5.i = z__6.i + z__7.i; + i__4 = j + c_dim1 * 3; + z__8.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__8.i = v3.r * + c__[i__4].i + v3.i * c__[i__4].r; + z__4.r = z__5.r + z__8.r, z__4.i = z__5.i + z__8.i; + i__5 = j + (c_dim1 << 2); + z__9.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__9.i = v4.r * + c__[i__5].i + v4.i * c__[i__5].r; + z__3.r = z__4.r + z__9.r, z__3.i = z__4.i + z__9.i; + i__6 = j + c_dim1 * 5; + z__10.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__10.i = v5.r + * c__[i__6].i + v5.i * c__[i__6].r; + z__2.r = z__3.r + z__10.r, z__2.i = z__3.i + z__10.i; + i__7 = j + c_dim1 * 6; + z__11.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__11.i = v6.r + * c__[i__7].i + v6.i * c__[i__7].r; + z__1.r = z__2.r + z__11.r, z__1.i = z__2.i + z__11.i; + sum.r = z__1.r, sum.i = z__1.i; + i__2 = j + c_dim1; + i__3 = j + c_dim1; + z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + + sum.i * t1.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + (c_dim1 << 1); + i__3 = j + (c_dim1 << 1); + z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + + sum.i * t2.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 3; + i__3 = j + c_dim1 * 3; + z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + + sum.i * t3.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + (c_dim1 << 2); + i__3 = j + (c_dim1 << 2); + z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + + sum.i * t4.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 5; + i__3 = j + c_dim1 * 5; + z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + + sum.i * t5.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 6; + i__3 = j + c_dim1 * 6; + z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i + + sum.i * t6.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; +/* L320: */ + } + goto L410; +L330: + +/* Special code for 7 x 7 Householder */ + + v1.r = v[1].r, v1.i = v[1].i; + d_cnjg(&z__2, &v1); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t1.r = z__1.r, t1.i = z__1.i; + v2.r = v[2].r, v2.i = v[2].i; + d_cnjg(&z__2, &v2); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t2.r = z__1.r, t2.i = z__1.i; + v3.r = v[3].r, v3.i = v[3].i; + d_cnjg(&z__2, &v3); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t3.r = z__1.r, t3.i = z__1.i; + v4.r = v[4].r, v4.i = v[4].i; + d_cnjg(&z__2, &v4); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t4.r = z__1.r, t4.i = z__1.i; + v5.r = v[5].r, v5.i = v[5].i; + d_cnjg(&z__2, &v5); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t5.r = z__1.r, t5.i = z__1.i; + v6.r = v[6].r, v6.i = v[6].i; + d_cnjg(&z__2, &v6); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t6.r = z__1.r, t6.i = z__1.i; + v7.r = v[7].r, v7.i = v[7].i; + d_cnjg(&z__2, &v7); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t7.r = z__1.r, t7.i = z__1.i; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = j + c_dim1; + z__7.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__7.i = v1.r * + c__[i__2].i + v1.i * c__[i__2].r; + i__3 = j + (c_dim1 << 1); + z__8.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__8.i = v2.r * + c__[i__3].i + v2.i * c__[i__3].r; + z__6.r = z__7.r + z__8.r, z__6.i = z__7.i + z__8.i; + i__4 = j + c_dim1 * 3; + z__9.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__9.i = v3.r * + c__[i__4].i + v3.i * c__[i__4].r; + z__5.r = z__6.r + z__9.r, z__5.i = z__6.i + z__9.i; + i__5 = j + (c_dim1 << 2); + z__10.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__10.i = v4.r + * c__[i__5].i + v4.i * c__[i__5].r; + z__4.r = z__5.r + z__10.r, z__4.i = z__5.i + z__10.i; + i__6 = j + c_dim1 * 5; + z__11.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__11.i = v5.r + * c__[i__6].i + v5.i * c__[i__6].r; + z__3.r = z__4.r + z__11.r, z__3.i = z__4.i + z__11.i; + i__7 = j + c_dim1 * 6; + z__12.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__12.i = v6.r + * c__[i__7].i + v6.i * c__[i__7].r; + z__2.r = z__3.r + z__12.r, z__2.i = z__3.i + z__12.i; + i__8 = j + c_dim1 * 7; + z__13.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__13.i = v7.r + * c__[i__8].i + v7.i * c__[i__8].r; + z__1.r = z__2.r + z__13.r, z__1.i = z__2.i + z__13.i; + sum.r = z__1.r, sum.i = z__1.i; + i__2 = j + c_dim1; + i__3 = j + c_dim1; + z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + + sum.i * t1.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + (c_dim1 << 1); + i__3 = j + (c_dim1 << 1); + z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + + sum.i * t2.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 3; + i__3 = j + c_dim1 * 3; + z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + + sum.i * t3.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + (c_dim1 << 2); + i__3 = j + (c_dim1 << 2); + z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + + sum.i * t4.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 5; + i__3 = j + c_dim1 * 5; + z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + + sum.i * t5.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 6; + i__3 = j + c_dim1 * 6; + z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i + + sum.i * t6.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 7; + i__3 = j + c_dim1 * 7; + z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i + + sum.i * t7.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; +/* L340: */ + } + goto L410; +L350: + +/* Special code for 8 x 8 Householder */ + + v1.r = v[1].r, v1.i = v[1].i; + d_cnjg(&z__2, &v1); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t1.r = z__1.r, t1.i = z__1.i; + v2.r = v[2].r, v2.i = v[2].i; + d_cnjg(&z__2, &v2); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t2.r = z__1.r, t2.i = z__1.i; + v3.r = v[3].r, v3.i = v[3].i; + d_cnjg(&z__2, &v3); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t3.r = z__1.r, t3.i = z__1.i; + v4.r = v[4].r, v4.i = v[4].i; + d_cnjg(&z__2, &v4); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t4.r = z__1.r, t4.i = z__1.i; + v5.r = v[5].r, v5.i = v[5].i; + d_cnjg(&z__2, &v5); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t5.r = z__1.r, t5.i = z__1.i; + v6.r = v[6].r, v6.i = v[6].i; + d_cnjg(&z__2, &v6); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t6.r = z__1.r, t6.i = z__1.i; + v7.r = v[7].r, v7.i = v[7].i; + d_cnjg(&z__2, &v7); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t7.r = z__1.r, t7.i = z__1.i; + v8.r = v[8].r, v8.i = v[8].i; + d_cnjg(&z__2, &v8); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t8.r = z__1.r, t8.i = z__1.i; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = j + c_dim1; + z__8.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__8.i = v1.r * + c__[i__2].i + v1.i * c__[i__2].r; + i__3 = j + (c_dim1 << 1); + z__9.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__9.i = v2.r * + c__[i__3].i + v2.i * c__[i__3].r; + z__7.r = z__8.r + z__9.r, z__7.i = z__8.i + z__9.i; + i__4 = j + c_dim1 * 3; + z__10.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__10.i = v3.r + * c__[i__4].i + v3.i * c__[i__4].r; + z__6.r = z__7.r + z__10.r, z__6.i = z__7.i + z__10.i; + i__5 = j + (c_dim1 << 2); + z__11.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__11.i = v4.r + * c__[i__5].i + v4.i * c__[i__5].r; + z__5.r = z__6.r + z__11.r, z__5.i = z__6.i + z__11.i; + i__6 = j + c_dim1 * 5; + z__12.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__12.i = v5.r + * c__[i__6].i + v5.i * c__[i__6].r; + z__4.r = z__5.r + z__12.r, z__4.i = z__5.i + z__12.i; + i__7 = j + c_dim1 * 6; + z__13.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__13.i = v6.r + * c__[i__7].i + v6.i * c__[i__7].r; + z__3.r = z__4.r + z__13.r, z__3.i = z__4.i + z__13.i; + i__8 = j + c_dim1 * 7; + z__14.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__14.i = v7.r + * c__[i__8].i + v7.i * c__[i__8].r; + z__2.r = z__3.r + z__14.r, z__2.i = z__3.i + z__14.i; + i__9 = j + (c_dim1 << 3); + z__15.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__15.i = v8.r + * c__[i__9].i + v8.i * c__[i__9].r; + z__1.r = z__2.r + z__15.r, z__1.i = z__2.i + z__15.i; + sum.r = z__1.r, sum.i = z__1.i; + i__2 = j + c_dim1; + i__3 = j + c_dim1; + z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + + sum.i * t1.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + (c_dim1 << 1); + i__3 = j + (c_dim1 << 1); + z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + + sum.i * t2.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 3; + i__3 = j + c_dim1 * 3; + z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + + sum.i * t3.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + (c_dim1 << 2); + i__3 = j + (c_dim1 << 2); + z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + + sum.i * t4.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 5; + i__3 = j + c_dim1 * 5; + z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + + sum.i * t5.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 6; + i__3 = j + c_dim1 * 6; + z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i + + sum.i * t6.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 7; + i__3 = j + c_dim1 * 7; + z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i + + sum.i * t7.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + (c_dim1 << 3); + i__3 = j + (c_dim1 << 3); + z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i + + sum.i * t8.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; +/* L360: */ + } + goto L410; +L370: + +/* Special code for 9 x 9 Householder */ + + v1.r = v[1].r, v1.i = v[1].i; + d_cnjg(&z__2, &v1); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t1.r = z__1.r, t1.i = z__1.i; + v2.r = v[2].r, v2.i = v[2].i; + d_cnjg(&z__2, &v2); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t2.r = z__1.r, t2.i = z__1.i; + v3.r = v[3].r, v3.i = v[3].i; + d_cnjg(&z__2, &v3); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t3.r = z__1.r, t3.i = z__1.i; + v4.r = v[4].r, v4.i = v[4].i; + d_cnjg(&z__2, &v4); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t4.r = z__1.r, t4.i = z__1.i; + v5.r = v[5].r, v5.i = v[5].i; + d_cnjg(&z__2, &v5); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t5.r = z__1.r, t5.i = z__1.i; + v6.r = v[6].r, v6.i = v[6].i; + d_cnjg(&z__2, &v6); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t6.r = z__1.r, t6.i = z__1.i; + v7.r = v[7].r, v7.i = v[7].i; + d_cnjg(&z__2, &v7); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t7.r = z__1.r, t7.i = z__1.i; + v8.r = v[8].r, v8.i = v[8].i; + d_cnjg(&z__2, &v8); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t8.r = z__1.r, t8.i = z__1.i; + v9.r = v[9].r, v9.i = v[9].i; + d_cnjg(&z__2, &v9); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t9.r = z__1.r, t9.i = z__1.i; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = j + c_dim1; + z__9.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__9.i = v1.r * + c__[i__2].i + v1.i * c__[i__2].r; + i__3 = j + (c_dim1 << 1); + z__10.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__10.i = v2.r + * c__[i__3].i + v2.i * c__[i__3].r; + z__8.r = z__9.r + z__10.r, z__8.i = z__9.i + z__10.i; + i__4 = j + c_dim1 * 3; + z__11.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__11.i = v3.r + * c__[i__4].i + v3.i * c__[i__4].r; + z__7.r = z__8.r + z__11.r, z__7.i = z__8.i + z__11.i; + i__5 = j + (c_dim1 << 2); + z__12.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__12.i = v4.r + * c__[i__5].i + v4.i * c__[i__5].r; + z__6.r = z__7.r + z__12.r, z__6.i = z__7.i + z__12.i; + i__6 = j + c_dim1 * 5; + z__13.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__13.i = v5.r + * c__[i__6].i + v5.i * c__[i__6].r; + z__5.r = z__6.r + z__13.r, z__5.i = z__6.i + z__13.i; + i__7 = j + c_dim1 * 6; + z__14.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__14.i = v6.r + * c__[i__7].i + v6.i * c__[i__7].r; + z__4.r = z__5.r + z__14.r, z__4.i = z__5.i + z__14.i; + i__8 = j + c_dim1 * 7; + z__15.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__15.i = v7.r + * c__[i__8].i + v7.i * c__[i__8].r; + z__3.r = z__4.r + z__15.r, z__3.i = z__4.i + z__15.i; + i__9 = j + (c_dim1 << 3); + z__16.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__16.i = v8.r + * c__[i__9].i + v8.i * c__[i__9].r; + z__2.r = z__3.r + z__16.r, z__2.i = z__3.i + z__16.i; + i__10 = j + c_dim1 * 9; + z__17.r = v9.r * c__[i__10].r - v9.i * c__[i__10].i, z__17.i = + v9.r * c__[i__10].i + v9.i * c__[i__10].r; + z__1.r = z__2.r + z__17.r, z__1.i = z__2.i + z__17.i; + sum.r = z__1.r, sum.i = z__1.i; + i__2 = j + c_dim1; + i__3 = j + c_dim1; + z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + + sum.i * t1.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + (c_dim1 << 1); + i__3 = j + (c_dim1 << 1); + z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + + sum.i * t2.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 3; + i__3 = j + c_dim1 * 3; + z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + + sum.i * t3.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + (c_dim1 << 2); + i__3 = j + (c_dim1 << 2); + z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + + sum.i * t4.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 5; + i__3 = j + c_dim1 * 5; + z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + + sum.i * t5.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 6; + i__3 = j + c_dim1 * 6; + z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i + + sum.i * t6.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 7; + i__3 = j + c_dim1 * 7; + z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i + + sum.i * t7.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + (c_dim1 << 3); + i__3 = j + (c_dim1 << 3); + z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i + + sum.i * t8.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 9; + i__3 = j + c_dim1 * 9; + z__2.r = sum.r * t9.r - sum.i * t9.i, z__2.i = sum.r * t9.i + + sum.i * t9.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; +/* L380: */ + } + goto L410; +L390: + +/* Special code for 10 x 10 Householder */ + + v1.r = v[1].r, v1.i = v[1].i; + d_cnjg(&z__2, &v1); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t1.r = z__1.r, t1.i = z__1.i; + v2.r = v[2].r, v2.i = v[2].i; + d_cnjg(&z__2, &v2); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t2.r = z__1.r, t2.i = z__1.i; + v3.r = v[3].r, v3.i = v[3].i; + d_cnjg(&z__2, &v3); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t3.r = z__1.r, t3.i = z__1.i; + v4.r = v[4].r, v4.i = v[4].i; + d_cnjg(&z__2, &v4); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t4.r = z__1.r, t4.i = z__1.i; + v5.r = v[5].r, v5.i = v[5].i; + d_cnjg(&z__2, &v5); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t5.r = z__1.r, t5.i = z__1.i; + v6.r = v[6].r, v6.i = v[6].i; + d_cnjg(&z__2, &v6); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t6.r = z__1.r, t6.i = z__1.i; + v7.r = v[7].r, v7.i = v[7].i; + d_cnjg(&z__2, &v7); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t7.r = z__1.r, t7.i = z__1.i; + v8.r = v[8].r, v8.i = v[8].i; + d_cnjg(&z__2, &v8); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t8.r = z__1.r, t8.i = z__1.i; + v9.r = v[9].r, v9.i = v[9].i; + d_cnjg(&z__2, &v9); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t9.r = z__1.r, t9.i = z__1.i; + v10.r = v[10].r, v10.i = v[10].i; + d_cnjg(&z__2, &v10); + z__1.r = tau->r * z__2.r - tau->i * z__2.i, z__1.i = tau->r * z__2.i + + tau->i * z__2.r; + t10.r = z__1.r, t10.i = z__1.i; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + i__2 = j + c_dim1; + z__10.r = v1.r * c__[i__2].r - v1.i * c__[i__2].i, z__10.i = v1.r + * c__[i__2].i + v1.i * c__[i__2].r; + i__3 = j + (c_dim1 << 1); + z__11.r = v2.r * c__[i__3].r - v2.i * c__[i__3].i, z__11.i = v2.r + * c__[i__3].i + v2.i * c__[i__3].r; + z__9.r = z__10.r + z__11.r, z__9.i = z__10.i + z__11.i; + i__4 = j + c_dim1 * 3; + z__12.r = v3.r * c__[i__4].r - v3.i * c__[i__4].i, z__12.i = v3.r + * c__[i__4].i + v3.i * c__[i__4].r; + z__8.r = z__9.r + z__12.r, z__8.i = z__9.i + z__12.i; + i__5 = j + (c_dim1 << 2); + z__13.r = v4.r * c__[i__5].r - v4.i * c__[i__5].i, z__13.i = v4.r + * c__[i__5].i + v4.i * c__[i__5].r; + z__7.r = z__8.r + z__13.r, z__7.i = z__8.i + z__13.i; + i__6 = j + c_dim1 * 5; + z__14.r = v5.r * c__[i__6].r - v5.i * c__[i__6].i, z__14.i = v5.r + * c__[i__6].i + v5.i * c__[i__6].r; + z__6.r = z__7.r + z__14.r, z__6.i = z__7.i + z__14.i; + i__7 = j + c_dim1 * 6; + z__15.r = v6.r * c__[i__7].r - v6.i * c__[i__7].i, z__15.i = v6.r + * c__[i__7].i + v6.i * c__[i__7].r; + z__5.r = z__6.r + z__15.r, z__5.i = z__6.i + z__15.i; + i__8 = j + c_dim1 * 7; + z__16.r = v7.r * c__[i__8].r - v7.i * c__[i__8].i, z__16.i = v7.r + * c__[i__8].i + v7.i * c__[i__8].r; + z__4.r = z__5.r + z__16.r, z__4.i = z__5.i + z__16.i; + i__9 = j + (c_dim1 << 3); + z__17.r = v8.r * c__[i__9].r - v8.i * c__[i__9].i, z__17.i = v8.r + * c__[i__9].i + v8.i * c__[i__9].r; + z__3.r = z__4.r + z__17.r, z__3.i = z__4.i + z__17.i; + i__10 = j + c_dim1 * 9; + z__18.r = v9.r * c__[i__10].r - v9.i * c__[i__10].i, z__18.i = + v9.r * c__[i__10].i + v9.i * c__[i__10].r; + z__2.r = z__3.r + z__18.r, z__2.i = z__3.i + z__18.i; + i__11 = j + c_dim1 * 10; + z__19.r = v10.r * c__[i__11].r - v10.i * c__[i__11].i, z__19.i = + v10.r * c__[i__11].i + v10.i * c__[i__11].r; + z__1.r = z__2.r + z__19.r, z__1.i = z__2.i + z__19.i; + sum.r = z__1.r, sum.i = z__1.i; + i__2 = j + c_dim1; + i__3 = j + c_dim1; + z__2.r = sum.r * t1.r - sum.i * t1.i, z__2.i = sum.r * t1.i + + sum.i * t1.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + (c_dim1 << 1); + i__3 = j + (c_dim1 << 1); + z__2.r = sum.r * t2.r - sum.i * t2.i, z__2.i = sum.r * t2.i + + sum.i * t2.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 3; + i__3 = j + c_dim1 * 3; + z__2.r = sum.r * t3.r - sum.i * t3.i, z__2.i = sum.r * t3.i + + sum.i * t3.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + (c_dim1 << 2); + i__3 = j + (c_dim1 << 2); + z__2.r = sum.r * t4.r - sum.i * t4.i, z__2.i = sum.r * t4.i + + sum.i * t4.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 5; + i__3 = j + c_dim1 * 5; + z__2.r = sum.r * t5.r - sum.i * t5.i, z__2.i = sum.r * t5.i + + sum.i * t5.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 6; + i__3 = j + c_dim1 * 6; + z__2.r = sum.r * t6.r - sum.i * t6.i, z__2.i = sum.r * t6.i + + sum.i * t6.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 7; + i__3 = j + c_dim1 * 7; + z__2.r = sum.r * t7.r - sum.i * t7.i, z__2.i = sum.r * t7.i + + sum.i * t7.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + (c_dim1 << 3); + i__3 = j + (c_dim1 << 3); + z__2.r = sum.r * t8.r - sum.i * t8.i, z__2.i = sum.r * t8.i + + sum.i * t8.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 9; + i__3 = j + c_dim1 * 9; + z__2.r = sum.r * t9.r - sum.i * t9.i, z__2.i = sum.r * t9.i + + sum.i * t9.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; + i__2 = j + c_dim1 * 10; + i__3 = j + c_dim1 * 10; + z__2.r = sum.r * t10.r - sum.i * t10.i, z__2.i = sum.r * t10.i + + sum.i * t10.r; + z__1.r = c__[i__3].r - z__2.r, z__1.i = c__[i__3].i - z__2.i; + c__[i__2].r = z__1.r, c__[i__2].i = z__1.i; +/* L400: */ + } + goto L410; + } +L410: + return 0; + +/* End of ZLARFX */ + +} /* zlarfx_ */ + diff --git a/lapack-netlib/SRC/zlarfy.c b/lapack-netlib/SRC/zlarfy.c new file mode 100644 index 000000000..854729e23 --- /dev/null +++ b/lapack-netlib/SRC/zlarfy.c @@ -0,0 +1,566 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLARFY */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) */ + +/* CHARACTER UPLO */ +/* INTEGER INCV, LDC, N */ +/* COMPLEX*16 TAU */ +/* COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLARFY applies an elementary reflector, or Householder matrix, H, */ +/* > to an n x n Hermitian matrix C, from both the left and the right. */ +/* > */ +/* > H is represented in the form */ +/* > */ +/* > H = I - tau * v * v' */ +/* > */ +/* > where tau is a scalar and v is a vector. */ +/* > */ +/* > If tau is zero, then H is taken to be the unit matrix. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > Hermitian matrix C is stored. */ +/* > = 'U': Upper triangle */ +/* > = 'L': Lower triangle */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of rows and columns of the matrix C. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is COMPLEX*16 array, dimension */ +/* > (1 + (N-1)*abs(INCV)) */ +/* > The vector v as described above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCV */ +/* > \verbatim */ +/* > INCV is INTEGER */ +/* > The increment between successive elements of v. INCV must */ +/* > not be zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 */ +/* > The value tau as described above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX*16 array, dimension (LDC, N) */ +/* > On entry, the matrix C. */ +/* > On exit, C is overwritten by H * C * H'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax( 1, N ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (N) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlarfy_(char *uplo, integer *n, doublecomplex *v, + integer *incv, doublecomplex *tau, doublecomplex *c__, integer *ldc, + doublecomplex *work) +{ + /* System generated locals */ + integer c_dim1, c_offset; + doublecomplex z__1, z__2, z__3, z__4; + + /* Local variables */ + extern /* Subroutine */ int zher2_(char *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + doublecomplex alpha; + extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + extern /* Subroutine */ int zhemv_(char *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, integer *), zaxpy_( + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *); + + +/* -- LAPACK test routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --v; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + if (tau->r == 0. && tau->i == 0.) { + return 0; + } + +/* Form w:= C * v */ + + zhemv_(uplo, n, &c_b1, &c__[c_offset], ldc, &v[1], incv, &c_b2, &work[1], + &c__1); + + z__3.r = -.5, z__3.i = 0.; + z__2.r = z__3.r * tau->r - z__3.i * tau->i, z__2.i = z__3.r * tau->i + + z__3.i * tau->r; + zdotc_(&z__4, n, &work[1], &c__1, &v[1], incv); + z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * z__4.i + + z__2.i * z__4.r; + alpha.r = z__1.r, alpha.i = z__1.i; + zaxpy_(n, &alpha, &v[1], incv, &work[1], &c__1); + +/* C := C - v * w' - w * v' */ + + z__1.r = -tau->r, z__1.i = -tau->i; + zher2_(uplo, n, &z__1, &v[1], incv, &work[1], &c__1, &c__[c_offset], ldc); + + return 0; + +/* End of ZLARFY */ + +} /* zlarfy_ */ + diff --git a/lapack-netlib/SRC/zlargv.c b/lapack-netlib/SRC/zlargv.c new file mode 100644 index 000000000..4075605fa --- /dev/null +++ b/lapack-netlib/SRC/zlargv.c @@ -0,0 +1,754 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLARGV generates a vector of plane rotations with real cosines and complex sines. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLARGV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLARGV( N, X, INCX, Y, INCY, C, INCC ) */ + +/* INTEGER INCC, INCX, INCY, N */ +/* DOUBLE PRECISION C( * ) */ +/* COMPLEX*16 X( * ), Y( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLARGV generates a vector of complex plane rotations with real */ +/* > cosines, determined by elements of the complex vectors x and y. */ +/* > For i = 1,2,...,n */ +/* > */ +/* > ( c(i) s(i) ) ( x(i) ) = ( r(i) ) */ +/* > ( -conjg(s(i)) c(i) ) ( y(i) ) = ( 0 ) */ +/* > */ +/* > where c(i)**2 + ABS(s(i))**2 = 1 */ +/* > */ +/* > The following conventions are used (these are the same as in ZLARTG, */ +/* > but differ from the BLAS1 routine ZROTG): */ +/* > If y(i)=0, then c(i)=1 and s(i)=0. */ +/* > If x(i)=0, then c(i)=0 and s(i) is chosen so that r(i) is real. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of plane rotations to be generated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (1+(N-1)*INCX) */ +/* > On entry, the vector x. */ +/* > On exit, x(i) is overwritten by r(i), for i = 1,...,n. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The increment between elements of X. INCX > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is COMPLEX*16 array, dimension (1+(N-1)*INCY) */ +/* > On entry, the vector y. */ +/* > On exit, the sines of the plane rotations. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCY */ +/* > \verbatim */ +/* > INCY is INTEGER */ +/* > The increment between elements of Y. INCY > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (1+(N-1)*INCC) */ +/* > The cosines of the plane rotations. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCC */ +/* > \verbatim */ +/* > INCC is INTEGER */ +/* > The increment between elements of C. INCC > 0. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > 6-6-96 - Modified with a new algorithm by W. Kahan and J. Demmel */ +/* > */ +/* > This version has a few statements commented out for thread safety */ +/* > (machine parameters are computed on each entry). 10 feb 03, SJH. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlargv_(integer *n, doublecomplex *x, integer *incx, + doublecomplex *y, integer *incy, doublereal *c__, integer *incc) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + doublereal d__; + doublecomplex f, g; + integer i__, j; + doublecomplex r__; + doublereal scale; + integer count; + doublereal f2, g2, safmn2; + extern doublereal dlapy2_(doublereal *, doublereal *); + doublereal safmx2; + integer ic; + doublereal di; + doublecomplex ff; + doublereal cs, dr; + extern doublereal dlamch_(char *); + doublecomplex fs, gs; + integer ix, iy; + doublecomplex sn; + doublereal safmin, f2s, g2s, eps; + + +/* -- 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 */ + + +/* ===================================================================== */ + +/* LOGICAL FIRST */ +/* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 */ +/* DATA FIRST / .TRUE. / */ + +/* IF( FIRST ) THEN */ +/* FIRST = .FALSE. */ + /* Parameter adjustments */ + --c__; + --y; + --x; + + /* Function Body */ + safmin = dlamch_("S"); + eps = dlamch_("E"); + d__1 = dlamch_("B"); + i__1 = (integer) (log(safmin / eps) / log(dlamch_("B")) / 2.); + safmn2 = pow_di(&d__1, &i__1); + safmx2 = 1. / safmn2; +/* END IF */ + ix = 1; + iy = 1; + ic = 1; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ix; + f.r = x[i__2].r, f.i = x[i__2].i; + i__2 = iy; + g.r = y[i__2].r, g.i = y[i__2].i; + +/* Use identical algorithm as in ZLARTG */ + +/* Computing MAX */ +/* Computing MAX */ + d__7 = (d__1 = f.r, abs(d__1)), d__8 = (d__2 = d_imag(&f), abs(d__2)); +/* Computing MAX */ + d__9 = (d__3 = g.r, abs(d__3)), d__10 = (d__4 = d_imag(&g), abs(d__4)) + ; + d__5 = f2cmax(d__7,d__8), d__6 = f2cmax(d__9,d__10); + scale = f2cmax(d__5,d__6); + fs.r = f.r, fs.i = f.i; + gs.r = g.r, gs.i = g.i; + count = 0; + if (scale >= safmx2) { +L10: + ++count; + z__1.r = safmn2 * fs.r, z__1.i = safmn2 * fs.i; + fs.r = z__1.r, fs.i = z__1.i; + z__1.r = safmn2 * gs.r, z__1.i = safmn2 * gs.i; + gs.r = z__1.r, gs.i = z__1.i; + scale *= safmn2; + if (scale >= safmx2 && count < 20) { + goto L10; + } + } else if (scale <= safmn2) { + if (g.r == 0. && g.i == 0.) { + cs = 1.; + sn.r = 0., sn.i = 0.; + r__.r = f.r, r__.i = f.i; + goto L50; + } +L20: + --count; + z__1.r = safmx2 * fs.r, z__1.i = safmx2 * fs.i; + fs.r = z__1.r, fs.i = z__1.i; + z__1.r = safmx2 * gs.r, z__1.i = safmx2 * gs.i; + gs.r = z__1.r, gs.i = z__1.i; + scale *= safmx2; + if (scale <= safmn2) { + goto L20; + } + } +/* Computing 2nd power */ + d__1 = fs.r; +/* Computing 2nd power */ + d__2 = d_imag(&fs); + f2 = d__1 * d__1 + d__2 * d__2; +/* Computing 2nd power */ + d__1 = gs.r; +/* Computing 2nd power */ + d__2 = d_imag(&gs); + g2 = d__1 * d__1 + d__2 * d__2; + if (f2 <= f2cmax(g2,1.) * safmin) { + +/* This is a rare case: F is very small. */ + + if (f.r == 0. && f.i == 0.) { + cs = 0.; + d__2 = g.r; + d__3 = d_imag(&g); + d__1 = dlapy2_(&d__2, &d__3); + r__.r = d__1, r__.i = 0.; +/* Do complex/real division explicitly with two real */ +/* divisions */ + d__1 = gs.r; + d__2 = d_imag(&gs); + d__ = dlapy2_(&d__1, &d__2); + d__1 = gs.r / d__; + d__2 = -d_imag(&gs) / d__; + z__1.r = d__1, z__1.i = d__2; + sn.r = z__1.r, sn.i = z__1.i; + goto L50; + } + d__1 = fs.r; + d__2 = d_imag(&fs); + f2s = dlapy2_(&d__1, &d__2); +/* G2 and G2S are accurate */ +/* G2 is at least SAFMIN, and G2S is at least SAFMN2 */ + g2s = sqrt(g2); +/* Error in CS from underflow in F2S is at most */ +/* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS */ +/* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN, */ +/* and so CS .lt. sqrt(SAFMIN) */ +/* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN */ +/* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS) */ +/* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S */ + cs = f2s / g2s; +/* Make sure abs(FF) = 1 */ +/* Do complex/real division explicitly with 2 real divisions */ +/* Computing MAX */ + d__3 = (d__1 = f.r, abs(d__1)), d__4 = (d__2 = d_imag(&f), abs( + d__2)); + if (f2cmax(d__3,d__4) > 1.) { + d__1 = f.r; + d__2 = d_imag(&f); + d__ = dlapy2_(&d__1, &d__2); + d__1 = f.r / d__; + d__2 = d_imag(&f) / d__; + z__1.r = d__1, z__1.i = d__2; + ff.r = z__1.r, ff.i = z__1.i; + } else { + dr = safmx2 * f.r; + di = safmx2 * d_imag(&f); + d__ = dlapy2_(&dr, &di); + d__1 = dr / d__; + d__2 = di / d__; + z__1.r = d__1, z__1.i = d__2; + ff.r = z__1.r, ff.i = z__1.i; + } + d__1 = gs.r / g2s; + d__2 = -d_imag(&gs) / g2s; + z__2.r = d__1, z__2.i = d__2; + z__1.r = ff.r * z__2.r - ff.i * z__2.i, z__1.i = ff.r * z__2.i + + ff.i * z__2.r; + sn.r = z__1.r, sn.i = z__1.i; + z__2.r = cs * f.r, z__2.i = cs * f.i; + z__3.r = sn.r * g.r - sn.i * g.i, z__3.i = sn.r * g.i + sn.i * + g.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + r__.r = z__1.r, r__.i = z__1.i; + } else { + +/* This is the most common case. */ +/* Neither F2 nor F2/G2 are less than SAFMIN */ +/* F2S cannot overflow, and it is accurate */ + + f2s = sqrt(g2 / f2 + 1.); +/* Do the F2S(real)*FS(complex) multiply with two real */ +/* multiplies */ + d__1 = f2s * fs.r; + d__2 = f2s * d_imag(&fs); + z__1.r = d__1, z__1.i = d__2; + r__.r = z__1.r, r__.i = z__1.i; + cs = 1. / f2s; + d__ = f2 + g2; +/* Do complex/real division explicitly with two real divisions */ + d__1 = r__.r / d__; + d__2 = d_imag(&r__) / d__; + z__1.r = d__1, z__1.i = d__2; + sn.r = z__1.r, sn.i = z__1.i; + d_cnjg(&z__2, &gs); + z__1.r = sn.r * z__2.r - sn.i * z__2.i, z__1.i = sn.r * z__2.i + + sn.i * z__2.r; + sn.r = z__1.r, sn.i = z__1.i; + if (count != 0) { + if (count > 0) { + i__2 = count; + for (j = 1; j <= i__2; ++j) { + z__1.r = safmx2 * r__.r, z__1.i = safmx2 * r__.i; + r__.r = z__1.r, r__.i = z__1.i; +/* L30: */ + } + } else { + i__2 = -count; + for (j = 1; j <= i__2; ++j) { + z__1.r = safmn2 * r__.r, z__1.i = safmn2 * r__.i; + r__.r = z__1.r, r__.i = z__1.i; +/* L40: */ + } + } + } + } +L50: + c__[ic] = cs; + i__2 = iy; + y[i__2].r = sn.r, y[i__2].i = sn.i; + i__2 = ix; + x[i__2].r = r__.r, x[i__2].i = r__.i; + ic += *incc; + iy += *incy; + ix += *incx; +/* L60: */ + } + return 0; + +/* End of ZLARGV */ + +} /* zlargv_ */ + diff --git a/lapack-netlib/SRC/zlarnv.c b/lapack-netlib/SRC/zlarnv.c new file mode 100644 index 000000000..91555a538 --- /dev/null +++ b/lapack-netlib/SRC/zlarnv.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 +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLARNV returns a vector of random numbers from a uniform or normal distribution. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLARNV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLARNV( IDIST, ISEED, N, X ) */ + +/* INTEGER IDIST, N */ +/* INTEGER ISEED( 4 ) */ +/* COMPLEX*16 X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLARNV returns a vector of n random complex numbers from a uniform or */ +/* > normal distribution. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] IDIST */ +/* > \verbatim */ +/* > IDIST is INTEGER */ +/* > Specifies the distribution of the random numbers: */ +/* > = 1: real and imaginary parts each uniform (0,1) */ +/* > = 2: real and imaginary parts each uniform (-1,1) */ +/* > = 3: real and imaginary parts each normal (0,1) */ +/* > = 4: uniformly distributed on the disc abs(z) < 1 */ +/* > = 5: uniformly distributed on the circle abs(z) = 1 */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of random numbers to be generated. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (N) */ +/* > The generated random numbers. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine calls the auxiliary routine DLARUV to generate random */ +/* > real numbers from a uniform (0,1) distribution, in batches of up to */ +/* > 128 using vectorisable code. The Box-Muller method is used to */ +/* > transform numbers from a uniform to a normal distribution. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlarnv_(integer *idist, integer *iseed, integer *n, + doublecomplex *x) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4, i__5; + doublereal d__1, d__2; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + integer i__; + doublereal u[128]; + integer il, iv; + extern /* Subroutine */ int dlaruv_(integer *, integer *, doublereal *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --x; + --iseed; + + /* Function Body */ + i__1 = *n; + for (iv = 1; iv <= i__1; iv += 64) { +/* Computing MIN */ + i__2 = 64, i__3 = *n - iv + 1; + il = f2cmin(i__2,i__3); + +/* Call DLARUV to generate 2*IL real numbers from a uniform (0,1) */ +/* distribution (2*IL <= LV) */ + + i__2 = il << 1; + dlaruv_(&iseed[1], &i__2, u); + + if (*idist == 1) { + +/* Copy generated numbers */ + + i__2 = il; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = iv + i__ - 1; + i__4 = (i__ << 1) - 2; + i__5 = (i__ << 1) - 1; + z__1.r = u[i__4], z__1.i = u[i__5]; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; +/* L10: */ + } + } else if (*idist == 2) { + +/* Convert generated numbers to uniform (-1,1) distribution */ + + i__2 = il; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = iv + i__ - 1; + d__1 = u[(i__ << 1) - 2] * 2. - 1.; + d__2 = u[(i__ << 1) - 1] * 2. - 1.; + z__1.r = d__1, z__1.i = d__2; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; +/* L20: */ + } + } else if (*idist == 3) { + +/* Convert generated numbers to normal (0,1) distribution */ + + i__2 = il; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = iv + i__ - 1; + d__1 = sqrt(log(u[(i__ << 1) - 2]) * -2.); + d__2 = u[(i__ << 1) - 1] * 6.2831853071795864769252867663; + z__3.r = 0., z__3.i = d__2; + z_exp(&z__2, &z__3); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; +/* L30: */ + } + } else if (*idist == 4) { + +/* Convert generated numbers to complex numbers uniformly */ +/* distributed on the unit disk */ + + i__2 = il; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = iv + i__ - 1; + d__1 = sqrt(u[(i__ << 1) - 2]); + d__2 = u[(i__ << 1) - 1] * 6.2831853071795864769252867663; + z__3.r = 0., z__3.i = d__2; + z_exp(&z__2, &z__3); + z__1.r = d__1 * z__2.r, z__1.i = d__1 * z__2.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; +/* L40: */ + } + } else if (*idist == 5) { + +/* Convert generated numbers to complex numbers uniformly */ +/* distributed on the unit circle */ + + i__2 = il; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = iv + i__ - 1; + d__1 = u[(i__ << 1) - 1] * 6.2831853071795864769252867663; + z__2.r = 0., z__2.i = d__1; + z_exp(&z__1, &z__2); + x[i__3].r = z__1.r, x[i__3].i = z__1.i; +/* L50: */ + } + } +/* L60: */ + } + return 0; + +/* End of ZLARNV */ + +} /* zlarnv_ */ + diff --git a/lapack-netlib/SRC/zlarrv.c b/lapack-netlib/SRC/zlarrv.c new file mode 100644 index 000000000..0ce17334a --- /dev/null +++ b/lapack-netlib/SRC/zlarrv.c @@ -0,0 +1,1521 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLARRV computes the eigenvectors of the tridiagonal matrix T = L D LT given L, D and the eigenv +alues of L D LT. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLARRV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLARRV( N, VL, VU, D, L, PIVMIN, */ +/* ISPLIT, M, DOL, DOU, MINRGP, */ +/* RTOL1, RTOL2, W, WERR, WGAP, */ +/* IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, */ +/* WORK, IWORK, INFO ) */ + +/* INTEGER DOL, DOU, INFO, LDZ, M, N */ +/* DOUBLE PRECISION MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU */ +/* INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ), */ +/* $ ISUPPZ( * ), IWORK( * ) */ +/* DOUBLE PRECISION D( * ), GERS( * ), L( * ), W( * ), WERR( * ), */ +/* $ WGAP( * ), WORK( * ) */ +/* COMPLEX*16 Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLARRV computes the eigenvectors of the tridiagonal matrix */ +/* > T = L D L**T given L, D and APPROXIMATIONS to the eigenvalues of L D L**T. */ +/* > The input eigenvalues should have been computed by DLARRE. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VL */ +/* > \verbatim */ +/* > VL is DOUBLE PRECISION */ +/* > Lower bound of the interval that contains the desired */ +/* > eigenvalues. VL < VU. Needed to compute gaps on the left or right */ +/* > end of the extremal eigenvalues in the desired RANGE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VU */ +/* > \verbatim */ +/* > VU is DOUBLE PRECISION */ +/* > Upper bound of the interval that contains the desired */ +/* > eigenvalues. VL < VU. Needed to compute gaps on the left or right */ +/* > end of the extremal eigenvalues in the desired RANGE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, the N diagonal elements of the diagonal matrix D. */ +/* > On exit, D may be overwritten. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] L */ +/* > \verbatim */ +/* > L is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, the (N-1) subdiagonal elements of the unit */ +/* > bidiagonal matrix L are in elements 1 to N-1 of L */ +/* > (if the matrix is not split.) At the end of each block */ +/* > is stored the corresponding shift as given by DLARRE. */ +/* > On exit, L is overwritten. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PIVMIN */ +/* > \verbatim */ +/* > PIVMIN is DOUBLE PRECISION */ +/* > The minimum pivot allowed in the Sturm sequence. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ISPLIT */ +/* > \verbatim */ +/* > ISPLIT is INTEGER array, dimension (N) */ +/* > The splitting points, at which T breaks up into blocks. */ +/* > The first block consists of rows/columns 1 to */ +/* > ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */ +/* > through ISPLIT( 2 ), etc. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The total number of input eigenvalues. 0 <= M <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DOL */ +/* > \verbatim */ +/* > DOL is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DOU */ +/* > \verbatim */ +/* > DOU is INTEGER */ +/* > If the user wants to compute only selected eigenvectors from all */ +/* > the eigenvalues supplied, he can specify an index range DOL:DOU. */ +/* > Or else the setting DOL=1, DOU=M should be applied. */ +/* > Note that DOL and DOU refer to the order in which the eigenvalues */ +/* > are stored in W. */ +/* > If the user wants to compute only selected eigenpairs, then */ +/* > the columns DOL-1 to DOU+1 of the eigenvector space Z contain the */ +/* > computed eigenvectors. All other columns of Z are set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MINRGP */ +/* > \verbatim */ +/* > MINRGP is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RTOL1 */ +/* > \verbatim */ +/* > RTOL1 is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RTOL2 */ +/* > \verbatim */ +/* > RTOL2 is DOUBLE PRECISION */ +/* > Parameters for bisection. */ +/* > An interval [LEFT,RIGHT] has converged if */ +/* > RIGHT-LEFT < MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] W */ +/* > \verbatim */ +/* > W is DOUBLE PRECISION array, dimension (N) */ +/* > The first M elements of W contain the APPROXIMATE 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 DLARRE is expected here ). Furthermore, they are with */ +/* > respect to the shift of the corresponding root representation */ +/* > for their block. On exit, W holds the eigenvalues of the */ +/* > UNshifted matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] WERR */ +/* > \verbatim */ +/* > WERR is DOUBLE PRECISION array, dimension (N) */ +/* > The first M elements contain the semiwidth of the uncertainty */ +/* > interval of the corresponding eigenvalue in W */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] WGAP */ +/* > \verbatim */ +/* > WGAP is DOUBLE PRECISION array, dimension (N) */ +/* > The separation from the right neighbor eigenvalue in W. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IBLOCK */ +/* > \verbatim */ +/* > IBLOCK is INTEGER array, dimension (N) */ +/* > The indices of the blocks (submatrices) associated with the */ +/* > corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue */ +/* > W(i) belongs to the first block from the top, =2 if W(i) */ +/* > belongs to the second block, etc. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INDEXW */ +/* > \verbatim */ +/* > INDEXW is INTEGER array, dimension (N) */ +/* > The indices of the eigenvalues within each block (submatrix); */ +/* > for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the */ +/* > i-th eigenvalue W(i) is the 10-th eigenvalue in the second block. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GERS */ +/* > \verbatim */ +/* > GERS is DOUBLE PRECISION array, dimension (2*N) */ +/* > The N Gerschgorin intervals (the i-th Gerschgorin interval */ +/* > is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should */ +/* > be computed from the original UNshifted matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX*16 array, dimension (LDZ, f2cmax(1,M) ) */ +/* > If INFO = 0, the first M columns of Z contain the */ +/* > orthonormal eigenvectors of the matrix T */ +/* > corresponding to the input eigenvalues, with the i-th */ +/* > column of Z holding the eigenvector associated with W(i). */ +/* > Note: the user must ensure that at least f2cmax(1,M) columns are */ +/* > supplied in the array Z. */ +/* > \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] 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 eigenvector */ +/* > is nonzero only in elements ISUPPZ( 2*I-1 ) through */ +/* > ISUPPZ( 2*I ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (12*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (7*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > */ +/* > > 0: A problem occurred in ZLARRV. */ +/* > < 0: One of the called subroutines signaled an internal problem. */ +/* > Needs inspection of the corresponding parameter IINFO */ +/* > for further information. */ +/* > */ +/* > =-1: Problem in DLARRB when refining a child's eigenvalues. */ +/* > =-2: Problem in DLARRF when computing the RRR of a child. */ +/* > When a child is inside a tight cluster, it can be difficult */ +/* > to find an RRR. A partial remedy from the user's point of */ +/* > view is to make the parameter MINRGP smaller and recompile. */ +/* > However, as the orthogonality of the computed vectors is */ +/* > proportional to 1/MINRGP, the user should be aware that */ +/* > he might be trading in precision when he decreases MINRGP. */ +/* > =-3: Problem in DLARRB when refining a single eigenvalue */ +/* > after the Rayleigh correction was rejected. */ +/* > = 5: The Rayleigh Quotient Iteration failed to converge to */ +/* > full accuracy in MAXITR steps. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Beresford Parlett, University of California, Berkeley, USA \n */ +/* > Jim Demmel, University of California, Berkeley, USA \n */ +/* > Inderjit Dhillon, University of Texas, Austin, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ +/* > Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ +/* Subroutine */ int zlarrv_(integer *n, doublereal *vl, doublereal *vu, + doublereal *d__, doublereal *l, doublereal *pivmin, integer *isplit, + integer *m, integer *dol, integer *dou, doublereal *minrgp, + doublereal *rtol1, doublereal *rtol2, doublereal *w, doublereal *werr, + doublereal *wgap, integer *iblock, integer *indexw, doublereal *gers, + doublecomplex *z__, integer *ldz, integer *isuppz, doublereal *work, + integer *iwork, integer *info) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5, i__6; + doublereal d__1, d__2; + doublecomplex z__1; + logical L__1; + + /* Local variables */ + integer iend, jblk; + doublereal lgap; + integer done; + doublereal rgap, left; + integer wend, iter; + doublereal bstw; + integer minwsize, itmp1, i__, j, k, p, q, indld; + doublereal fudge; + integer idone; + doublereal sigma; + integer iinfo, iindr; + doublereal resid; + logical eskip; + doublereal right; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + integer nclus, zfrom; + doublereal rqtol; + integer iindc1, iindc2, indin1, indin2, miniwsize; + logical stp2ii; + extern /* Subroutine */ int zlar1v_(integer *, integer *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublecomplex *, + logical *, integer *, doublereal *, doublereal *, integer *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *) + ; + doublereal lambda; + integer ii; + doublereal gl; + integer im, in; + extern doublereal dlamch_(char *); + doublereal gu; + integer ibegin, indeig; + logical needbs; + integer indlld; + doublereal sgndef, mingma; + extern /* Subroutine */ int dlarrb_(integer *, doublereal *, doublereal *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, doublereal *, integer *, integer *); + integer oldien, oldncl, wbegin, negcnt; + doublereal spdiam; + integer oldcls; + doublereal savgap; + integer ndepth; + doublereal ssigma; + extern /* Subroutine */ int dlarrf_(integer *, doublereal *, doublereal *, + doublereal *, integer *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *); + logical usedbs; + integer iindwk, offset; + doublereal gaptol; + extern /* Subroutine */ int zdscal_(integer *, doublereal *, + doublecomplex *, integer *); + integer newcls, oldfst, indwrk, windex, oldlst; + logical usedrq; + integer newfst, newftt, parity, windmn, windpl, isupmn, newlst, zusedl; + doublereal bstres; + integer newsiz, zusedu, zusedw; + doublereal nrminv; + logical tryrqc; + integer isupmx; + doublereal rqcorr; + extern /* Subroutine */ int zlaset_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *); + doublereal gap, eps, tau, tol, tmp; + integer zto; + doublereal ztz; + + +/* -- LAPACK auxiliary 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__; + --l; + --isplit; + --w; + --werr; + --wgap; + --iblock; + --indexw; + --gers; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --isuppz; + --work; + --iwork; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n <= 0 || *m <= 0) { + return 0; + } + +/* The first N entries of WORK are reserved for the eigenvalues */ + indld = *n + 1; + indlld = (*n << 1) + 1; + indin1 = *n * 3 + 1; + indin2 = (*n << 2) + 1; + indwrk = *n * 5 + 1; + minwsize = *n * 12; + i__1 = minwsize; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; +/* L5: */ + } +/* IWORK(IINDR+1:IINDR+N) hold the twist indices R for the */ +/* factorization used to compute the FP vector */ + iindr = 0; +/* IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current */ +/* layer and the one above. */ + iindc1 = *n; + iindc2 = *n << 1; + iindwk = *n * 3 + 1; + miniwsize = *n * 7; + i__1 = miniwsize; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = 0; +/* L10: */ + } + zusedl = 1; + if (*dol > 1) { +/* Set lower bound for use of Z */ + zusedl = *dol - 1; + } + zusedu = *m; + if (*dou < *m) { +/* Set lower bound for use of Z */ + zusedu = *dou + 1; + } +/* The width of the part of Z that is used */ + zusedw = zusedu - zusedl + 1; + zlaset_("Full", n, &zusedw, &c_b1, &c_b1, &z__[zusedl * z_dim1 + 1], ldz); + eps = dlamch_("Precision"); + rqtol = eps * 2.; + +/* Set expert flags for standard code. */ + tryrqc = TRUE_; + if (*dol == 1 && *dou == *m) { + } else { +/* Only selected eigenpairs are computed. Since the other evalues */ +/* are not refined by RQ iteration, bisection has to compute to full */ +/* accuracy. */ + *rtol1 = eps * 4.; + *rtol2 = eps * 4.; + } +/* The entries WBEGIN:WEND in W, WERR, WGAP correspond to the */ +/* desired eigenvalues. The support of the nonzero eigenvector */ +/* entries is contained in the interval IBEGIN:IEND. */ +/* Remark that if k eigenpairs are desired, then the eigenvectors */ +/* are stored in k contiguous columns of Z. */ +/* DONE is the number of eigenvectors already computed */ + done = 0; + ibegin = 1; + wbegin = 1; + i__1 = iblock[*m]; + for (jblk = 1; jblk <= i__1; ++jblk) { + iend = isplit[jblk]; + sigma = l[iend]; +/* Find the eigenvectors of the submatrix indexed IBEGIN */ +/* through IEND. */ + wend = wbegin - 1; +L15: + if (wend < *m) { + if (iblock[wend + 1] == jblk) { + ++wend; + goto L15; + } + } + if (wend < wbegin) { + ibegin = iend + 1; + goto L170; + } else if (wend < *dol || wbegin > *dou) { + ibegin = iend + 1; + wbegin = wend + 1; + goto L170; + } +/* Find local spectral diameter of the block */ + gl = gers[(ibegin << 1) - 1]; + gu = gers[ibegin * 2]; + i__2 = iend; + for (i__ = ibegin + 1; i__ <= i__2; ++i__) { +/* Computing MIN */ + d__1 = gers[(i__ << 1) - 1]; + gl = f2cmin(d__1,gl); +/* Computing MAX */ + d__1 = gers[i__ * 2]; + gu = f2cmax(d__1,gu); +/* L20: */ + } + spdiam = gu - gl; +/* OLDIEN is the last index of the previous block */ + oldien = ibegin - 1; +/* Calculate the size of the current block */ + in = iend - ibegin + 1; +/* The number of eigenvalues in the current block */ + im = wend - wbegin + 1; +/* This is for a 1x1 block */ + if (ibegin == iend) { + ++done; + i__2 = ibegin + wbegin * z_dim1; + z__[i__2].r = 1., z__[i__2].i = 0.; + isuppz[(wbegin << 1) - 1] = ibegin; + isuppz[wbegin * 2] = ibegin; + w[wbegin] += sigma; + work[wbegin] = w[wbegin]; + ibegin = iend + 1; + ++wbegin; + goto L170; + } +/* The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND) */ +/* Note that these can be approximations, in this case, the corresp. */ +/* entries of WERR give the size of the uncertainty interval. */ +/* The eigenvalue approximations will be refined when necessary as */ +/* high relative accuracy is required for the computation of the */ +/* corresponding eigenvectors. */ + dcopy_(&im, &w[wbegin], &c__1, &work[wbegin], &c__1); +/* We store in W the eigenvalue approximations w.r.t. the original */ +/* matrix T. */ + i__2 = im; + for (i__ = 1; i__ <= i__2; ++i__) { + w[wbegin + i__ - 1] += sigma; +/* L30: */ + } +/* NDEPTH is the current depth of the representation tree */ + ndepth = 0; +/* PARITY is either 1 or 0 */ + parity = 1; +/* NCLUS is the number of clusters for the next level of the */ +/* representation tree, we start with NCLUS = 1 for the root */ + nclus = 1; + iwork[iindc1 + 1] = 1; + iwork[iindc1 + 2] = im; +/* IDONE is the number of eigenvectors already computed in the current */ +/* block */ + idone = 0; +/* loop while( IDONE.LT.IM ) */ +/* generate the representation tree for the current block and */ +/* compute the eigenvectors */ +L40: + if (idone < im) { +/* This is a crude protection against infinitely deep trees */ + if (ndepth > *m) { + *info = -2; + return 0; + } +/* breadth first processing of the current level of the representation */ +/* tree: OLDNCL = number of clusters on current level */ + oldncl = nclus; +/* reset NCLUS to count the number of child clusters */ + nclus = 0; + + parity = 1 - parity; + if (parity == 0) { + oldcls = iindc1; + newcls = iindc2; + } else { + oldcls = iindc2; + newcls = iindc1; + } +/* Process the clusters on the current level */ + i__2 = oldncl; + for (i__ = 1; i__ <= i__2; ++i__) { + j = oldcls + (i__ << 1); +/* OLDFST, OLDLST = first, last index of current cluster. */ +/* cluster indices start with 1 and are relative */ +/* to WBEGIN when accessing W, WGAP, WERR, Z */ + oldfst = iwork[j - 1]; + oldlst = iwork[j]; + if (ndepth > 0) { +/* Retrieve relatively robust representation (RRR) of cluster */ +/* that has been computed at the previous level */ +/* The RRR is stored in Z and overwritten once the eigenvectors */ +/* have been computed or when the cluster is refined */ + if (*dol == 1 && *dou == *m) { +/* Get representation from location of the leftmost evalue */ +/* of the cluster */ + j = wbegin + oldfst - 1; + } else { + if (wbegin + oldfst - 1 < *dol) { +/* Get representation from the left end of Z array */ + j = *dol - 1; + } else if (wbegin + oldfst - 1 > *dou) { +/* Get representation from the right end of Z array */ + j = *dou; + } else { + j = wbegin + oldfst - 1; + } + } + i__3 = in - 1; + for (k = 1; k <= i__3; ++k) { + i__4 = ibegin + k - 1 + j * z_dim1; + d__[ibegin + k - 1] = z__[i__4].r; + i__4 = ibegin + k - 1 + (j + 1) * z_dim1; + l[ibegin + k - 1] = z__[i__4].r; +/* L45: */ + } + i__3 = iend + j * z_dim1; + d__[iend] = z__[i__3].r; + i__3 = iend + (j + 1) * z_dim1; + sigma = z__[i__3].r; +/* Set the corresponding entries in Z to zero */ + zlaset_("Full", &in, &c__2, &c_b1, &c_b1, &z__[ibegin + j + * z_dim1], ldz); + } +/* Compute DL and DLL of current RRR */ + i__3 = iend - 1; + for (j = ibegin; j <= i__3; ++j) { + tmp = d__[j] * l[j]; + work[indld - 1 + j] = tmp; + work[indlld - 1 + j] = tmp * l[j]; +/* L50: */ + } + if (ndepth > 0) { +/* P and Q are index of the first and last eigenvalue to compute */ +/* within the current block */ + p = indexw[wbegin - 1 + oldfst]; + q = indexw[wbegin - 1 + oldlst]; +/* Offset for the arrays WORK, WGAP and WERR, i.e., the P-OFFSET */ +/* through the Q-OFFSET elements of these arrays are to be used. */ +/* OFFSET = P-OLDFST */ + offset = indexw[wbegin] - 1; +/* perform limited bisection (if necessary) to get approximate */ +/* eigenvalues to the precision needed. */ + dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin - 1], &p, + &q, rtol1, rtol2, &offset, &work[wbegin], &wgap[ + wbegin], &werr[wbegin], &work[indwrk], &iwork[ + iindwk], pivmin, &spdiam, &in, &iinfo); + if (iinfo != 0) { + *info = -1; + return 0; + } +/* We also recompute the extremal gaps. W holds all eigenvalues */ +/* of the unshifted matrix and must be used for computation */ +/* of WGAP, the entries of WORK might stem from RRRs with */ +/* different shifts. The gaps from WBEGIN-1+OLDFST to */ +/* WBEGIN-1+OLDLST are correctly computed in DLARRB. */ +/* However, we only allow the gaps to become greater since */ +/* this is what should happen when we decrease WERR */ + if (oldfst > 1) { +/* Computing MAX */ + d__1 = wgap[wbegin + oldfst - 2], d__2 = w[wbegin + + oldfst - 1] - werr[wbegin + oldfst - 1] - w[ + wbegin + oldfst - 2] - werr[wbegin + oldfst - + 2]; + wgap[wbegin + oldfst - 2] = f2cmax(d__1,d__2); + } + if (wbegin + oldlst - 1 < wend) { +/* Computing MAX */ + d__1 = wgap[wbegin + oldlst - 1], d__2 = w[wbegin + + oldlst] - werr[wbegin + oldlst] - w[wbegin + + oldlst - 1] - werr[wbegin + oldlst - 1]; + wgap[wbegin + oldlst - 1] = f2cmax(d__1,d__2); + } +/* Each time the eigenvalues in WORK get refined, we store */ +/* the newly found approximation with all shifts applied in W */ + i__3 = oldlst; + for (j = oldfst; j <= i__3; ++j) { + w[wbegin + j - 1] = work[wbegin + j - 1] + sigma; +/* L53: */ + } + } +/* Process the current node. */ + newfst = oldfst; + i__3 = oldlst; + for (j = oldfst; j <= i__3; ++j) { + if (j == oldlst) { +/* we are at the right end of the cluster, this is also the */ +/* boundary of the child cluster */ + newlst = j; + } else if (wgap[wbegin + j - 1] >= *minrgp * (d__1 = work[ + wbegin + j - 1], abs(d__1))) { +/* the right relative gap is big enough, the child cluster */ +/* (NEWFST,..,NEWLST) is well separated from the following */ + newlst = j; + } else { +/* inside a child cluster, the relative gap is not */ +/* big enough. */ + goto L140; + } +/* Compute size of child cluster found */ + newsiz = newlst - newfst + 1; +/* NEWFTT is the place in Z where the new RRR or the computed */ +/* eigenvector is to be stored */ + if (*dol == 1 && *dou == *m) { +/* Store representation at location of the leftmost evalue */ +/* of the cluster */ + newftt = wbegin + newfst - 1; + } else { + if (wbegin + newfst - 1 < *dol) { +/* Store representation at the left end of Z array */ + newftt = *dol - 1; + } else if (wbegin + newfst - 1 > *dou) { +/* Store representation at the right end of Z array */ + newftt = *dou; + } else { + newftt = wbegin + newfst - 1; + } + } + if (newsiz > 1) { + +/* Current child is not a singleton but a cluster. */ +/* Compute and store new representation of child. */ + + +/* Compute left and right cluster gap. */ + +/* LGAP and RGAP are not computed from WORK because */ +/* the eigenvalue approximations may stem from RRRs */ +/* different shifts. However, W hold all eigenvalues */ +/* of the unshifted matrix. Still, the entries in WGAP */ +/* have to be computed from WORK since the entries */ +/* in W might be of the same order so that gaps are not */ +/* exhibited correctly for very close eigenvalues. */ + if (newfst == 1) { +/* Computing MAX */ + d__1 = 0., d__2 = w[wbegin] - werr[wbegin] - *vl; + lgap = f2cmax(d__1,d__2); + } else { + lgap = wgap[wbegin + newfst - 2]; + } + rgap = wgap[wbegin + newlst - 1]; + +/* Compute left- and rightmost eigenvalue of child */ +/* to high precision in order to shift as close */ +/* as possible and obtain as large relative gaps */ +/* as possible */ + + for (k = 1; k <= 2; ++k) { + if (k == 1) { + p = indexw[wbegin - 1 + newfst]; + } else { + p = indexw[wbegin - 1 + newlst]; + } + offset = indexw[wbegin] - 1; + dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin + - 1], &p, &p, &rqtol, &rqtol, &offset, & + work[wbegin], &wgap[wbegin], &werr[wbegin] + , &work[indwrk], &iwork[iindwk], pivmin, & + spdiam, &in, &iinfo); +/* L55: */ + } + + if (wbegin + newlst - 1 < *dol || wbegin + newfst - 1 + > *dou) { +/* if the cluster contains no desired eigenvalues */ +/* skip the computation of that branch of the rep. tree */ + +/* We could skip before the refinement of the extremal */ +/* eigenvalues of the child, but then the representation */ +/* tree could be different from the one when nothing is */ +/* skipped. For this reason we skip at this place. */ + idone = idone + newlst - newfst + 1; + goto L139; + } + +/* Compute RRR of child cluster. */ +/* Note that the new RRR is stored in Z */ + +/* DLARRF needs LWORK = 2*N */ + dlarrf_(&in, &d__[ibegin], &l[ibegin], &work[indld + + ibegin - 1], &newfst, &newlst, &work[wbegin], + &wgap[wbegin], &werr[wbegin], &spdiam, &lgap, + &rgap, pivmin, &tau, &work[indin1], &work[ + indin2], &work[indwrk], &iinfo); +/* In the complex case, DLARRF cannot write */ +/* the new RRR directly into Z and needs an intermediate */ +/* workspace */ + i__4 = in - 1; + for (k = 1; k <= i__4; ++k) { + i__5 = ibegin + k - 1 + newftt * z_dim1; + i__6 = indin1 + k - 1; + z__1.r = work[i__6], z__1.i = 0.; + z__[i__5].r = z__1.r, z__[i__5].i = z__1.i; + i__5 = ibegin + k - 1 + (newftt + 1) * z_dim1; + i__6 = indin2 + k - 1; + z__1.r = work[i__6], z__1.i = 0.; + z__[i__5].r = z__1.r, z__[i__5].i = z__1.i; +/* L56: */ + } + i__4 = iend + newftt * z_dim1; + i__5 = indin1 + in - 1; + z__1.r = work[i__5], z__1.i = 0.; + z__[i__4].r = z__1.r, z__[i__4].i = z__1.i; + if (iinfo == 0) { +/* a new RRR for the cluster was found by DLARRF */ +/* update shift and store it */ + ssigma = sigma + tau; + i__4 = iend + (newftt + 1) * z_dim1; + z__1.r = ssigma, z__1.i = 0.; + z__[i__4].r = z__1.r, z__[i__4].i = z__1.i; +/* WORK() are the midpoints and WERR() the semi-width */ +/* Note that the entries in W are unchanged. */ + i__4 = newlst; + for (k = newfst; k <= i__4; ++k) { + fudge = eps * 3. * (d__1 = work[wbegin + k - + 1], abs(d__1)); + work[wbegin + k - 1] -= tau; + fudge += eps * 4. * (d__1 = work[wbegin + k - + 1], abs(d__1)); +/* Fudge errors */ + werr[wbegin + k - 1] += fudge; +/* Gaps are not fudged. Provided that WERR is small */ +/* when eigenvalues are close, a zero gap indicates */ +/* that a new representation is needed for resolving */ +/* the cluster. A fudge could lead to a wrong decision */ +/* of judging eigenvalues 'separated' which in */ +/* reality are not. This could have a negative impact */ +/* on the orthogonality of the computed eigenvectors. */ +/* L116: */ + } + ++nclus; + k = newcls + (nclus << 1); + iwork[k - 1] = newfst; + iwork[k] = newlst; + } else { + *info = -2; + return 0; + } + } else { + +/* Compute eigenvector of singleton */ + + iter = 0; + + tol = log((doublereal) in) * 4. * eps; + + k = newfst; + windex = wbegin + k - 1; +/* Computing MAX */ + i__4 = windex - 1; + windmn = f2cmax(i__4,1); +/* Computing MIN */ + i__4 = windex + 1; + windpl = f2cmin(i__4,*m); + lambda = work[windex]; + ++done; +/* Check if eigenvector computation is to be skipped */ + if (windex < *dol || windex > *dou) { + eskip = TRUE_; + goto L125; + } else { + eskip = FALSE_; + } + left = work[windex] - werr[windex]; + right = work[windex] + werr[windex]; + indeig = indexw[windex]; +/* Note that since we compute the eigenpairs for a child, */ +/* all eigenvalue approximations are w.r.t the same shift. */ +/* In this case, the entries in WORK should be used for */ +/* computing the gaps since they exhibit even very small */ +/* differences in the eigenvalues, as opposed to the */ +/* entries in W which might "look" the same. */ + if (k == 1) { +/* In the case RANGE='I' and with not much initial */ +/* accuracy in LAMBDA and VL, the formula */ +/* LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA ) */ +/* can lead to an overestimation of the left gap and */ +/* thus to inadequately early RQI 'convergence'. */ +/* Prevent this by forcing a small left gap. */ +/* Computing MAX */ + d__1 = abs(left), d__2 = abs(right); + lgap = eps * f2cmax(d__1,d__2); + } else { + lgap = wgap[windmn]; + } + if (k == im) { +/* In the case RANGE='I' and with not much initial */ +/* accuracy in LAMBDA and VU, the formula */ +/* can lead to an overestimation of the right gap and */ +/* thus to inadequately early RQI 'convergence'. */ +/* Prevent this by forcing a small right gap. */ +/* Computing MAX */ + d__1 = abs(left), d__2 = abs(right); + rgap = eps * f2cmax(d__1,d__2); + } else { + rgap = wgap[windex]; + } + gap = f2cmin(lgap,rgap); + if (k == 1 || k == im) { +/* The eigenvector support can become wrong */ +/* because significant entries could be cut off due to a */ +/* large GAPTOL parameter in LAR1V. Prevent this. */ + gaptol = 0.; + } else { + gaptol = gap * eps; + } + isupmn = in; + isupmx = 1; +/* Update WGAP so that it holds the minimum gap */ +/* to the left or the right. This is crucial in the */ +/* case where bisection is used to ensure that the */ +/* eigenvalue is refined up to the required precision. */ +/* The correct value is restored afterwards. */ + savgap = wgap[windex]; + wgap[windex] = gap; +/* We want to use the Rayleigh Quotient Correction */ +/* as often as possible since it converges quadratically */ +/* when we are close enough to the desired eigenvalue. */ +/* However, the Rayleigh Quotient can have the wrong sign */ +/* and lead us away from the desired eigenvalue. In this */ +/* case, the best we can do is to use bisection. */ + usedbs = FALSE_; + usedrq = FALSE_; +/* Bisection is initially turned off unless it is forced */ + needbs = ! tryrqc; +L120: +/* Check if bisection should be used to refine eigenvalue */ + if (needbs) { +/* Take the bisection as new iterate */ + usedbs = TRUE_; + itmp1 = iwork[iindr + windex]; + offset = indexw[wbegin] - 1; + d__1 = eps * 2.; + dlarrb_(&in, &d__[ibegin], &work[indlld + ibegin + - 1], &indeig, &indeig, &c_b28, &d__1, & + offset, &work[wbegin], &wgap[wbegin], & + werr[wbegin], &work[indwrk], &iwork[ + iindwk], pivmin, &spdiam, &itmp1, &iinfo); + if (iinfo != 0) { + *info = -3; + return 0; + } + lambda = work[windex]; +/* Reset twist index from inaccurate LAMBDA to */ +/* force computation of true MINGMA */ + iwork[iindr + windex] = 0; + } +/* Given LAMBDA, compute the eigenvector. */ + L__1 = ! usedbs; + zlar1v_(&in, &c__1, &in, &lambda, &d__[ibegin], &l[ + ibegin], &work[indld + ibegin - 1], &work[ + indlld + ibegin - 1], pivmin, &gaptol, &z__[ + ibegin + windex * z_dim1], &L__1, &negcnt, & + ztz, &mingma, &iwork[iindr + windex], &isuppz[ + (windex << 1) - 1], &nrminv, &resid, &rqcorr, + &work[indwrk]); + if (iter == 0) { + bstres = resid; + bstw = lambda; + } else if (resid < bstres) { + bstres = resid; + bstw = lambda; + } +/* Computing MIN */ + i__4 = isupmn, i__5 = isuppz[(windex << 1) - 1]; + isupmn = f2cmin(i__4,i__5); +/* Computing MAX */ + i__4 = isupmx, i__5 = isuppz[windex * 2]; + isupmx = f2cmax(i__4,i__5); + ++iter; +/* sin alpha <= |resid|/gap */ +/* Note that both the residual and the gap are */ +/* proportional to the matrix, so ||T|| doesn't play */ +/* a role in the quotient */ + +/* Convergence test for Rayleigh-Quotient iteration */ +/* (omitted when Bisection has been used) */ + + if (resid > tol * gap && abs(rqcorr) > rqtol * abs( + lambda) && ! usedbs) { +/* We need to check that the RQCORR update doesn't */ +/* move the eigenvalue away from the desired one and */ +/* towards a neighbor. -> protection with bisection */ + if (indeig <= negcnt) { +/* The wanted eigenvalue lies to the left */ + sgndef = -1.; + } else { +/* The wanted eigenvalue lies to the right */ + sgndef = 1.; + } +/* We only use the RQCORR if it improves the */ +/* the iterate reasonably. */ + if (rqcorr * sgndef >= 0. && lambda + rqcorr <= + right && lambda + rqcorr >= left) { + usedrq = TRUE_; +/* Store new midpoint of bisection interval in WORK */ + if (sgndef == 1.) { +/* The current LAMBDA is on the left of the true */ +/* eigenvalue */ + left = lambda; +/* We prefer to assume that the error estimate */ +/* is correct. We could make the interval not */ +/* as a bracket but to be modified if the RQCORR */ +/* chooses to. In this case, the RIGHT side should */ +/* be modified as follows: */ +/* RIGHT = MAX(RIGHT, LAMBDA + RQCORR) */ + } else { +/* The current LAMBDA is on the right of the true */ +/* eigenvalue */ + right = lambda; +/* See comment about assuming the error estimate is */ +/* correct above. */ +/* LEFT = MIN(LEFT, LAMBDA + RQCORR) */ + } + work[windex] = (right + left) * .5; +/* Take RQCORR since it has the correct sign and */ +/* improves the iterate reasonably */ + lambda += rqcorr; +/* Update width of error interval */ + werr[windex] = (right - left) * .5; + } else { + needbs = TRUE_; + } + if (right - left < rqtol * abs(lambda)) { +/* The eigenvalue is computed to bisection accuracy */ +/* compute eigenvector and stop */ + usedbs = TRUE_; + goto L120; + } else if (iter < 10) { + goto L120; + } else if (iter == 10) { + needbs = TRUE_; + goto L120; + } else { + *info = 5; + return 0; + } + } else { + stp2ii = FALSE_; + if (usedrq && usedbs && bstres <= resid) { + lambda = bstw; + stp2ii = TRUE_; + } + if (stp2ii) { +/* improve error angle by second step */ + L__1 = ! usedbs; + zlar1v_(&in, &c__1, &in, &lambda, &d__[ibegin] + , &l[ibegin], &work[indld + ibegin - + 1], &work[indlld + ibegin - 1], + pivmin, &gaptol, &z__[ibegin + windex + * z_dim1], &L__1, &negcnt, &ztz, & + mingma, &iwork[iindr + windex], & + isuppz[(windex << 1) - 1], &nrminv, & + resid, &rqcorr, &work[indwrk]); + } + work[windex] = lambda; + } + +/* Compute FP-vector support w.r.t. whole matrix */ + + isuppz[(windex << 1) - 1] += oldien; + isuppz[windex * 2] += oldien; + zfrom = isuppz[(windex << 1) - 1]; + zto = isuppz[windex * 2]; + isupmn += oldien; + isupmx += oldien; +/* Ensure vector is ok if support in the RQI has changed */ + if (isupmn < zfrom) { + i__4 = zfrom - 1; + for (ii = isupmn; ii <= i__4; ++ii) { + i__5 = ii + windex * z_dim1; + z__[i__5].r = 0., z__[i__5].i = 0.; +/* L122: */ + } + } + if (isupmx > zto) { + i__4 = isupmx; + for (ii = zto + 1; ii <= i__4; ++ii) { + i__5 = ii + windex * z_dim1; + z__[i__5].r = 0., z__[i__5].i = 0.; +/* L123: */ + } + } + i__4 = zto - zfrom + 1; + zdscal_(&i__4, &nrminv, &z__[zfrom + windex * z_dim1], + &c__1); +L125: +/* Update W */ + w[windex] = lambda + sigma; +/* Recompute the gaps on the left and right */ +/* But only allow them to become larger and not */ +/* smaller (which can only happen through "bad" */ +/* cancellation and doesn't reflect the theory */ +/* where the initial gaps are underestimated due */ +/* to WERR being too crude.) */ + if (! eskip) { + if (k > 1) { +/* Computing MAX */ + d__1 = wgap[windmn], d__2 = w[windex] - werr[ + windex] - w[windmn] - werr[windmn]; + wgap[windmn] = f2cmax(d__1,d__2); + } + if (windex < wend) { +/* Computing MAX */ + d__1 = savgap, d__2 = w[windpl] - werr[windpl] + - w[windex] - werr[windex]; + wgap[windex] = f2cmax(d__1,d__2); + } + } + ++idone; + } +/* here ends the code for the current child */ + +L139: +/* Proceed to any remaining child nodes */ + newfst = j + 1; +L140: + ; + } +/* L150: */ + } + ++ndepth; + goto L40; + } + ibegin = iend + 1; + wbegin = wend + 1; +L170: + ; + } + + return 0; + +/* End of ZLARRV */ + +} /* zlarrv_ */ + diff --git a/lapack-netlib/SRC/zlarscl2.c b/lapack-netlib/SRC/zlarscl2.c new file mode 100644 index 000000000..7aa294499 --- /dev/null +++ b/lapack-netlib/SRC/zlarscl2.c @@ -0,0 +1,519 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLARSCL2 performs reciprocal diagonal scaling on a vector. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLARSCL2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLARSCL2 ( M, N, D, X, LDX ) */ + +/* INTEGER M, N, LDX */ +/* COMPLEX*16 X( LDX, * ) */ +/* DOUBLE PRECISION D( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLARSCL2 performs a reciprocal diagonal scaling on an vector: */ +/* > x <-- inv(D) * x */ +/* > where the DOUBLE PRECISION diagonal matrix D is stored as a vector. */ +/* > */ +/* > Eventually to be replaced by BLAS_zge_diag_scale in the new BLAS */ +/* > standard. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of D and X. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of X. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, length M */ +/* > Diagonal matrix D, stored as a vector of length M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (LDX,N) */ +/* > On entry, the vector X to be scaled by D. */ +/* > On exit, the scaled vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the vector X. LDX >= M. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16OTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zlarscl2_(integer *m, integer *n, doublereal *d__, + doublecomplex *x, integer *ldx) +{ + /* System generated locals */ + integer x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1; + + /* Local variables */ + integer i__, j; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --d__; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + + /* Function Body */ + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * x_dim1; + i__4 = i__ + j * x_dim1; + i__5 = i__; + z__1.r = x[i__4].r / d__[i__5], z__1.i = x[i__4].i / d__[i__5]; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + } + } + return 0; +} /* zlarscl2_ */ + diff --git a/lapack-netlib/SRC/zlartg.c b/lapack-netlib/SRC/zlartg.c new file mode 100644 index 000000000..3e77774e7 --- /dev/null +++ b/lapack-netlib/SRC/zlartg.c @@ -0,0 +1,695 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLARTG generates a plane rotation with real cosine and complex sine. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLARTG + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLARTG( F, G, CS, SN, R ) */ + +/* DOUBLE PRECISION CS */ +/* COMPLEX*16 F, G, R, SN */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLARTG generates a plane rotation so that */ +/* > */ +/* > [ CS SN ] [ F ] [ R ] */ +/* > [ __ ] . [ ] = [ ] where CS**2 + |SN|**2 = 1. */ +/* > [ -SN CS ] [ G ] [ 0 ] */ +/* > */ +/* > This is a faster version of the BLAS1 routine ZROTG, except for */ +/* > the following differences: */ +/* > F and G are unchanged on return. */ +/* > If G=0, then CS=1 and SN=0. */ +/* > If F=0, then CS=0 and SN is chosen so that R is real. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] F */ +/* > \verbatim */ +/* > F is COMPLEX*16 */ +/* > The first component of vector to be rotated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] G */ +/* > \verbatim */ +/* > G is COMPLEX*16 */ +/* > The second component of vector to be rotated. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CS */ +/* > \verbatim */ +/* > CS is DOUBLE PRECISION */ +/* > The cosine of the rotation. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SN */ +/* > \verbatim */ +/* > SN is COMPLEX*16 */ +/* > The sine of the rotation. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] R */ +/* > \verbatim */ +/* > R is COMPLEX*16 */ +/* > The nonzero component of the rotated vector. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > 3-5-96 - Modified with a new algorithm by W. Kahan and J. Demmel */ +/* > */ +/* > This version has a few statements commented out for thread safety */ +/* > (machine parameters are computed on each entry). 10 feb 03, SJH. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlartg_(doublecomplex *f, doublecomplex *g, doublereal * + cs, doublecomplex *sn, doublecomplex *r__) +{ + /* System generated locals */ + integer i__1; + doublereal d__1, d__2, d__3, d__4, d__5, d__6, d__7, d__8, d__9, d__10; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + doublereal d__; + integer i__; + doublereal scale; + integer count; + doublereal f2, g2, safmn2; + extern doublereal dlapy2_(doublereal *, doublereal *); + doublereal safmx2; + doublecomplex ff; + doublereal di, dr; + extern doublereal dlamch_(char *); + doublecomplex fs, gs; + extern logical disnan_(doublereal *); + doublereal safmin, f2s, g2s, eps; + + +/* -- 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 */ + + +/* ===================================================================== */ + +/* LOGICAL FIRST */ + + safmin = dlamch_("S"); + eps = dlamch_("E"); + d__1 = dlamch_("B"); + i__1 = (integer) (log(safmin / eps) / log(dlamch_("B")) / 2.); + safmn2 = pow_di(&d__1, &i__1); + safmx2 = 1. / safmn2; +/* Computing MAX */ +/* Computing MAX */ + d__7 = (d__1 = f->r, abs(d__1)), d__8 = (d__2 = d_imag(f), abs(d__2)); +/* Computing MAX */ + d__9 = (d__3 = g->r, abs(d__3)), d__10 = (d__4 = d_imag(g), abs(d__4)); + d__5 = f2cmax(d__7,d__8), d__6 = f2cmax(d__9,d__10); + scale = f2cmax(d__5,d__6); + fs.r = f->r, fs.i = f->i; + gs.r = g->r, gs.i = g->i; + count = 0; + if (scale >= safmx2) { +L10: + ++count; + z__1.r = safmn2 * fs.r, z__1.i = safmn2 * fs.i; + fs.r = z__1.r, fs.i = z__1.i; + z__1.r = safmn2 * gs.r, z__1.i = safmn2 * gs.i; + gs.r = z__1.r, gs.i = z__1.i; + scale *= safmn2; + if (scale >= safmx2 && count < 20) { + goto L10; + } + } else if (scale <= safmn2) { + d__1 = z_abs(g); + if (g->r == 0. && g->i == 0. || disnan_(&d__1)) { + *cs = 1.; + sn->r = 0., sn->i = 0.; + r__->r = f->r, r__->i = f->i; + return 0; + } +L20: + --count; + z__1.r = safmx2 * fs.r, z__1.i = safmx2 * fs.i; + fs.r = z__1.r, fs.i = z__1.i; + z__1.r = safmx2 * gs.r, z__1.i = safmx2 * gs.i; + gs.r = z__1.r, gs.i = z__1.i; + scale *= safmx2; + if (scale <= safmn2) { + goto L20; + } + } +/* Computing 2nd power */ + d__1 = fs.r; +/* Computing 2nd power */ + d__2 = d_imag(&fs); + f2 = d__1 * d__1 + d__2 * d__2; +/* Computing 2nd power */ + d__1 = gs.r; +/* Computing 2nd power */ + d__2 = d_imag(&gs); + g2 = d__1 * d__1 + d__2 * d__2; + if (f2 <= f2cmax(g2,1.) * safmin) { + +/* This is a rare case: F is very small. */ + + if (f->r == 0. && f->i == 0.) { + *cs = 0.; + d__2 = g->r; + d__3 = d_imag(g); + d__1 = dlapy2_(&d__2, &d__3); + r__->r = d__1, r__->i = 0.; +/* Do complex/real division explicitly with two real divisions */ + d__1 = gs.r; + d__2 = d_imag(&gs); + d__ = dlapy2_(&d__1, &d__2); + d__1 = gs.r / d__; + d__2 = -d_imag(&gs) / d__; + z__1.r = d__1, z__1.i = d__2; + sn->r = z__1.r, sn->i = z__1.i; + return 0; + } + d__1 = fs.r; + d__2 = d_imag(&fs); + f2s = dlapy2_(&d__1, &d__2); +/* G2 and G2S are accurate */ +/* G2 is at least SAFMIN, and G2S is at least SAFMN2 */ + g2s = sqrt(g2); +/* Error in CS from underflow in F2S is at most */ +/* UNFL / SAFMN2 .lt. sqrt(UNFL*EPS) .lt. EPS */ +/* If MAX(G2,ONE)=G2, then F2 .lt. G2*SAFMIN, */ +/* and so CS .lt. sqrt(SAFMIN) */ +/* If MAX(G2,ONE)=ONE, then F2 .lt. SAFMIN */ +/* and so CS .lt. sqrt(SAFMIN)/SAFMN2 = sqrt(EPS) */ +/* Therefore, CS = F2S/G2S / sqrt( 1 + (F2S/G2S)**2 ) = F2S/G2S */ + *cs = f2s / g2s; +/* Make sure abs(FF) = 1 */ +/* Do complex/real division explicitly with 2 real divisions */ +/* Computing MAX */ + d__3 = (d__1 = f->r, abs(d__1)), d__4 = (d__2 = d_imag(f), abs(d__2)); + if (f2cmax(d__3,d__4) > 1.) { + d__1 = f->r; + d__2 = d_imag(f); + d__ = dlapy2_(&d__1, &d__2); + d__1 = f->r / d__; + d__2 = d_imag(f) / d__; + z__1.r = d__1, z__1.i = d__2; + ff.r = z__1.r, ff.i = z__1.i; + } else { + dr = safmx2 * f->r; + di = safmx2 * d_imag(f); + d__ = dlapy2_(&dr, &di); + d__1 = dr / d__; + d__2 = di / d__; + z__1.r = d__1, z__1.i = d__2; + ff.r = z__1.r, ff.i = z__1.i; + } + d__1 = gs.r / g2s; + d__2 = -d_imag(&gs) / g2s; + z__2.r = d__1, z__2.i = d__2; + z__1.r = ff.r * z__2.r - ff.i * z__2.i, z__1.i = ff.r * z__2.i + ff.i + * z__2.r; + sn->r = z__1.r, sn->i = z__1.i; + z__2.r = *cs * f->r, z__2.i = *cs * f->i; + z__3.r = sn->r * g->r - sn->i * g->i, z__3.i = sn->r * g->i + sn->i * + g->r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + r__->r = z__1.r, r__->i = z__1.i; + } else { + +/* This is the most common case. */ +/* Neither F2 nor F2/G2 are less than SAFMIN */ +/* F2S cannot overflow, and it is accurate */ + + f2s = sqrt(g2 / f2 + 1.); +/* Do the F2S(real)*FS(complex) multiply with two real multiplies */ + d__1 = f2s * fs.r; + d__2 = f2s * d_imag(&fs); + z__1.r = d__1, z__1.i = d__2; + r__->r = z__1.r, r__->i = z__1.i; + *cs = 1. / f2s; + d__ = f2 + g2; +/* Do complex/real division explicitly with two real divisions */ + d__1 = r__->r / d__; + d__2 = d_imag(r__) / d__; + z__1.r = d__1, z__1.i = d__2; + sn->r = z__1.r, sn->i = z__1.i; + d_cnjg(&z__2, &gs); + z__1.r = sn->r * z__2.r - sn->i * z__2.i, z__1.i = sn->r * z__2.i + + sn->i * z__2.r; + sn->r = z__1.r, sn->i = z__1.i; + if (count != 0) { + if (count > 0) { + i__1 = count; + for (i__ = 1; i__ <= i__1; ++i__) { + z__1.r = safmx2 * r__->r, z__1.i = safmx2 * r__->i; + r__->r = z__1.r, r__->i = z__1.i; +/* L30: */ + } + } else { + i__1 = -count; + for (i__ = 1; i__ <= i__1; ++i__) { + z__1.r = safmn2 * r__->r, z__1.i = safmn2 * r__->i; + r__->r = z__1.r, r__->i = z__1.i; +/* L40: */ + } + } + } + } + return 0; + +/* End of ZLARTG */ + +} /* zlartg_ */ + diff --git a/lapack-netlib/SRC/zlartv.c b/lapack-netlib/SRC/zlartv.c new file mode 100644 index 000000000..33f8d400a --- /dev/null +++ b/lapack-netlib/SRC/zlartv.c @@ -0,0 +1,560 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLARTV applies a vector of plane rotations with real cosines and complex sines to the elements +of a pair of vectors. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLARTV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLARTV( N, X, INCX, Y, INCY, C, S, INCC ) */ + +/* INTEGER INCC, INCX, INCY, N */ +/* DOUBLE PRECISION C( * ) */ +/* COMPLEX*16 S( * ), X( * ), Y( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLARTV applies a vector of complex plane rotations with real cosines */ +/* > to elements of the complex vectors x and y. For i = 1,2,...,n */ +/* > */ +/* > ( x(i) ) := ( c(i) s(i) ) ( x(i) ) */ +/* > ( y(i) ) ( -conjg(s(i)) c(i) ) ( y(i) ) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of plane rotations to be applied. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (1+(N-1)*INCX) */ +/* > The vector x. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The increment between elements of X. INCX > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is COMPLEX*16 array, dimension (1+(N-1)*INCY) */ +/* > The vector y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCY */ +/* > \verbatim */ +/* > INCY is INTEGER */ +/* > The increment between elements of Y. INCY > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (1+(N-1)*INCC) */ +/* > The cosines of the plane rotations. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is COMPLEX*16 array, dimension (1+(N-1)*INCC) */ +/* > The sines of the plane rotations. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCC */ +/* > \verbatim */ +/* > INCC is INTEGER */ +/* > The increment between elements of C and S. INCC > 0. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlartv_(integer *n, doublecomplex *x, integer *incx, + doublecomplex *y, integer *incy, doublereal *c__, doublecomplex *s, + integer *incc) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4; + doublecomplex z__1, z__2, z__3, z__4; + + /* Local variables */ + integer i__, ic, ix, iy; + doublecomplex xi, yi; + + +/* -- 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 */ + --s; + --c__; + --y; + --x; + + /* Function Body */ + ix = 1; + iy = 1; + ic = 1; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ix; + xi.r = x[i__2].r, xi.i = x[i__2].i; + i__2 = iy; + yi.r = y[i__2].r, yi.i = y[i__2].i; + i__2 = ix; + i__3 = ic; + z__2.r = c__[i__3] * xi.r, z__2.i = c__[i__3] * xi.i; + i__4 = ic; + z__3.r = s[i__4].r * yi.r - s[i__4].i * yi.i, z__3.i = s[i__4].r * + yi.i + s[i__4].i * yi.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + i__2 = iy; + i__3 = ic; + z__2.r = c__[i__3] * yi.r, z__2.i = c__[i__3] * yi.i; + d_cnjg(&z__4, &s[ic]); + z__3.r = z__4.r * xi.r - z__4.i * xi.i, z__3.i = z__4.r * xi.i + + z__4.i * xi.r; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + ix += *incx; + iy += *incy; + ic += *incc; +/* L10: */ + } + return 0; + +/* End of ZLARTV */ + +} /* zlartv_ */ + diff --git a/lapack-netlib/SRC/zlarz.c b/lapack-netlib/SRC/zlarz.c new file mode 100644 index 000000000..5298e20df --- /dev/null +++ b/lapack-netlib/SRC/zlarz.c @@ -0,0 +1,646 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLARZ applies an elementary reflector (as returned by stzrzf) to a general matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLARZ + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK ) */ + +/* CHARACTER SIDE */ +/* INTEGER INCV, L, LDC, M, N */ +/* COMPLEX*16 TAU */ +/* COMPLEX*16 C( LDC, * ), V( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLARZ applies a complex elementary reflector H to a complex */ +/* > M-by-N matrix C, from either the left or the right. H is represented */ +/* > in the form */ +/* > */ +/* > H = I - tau * v * v**H */ +/* > */ +/* > where tau is a complex scalar and v is a complex vector. */ +/* > */ +/* > If tau = 0, then H is taken to be the unit matrix. */ +/* > */ +/* > To apply H**H (the conjugate transpose of H), supply conjg(tau) instead */ +/* > tau. */ +/* > */ +/* > H is a product of k elementary reflectors as returned by ZTZRZF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': form H * C */ +/* > = 'R': form C * H */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The number of entries of the vector V containing */ +/* > the meaningful part of the Householder vectors. */ +/* > If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is COMPLEX*16 array, dimension (1+(L-1)*abs(INCV)) */ +/* > The vector v in the representation of H as returned by */ +/* > ZTZRZF. V is not used if TAU = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCV */ +/* > \verbatim */ +/* > INCV is INTEGER */ +/* > The increment between elements of v. INCV <> 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 */ +/* > The value tau in the representation of H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX*16 array, dimension (LDC,N) */ +/* > On entry, the M-by-N matrix C. */ +/* > On exit, C is overwritten by the matrix H * C if SIDE = 'L', */ +/* > or C * H if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension */ +/* > (N) if SIDE = 'L' */ +/* > or (M) if SIDE = 'R' */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlarz_(char *side, integer *m, integer *n, integer *l, + doublecomplex *v, integer *incv, doublecomplex *tau, doublecomplex * + c__, integer *ldc, doublecomplex *work) +{ + /* System generated locals */ + integer c_dim1, c_offset; + doublecomplex z__1; + + /* Local variables */ + extern logical lsame_(char *, char *); + extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *), + zgeru_(integer *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *) + , zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, + integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, integer *), zlacgv_(integer *, + doublecomplex *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --v; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + if (lsame_(side, "L")) { + +/* Form H * C */ + + if (tau->r != 0. || tau->i != 0.) { + +/* w( 1:n ) = conjg( C( 1, 1:n ) ) */ + + zcopy_(n, &c__[c_offset], ldc, &work[1], &c__1); + zlacgv_(n, &work[1], &c__1); + +/* w( 1:n ) = conjg( w( 1:n ) + C( m-l+1:m, 1:n )**H * v( 1:l ) ) */ + + zgemv_("Conjugate transpose", l, n, &c_b1, &c__[*m - *l + 1 + + c_dim1], ldc, &v[1], incv, &c_b1, &work[1], &c__1); + zlacgv_(n, &work[1], &c__1); + +/* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n ) */ + + z__1.r = -tau->r, z__1.i = -tau->i; + zaxpy_(n, &z__1, &work[1], &c__1, &c__[c_offset], ldc); + +/* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... */ +/* tau * v( 1:l ) * w( 1:n )**H */ + + z__1.r = -tau->r, z__1.i = -tau->i; + zgeru_(l, n, &z__1, &v[1], incv, &work[1], &c__1, &c__[*m - *l + + 1 + c_dim1], ldc); + } + + } else { + +/* Form C * H */ + + if (tau->r != 0. || tau->i != 0.) { + +/* w( 1:m ) = C( 1:m, 1 ) */ + + zcopy_(m, &c__[c_offset], &c__1, &work[1], &c__1); + +/* w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l ) */ + + zgemv_("No transpose", m, l, &c_b1, &c__[(*n - *l + 1) * c_dim1 + + 1], ldc, &v[1], incv, &c_b1, &work[1], &c__1); + +/* C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m ) */ + + z__1.r = -tau->r, z__1.i = -tau->i; + zaxpy_(m, &z__1, &work[1], &c__1, &c__[c_offset], &c__1); + +/* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... */ +/* tau * w( 1:m ) * v( 1:l )**H */ + + z__1.r = -tau->r, z__1.i = -tau->i; + zgerc_(m, l, &z__1, &work[1], &c__1, &v[1], incv, &c__[(*n - *l + + 1) * c_dim1 + 1], ldc); + + } + + } + + return 0; + +/* End of ZLARZ */ + +} /* zlarz_ */ + diff --git a/lapack-netlib/SRC/zlarzb.c b/lapack-netlib/SRC/zlarzb.c new file mode 100644 index 000000000..30aee75f0 --- /dev/null +++ b/lapack-netlib/SRC/zlarzb.c @@ -0,0 +1,786 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLARZB applies a block reflector or its conjugate-transpose to a general matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLARZB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, */ +/* LDV, T, LDT, C, LDC, WORK, LDWORK ) */ + +/* CHARACTER DIRECT, SIDE, STOREV, TRANS */ +/* INTEGER K, L, LDC, LDT, LDV, LDWORK, M, N */ +/* COMPLEX*16 C( LDC, * ), T( LDT, * ), V( LDV, * ), */ +/* $ WORK( LDWORK, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLARZB applies a complex block reflector H or its transpose H**H */ +/* > to a complex distributed M-by-N C from the left or the right. */ +/* > */ +/* > Currently, only STOREV = 'R' and DIRECT = 'B' are supported. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply H or H**H from the Left */ +/* > = 'R': apply H or H**H from the Right */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': apply H (No transpose) */ +/* > = 'C': apply H**H (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIRECT */ +/* > \verbatim */ +/* > DIRECT is CHARACTER*1 */ +/* > Indicates how H is formed from a product of elementary */ +/* > reflectors */ +/* > = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet) */ +/* > = 'B': H = H(k) . . . H(2) H(1) (Backward) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] STOREV */ +/* > \verbatim */ +/* > STOREV is CHARACTER*1 */ +/* > Indicates how the vectors which define the elementary */ +/* > reflectors are stored: */ +/* > = 'C': Columnwise (not supported yet) */ +/* > = 'R': Rowwise */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The order of the matrix T (= the number of elementary */ +/* > reflectors whose product defines the block reflector). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The number of columns of the matrix V containing the */ +/* > meaningful part of the Householder reflectors. */ +/* > If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is COMPLEX*16 array, dimension (LDV,NV). */ +/* > If STOREV = 'C', NV = K; if STOREV = 'R', NV = L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. */ +/* > If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is COMPLEX*16 array, dimension (LDT,K) */ +/* > The triangular K-by-K matrix T in the representation of the */ +/* > block reflector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= K. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX*16 array, dimension (LDC,N) */ +/* > On entry, the M-by-N matrix C. */ +/* > On exit, C is overwritten by H*C or H**H*C or C*H or C*H**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (LDWORK,K) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDWORK */ +/* > \verbatim */ +/* > LDWORK is INTEGER */ +/* > The leading dimension of the array WORK. */ +/* > If SIDE = 'L', LDWORK >= f2cmax(1,N); */ +/* > if SIDE = 'R', LDWORK >= f2cmax(1,M). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlarzb_(char *side, char *trans, char *direct, char * + storev, integer *m, integer *n, integer *k, integer *l, doublecomplex + *v, integer *ldv, doublecomplex *t, integer *ldt, doublecomplex *c__, + integer *ldc, doublecomplex *work, integer *ldwork) +{ + /* System generated locals */ + integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, + work_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1; + + /* Local variables */ + integer info, i__, j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *), zcopy_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *), ztrmm_(char *, char *, + char *, char *, integer *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *, ftnlen), + zlacgv_(integer *, doublecomplex *, integer *); + char transt[1]; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + work_dim1 = *ldwork; + work_offset = 1 + work_dim1 * 1; + work -= work_offset; + + /* Function Body */ + if (*m <= 0 || *n <= 0) { + return 0; + } + +/* Check for currently supported options */ + + info = 0; + if (! lsame_(direct, "B")) { + info = -3; + } else if (! lsame_(storev, "R")) { + info = -4; + } + if (info != 0) { + i__1 = -info; + xerbla_("ZLARZB", &i__1, (ftnlen)6); + return 0; + } + + if (lsame_(trans, "N")) { + *(unsigned char *)transt = 'C'; + } else { + *(unsigned char *)transt = 'N'; + } + + if (lsame_(side, "L")) { + +/* Form H * C or H**H * C */ + +/* W( 1:n, 1:k ) = C( 1:k, 1:n )**H */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); +/* L10: */ + } + +/* W( 1:n, 1:k ) = W( 1:n, 1:k ) + ... */ +/* C( m-l+1:m, 1:n )**H * V( 1:k, 1:l )**T */ + + if (*l > 0) { + zgemm_("Transpose", "Conjugate transpose", n, k, l, &c_b1, &c__[* + m - *l + 1 + c_dim1], ldc, &v[v_offset], ldv, &c_b1, & + work[work_offset], ldwork); + } + +/* W( 1:n, 1:k ) = W( 1:n, 1:k ) * T**T or W( 1:m, 1:k ) * T */ + + ztrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b1, &t[t_offset] + , ldt, &work[work_offset], ldwork); + +/* C( 1:k, 1:n ) = C( 1:k, 1:n ) - W( 1:n, 1:k )**H */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + i__5 = j + i__ * work_dim1; + z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[i__4].i - + work[i__5].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L20: */ + } +/* L30: */ + } + +/* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... */ +/* V( 1:k, 1:l )**H * W( 1:n, 1:k )**H */ + + if (*l > 0) { + z__1.r = -1., z__1.i = 0.; + zgemm_("Transpose", "Transpose", l, n, k, &z__1, &v[v_offset], + ldv, &work[work_offset], ldwork, &c_b1, &c__[*m - *l + 1 + + c_dim1], ldc); + } + + } else if (lsame_(side, "R")) { + +/* Form C * H or C * H**H */ + +/* W( 1:m, 1:k ) = C( 1:m, 1:k ) */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + zcopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], & + c__1); +/* L40: */ + } + +/* W( 1:m, 1:k ) = W( 1:m, 1:k ) + ... */ +/* C( 1:m, n-l+1:n ) * V( 1:k, 1:l )**H */ + + if (*l > 0) { + zgemm_("No transpose", "Transpose", m, k, l, &c_b1, &c__[(*n - *l + + 1) * c_dim1 + 1], ldc, &v[v_offset], ldv, &c_b1, &work[ + work_offset], ldwork); + } + +/* W( 1:m, 1:k ) = W( 1:m, 1:k ) * conjg( T ) or */ +/* W( 1:m, 1:k ) * T**H */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *k - j + 1; + zlacgv_(&i__2, &t[j + j * t_dim1], &c__1); +/* L50: */ + } + ztrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b1, &t[t_offset], + ldt, &work[work_offset], ldwork); + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *k - j + 1; + zlacgv_(&i__2, &t[j + j * t_dim1], &c__1); +/* L60: */ + } + +/* C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k ) */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * c_dim1; + i__4 = i__ + j * c_dim1; + i__5 = i__ + j * work_dim1; + z__1.r = c__[i__4].r - work[i__5].r, z__1.i = c__[i__4].i - + work[i__5].i; + c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; +/* L70: */ + } +/* L80: */ + } + +/* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... */ +/* W( 1:m, 1:k ) * conjg( V( 1:k, 1:l ) ) */ + + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + zlacgv_(k, &v[j * v_dim1 + 1], &c__1); +/* L90: */ + } + if (*l > 0) { + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "No transpose", m, l, k, &z__1, &work[ + work_offset], ldwork, &v[v_offset], ldv, &c_b1, &c__[(*n + - *l + 1) * c_dim1 + 1], ldc); + } + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + zlacgv_(k, &v[j * v_dim1 + 1], &c__1); +/* L100: */ + } + + } + + return 0; + +/* End of ZLARZB */ + +} /* zlarzb_ */ + diff --git a/lapack-netlib/SRC/zlarzt.c b/lapack-netlib/SRC/zlarzt.c new file mode 100644 index 000000000..0d6fea4f9 --- /dev/null +++ b/lapack-netlib/SRC/zlarzt.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 +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLARZT forms the triangular factor T of a block reflector H = I - vtvH. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLARZT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) */ + +/* CHARACTER DIRECT, STOREV */ +/* INTEGER K, LDT, LDV, N */ +/* COMPLEX*16 T( LDT, * ), TAU( * ), V( LDV, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLARZT forms the triangular factor T of a complex block reflector */ +/* > H of order > n, which is defined as a product of k elementary */ +/* > reflectors. */ +/* > */ +/* > If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */ +/* > */ +/* > If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */ +/* > */ +/* > If STOREV = 'C', the vector which defines the elementary reflector */ +/* > H(i) is stored in the i-th column of the array V, and */ +/* > */ +/* > H = I - V * T * V**H */ +/* > */ +/* > If STOREV = 'R', the vector which defines the elementary reflector */ +/* > H(i) is stored in the i-th row of the array V, and */ +/* > */ +/* > H = I - V**H * T * V */ +/* > */ +/* > Currently, only STOREV = 'R' and DIRECT = 'B' are supported. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] DIRECT */ +/* > \verbatim */ +/* > DIRECT is CHARACTER*1 */ +/* > Specifies the order in which the elementary reflectors are */ +/* > multiplied to form the block reflector: */ +/* > = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet) */ +/* > = 'B': H = H(k) . . . H(2) H(1) (Backward) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] STOREV */ +/* > \verbatim */ +/* > STOREV is CHARACTER*1 */ +/* > Specifies how the vectors which define the elementary */ +/* > reflectors are stored (see also Further Details): */ +/* > = 'C': columnwise (not supported yet) */ +/* > = 'R': rowwise */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the block reflector H. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The order of the triangular factor T (= the number of */ +/* > elementary reflectors). K >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] V */ +/* > \verbatim */ +/* > V is COMPLEX*16 array, dimension */ +/* > (LDV,K) if STOREV = 'C' */ +/* > (LDV,N) if STOREV = 'R' */ +/* > The matrix V. See further details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. */ +/* > If STOREV = 'C', LDV >= f2cmax(1,N); if STOREV = 'R', LDV >= K. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 array, dimension (K) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is COMPLEX*16 array, dimension (LDT,K) */ +/* > The k by k triangular factor T of the block reflector. */ +/* > If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */ +/* > lower triangular. The rest of the array is not used. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= K. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The shape of the matrix V and the storage of the vectors which define */ +/* > the H(i) is best illustrated by the following example with n = 5 and */ +/* > k = 3. The elements equal to 1 are not stored; the corresponding */ +/* > array elements are modified but restored on exit. The rest of the */ +/* > array is not used. */ +/* > */ +/* > DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */ +/* > */ +/* > ______V_____ */ +/* > ( v1 v2 v3 ) / \ */ +/* > ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 ) */ +/* > V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 ) */ +/* > ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 ) */ +/* > ( v1 v2 v3 ) */ +/* > . . . */ +/* > . . . */ +/* > 1 . . */ +/* > 1 . */ +/* > 1 */ +/* > */ +/* > DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */ +/* > */ +/* > ______V_____ */ +/* > 1 / \ */ +/* > . 1 ( 1 . . . . v1 v1 v1 v1 v1 ) */ +/* > . . 1 ( . 1 . . . v2 v2 v2 v2 v2 ) */ +/* > . . . ( . . 1 . . v3 v3 v3 v3 v3 ) */ +/* > . . . */ +/* > ( v1 v2 v3 ) */ +/* > ( v1 v2 v3 ) */ +/* > V = ( v1 v2 v3 ) */ +/* > ( v1 v2 v3 ) */ +/* > ( v1 v2 v3 ) */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlarzt_(char *direct, char *storev, integer *n, integer * + k, doublecomplex *v, integer *ldv, doublecomplex *tau, doublecomplex * + t, integer *ldt) +{ + /* System generated locals */ + integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2; + doublecomplex z__1; + + /* Local variables */ + integer info, i__, j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *), + ztrmv_(char *, char *, char *, integer *, doublecomplex *, + integer *, doublecomplex *, integer *), + xerbla_(char *, integer *, ftnlen), zlacgv_(integer *, + doublecomplex *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Check for currently supported options */ + + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + --tau; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + + /* Function Body */ + info = 0; + if (! lsame_(direct, "B")) { + info = -1; + } else if (! lsame_(storev, "R")) { + info = -2; + } + if (info != 0) { + i__1 = -info; + xerbla_("ZLARZT", &i__1, (ftnlen)6); + return 0; + } + + for (i__ = *k; i__ >= 1; --i__) { + i__1 = i__; + if (tau[i__1].r == 0. && tau[i__1].i == 0.) { + +/* H(i) = I */ + + i__1 = *k; + for (j = i__; j <= i__1; ++j) { + i__2 = j + i__ * t_dim1; + t[i__2].r = 0., t[i__2].i = 0.; +/* L10: */ + } + } else { + +/* general case */ + + if (i__ < *k) { + +/* T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)**H */ + + zlacgv_(n, &v[i__ + v_dim1], ldv); + i__1 = *k - i__; + i__2 = i__; + z__1.r = -tau[i__2].r, z__1.i = -tau[i__2].i; + zgemv_("No transpose", &i__1, n, &z__1, &v[i__ + 1 + v_dim1], + ldv, &v[i__ + v_dim1], ldv, &c_b1, &t[i__ + 1 + i__ * + t_dim1], &c__1); + zlacgv_(n, &v[i__ + v_dim1], ldv); + +/* T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i) */ + + i__1 = *k - i__; + ztrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ + 1 + + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * t_dim1] + , &c__1); + } + i__1 = i__ + i__ * t_dim1; + i__2 = i__; + t[i__1].r = tau[i__2].r, t[i__1].i = tau[i__2].i; + } +/* L20: */ + } + return 0; + +/* End of ZLARZT */ + +} /* zlarzt_ */ + diff --git a/lapack-netlib/SRC/zlascl.c b/lapack-netlib/SRC/zlascl.c new file mode 100644 index 000000000..02d8a7b19 --- /dev/null +++ b/lapack-netlib/SRC/zlascl.c @@ -0,0 +1,818 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLASCL + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) */ + +/* CHARACTER TYPE */ +/* INTEGER INFO, KL, KU, LDA, M, N */ +/* DOUBLE PRECISION CFROM, CTO */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLASCL multiplies the M by N complex matrix A by the real scalar */ +/* > CTO/CFROM. This is done without over/underflow as long as the final */ +/* > result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that */ +/* > A may be full, upper triangular, lower triangular, upper Hessenberg, */ +/* > or banded. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TYPE */ +/* > \verbatim */ +/* > TYPE is CHARACTER*1 */ +/* > TYPE indices the storage type of the input matrix. */ +/* > = 'G': A is a full matrix. */ +/* > = 'L': A is a lower triangular matrix. */ +/* > = 'U': A is an upper triangular matrix. */ +/* > = 'H': A is an upper Hessenberg matrix. */ +/* > = 'B': A is a symmetric band matrix with lower bandwidth KL */ +/* > and upper bandwidth KU and with the only the lower */ +/* > half stored. */ +/* > = 'Q': A is a symmetric band matrix with lower bandwidth KL */ +/* > and upper bandwidth KU and with the only the upper */ +/* > half stored. */ +/* > = 'Z': A is a band matrix with lower bandwidth KL and upper */ +/* > bandwidth KU. See ZGBTRF for storage details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The lower bandwidth of A. Referenced only if TYPE = 'B', */ +/* > 'Q' or 'Z'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The upper bandwidth of A. Referenced only if TYPE = 'B', */ +/* > 'Q' or 'Z'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CFROM */ +/* > \verbatim */ +/* > CFROM is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CTO */ +/* > \verbatim */ +/* > CTO is DOUBLE PRECISION */ +/* > */ +/* > The matrix A is multiplied by CTO/CFROM. A(I,J) is computed */ +/* > without over/underflow if the final result CTO*A(I,J)/CFROM */ +/* > can be represented without over/underflow. CFROM must be */ +/* > nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > The matrix to be multiplied by CTO/CFROM. See TYPE for the */ +/* > storage type. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > If TYPE = 'G', 'L', 'U', 'H', LDA >= f2cmax(1,M); */ +/* > TYPE = 'B', LDA >= KL+1; */ +/* > TYPE = 'Q', LDA >= KU+1; */ +/* > TYPE = 'Z', LDA >= 2*KL+KU+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 June 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlascl_(char *type__, integer *kl, integer *ku, + doublereal *cfrom, doublereal *cto, integer *m, integer *n, + doublecomplex *a, integer *lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1; + + /* Local variables */ + logical done; + doublereal ctoc; + integer i__, j; + extern logical lsame_(char *, char *); + integer itype, k1, k2, k3, k4; + doublereal cfrom1; + extern doublereal dlamch_(char *); + doublereal cfromc; + extern logical disnan_(doublereal *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum, smlnum, mul, cto1; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + *info = 0; + + if (lsame_(type__, "G")) { + itype = 0; + } else if (lsame_(type__, "L")) { + itype = 1; + } else if (lsame_(type__, "U")) { + itype = 2; + } else if (lsame_(type__, "H")) { + itype = 3; + } else if (lsame_(type__, "B")) { + itype = 4; + } else if (lsame_(type__, "Q")) { + itype = 5; + } else if (lsame_(type__, "Z")) { + itype = 6; + } else { + itype = -1; + } + + if (itype == -1) { + *info = -1; + } else if (*cfrom == 0. || disnan_(cfrom)) { + *info = -4; + } else if (disnan_(cto)) { + *info = -5; + } else if (*m < 0) { + *info = -6; + } else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) { + *info = -7; + } else if (itype <= 3 && *lda < f2cmax(1,*m)) { + *info = -9; + } else if (itype >= 4) { +/* Computing MAX */ + i__1 = *m - 1; + if (*kl < 0 || *kl > f2cmax(i__1,0)) { + *info = -2; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = *n - 1; + if (*ku < 0 || *ku > f2cmax(i__1,0) || (itype == 4 || itype == 5) && + *kl != *ku) { + *info = -3; + } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < * + ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) { + *info = -9; + } + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLASCL", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *m == 0) { + return 0; + } + +/* Get machine parameters */ + + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + + cfromc = *cfrom; + ctoc = *cto; + +L10: + cfrom1 = cfromc * smlnum; + if (cfrom1 == cfromc) { +/* CFROMC is an inf. Multiply by a correctly signed zero for */ +/* finite CTOC, or a NaN if CTOC is infinite. */ + mul = ctoc / cfromc; + done = TRUE_; + cto1 = ctoc; + } else { + cto1 = ctoc / bignum; + if (cto1 == ctoc) { +/* CTOC is either 0 or an inf. In both cases, CTOC itself */ +/* serves as the correct multiplication factor. */ + mul = ctoc; + done = TRUE_; + cfromc = 1.; + } else if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) { + mul = smlnum; + done = FALSE_; + cfromc = cfrom1; + } else if (abs(cto1) > abs(cfromc)) { + mul = bignum; + done = FALSE_; + ctoc = cto1; + } else { + mul = ctoc / cfromc; + done = TRUE_; + } + } + + if (itype == 0) { + +/* Full matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L20: */ + } +/* L30: */ + } + + } else if (itype == 1) { + +/* Lower triangular matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L40: */ + } +/* L50: */ + } + + } else if (itype == 2) { + +/* Upper triangular matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = f2cmin(j,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L60: */ + } +/* L70: */ + } + + } else if (itype == 3) { + +/* Upper Hessenberg matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = j + 1; + i__2 = f2cmin(i__3,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L80: */ + } +/* L90: */ + } + + } else if (itype == 4) { + +/* Lower half of a symmetric band matrix */ + + k3 = *kl + 1; + k4 = *n + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = k3, i__4 = k4 - j; + i__2 = f2cmin(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L100: */ + } +/* L110: */ + } + + } else if (itype == 5) { + +/* Upper half of a symmetric band matrix */ + + k1 = *ku + 2; + k3 = *ku + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = k1 - j; + i__3 = k3; + for (i__ = f2cmax(i__2,1); i__ <= i__3; ++i__) { + i__2 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L120: */ + } +/* L130: */ + } + + } else if (itype == 6) { + +/* Band matrix */ + + k1 = *kl + *ku + 2; + k2 = *kl + 1; + k3 = (*kl << 1) + *ku + 1; + k4 = *kl + *ku + 1 + *m; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__3 = k1 - j; +/* Computing MIN */ + i__4 = k3, i__5 = k4 - j; + i__2 = f2cmin(i__4,i__5); + for (i__ = f2cmax(i__3,k2); i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + z__1.r = mul * a[i__4].r, z__1.i = mul * a[i__4].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L140: */ + } +/* L150: */ + } + + } + + if (! done) { + goto L10; + } + + return 0; + +/* End of ZLASCL */ + +} /* zlascl_ */ + diff --git a/lapack-netlib/SRC/zlascl2.c b/lapack-netlib/SRC/zlascl2.c new file mode 100644 index 000000000..ee9c292f1 --- /dev/null +++ b/lapack-netlib/SRC/zlascl2.c @@ -0,0 +1,519 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLASCL2 performs diagonal scaling on a vector. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLASCL2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLASCL2 ( M, N, D, X, LDX ) */ + +/* INTEGER M, N, LDX */ +/* DOUBLE PRECISION D( * ) */ +/* COMPLEX*16 X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLASCL2 performs a diagonal scaling on a vector: */ +/* > x <-- D * x */ +/* > where the DOUBLE PRECISION diagonal matrix D is stored as a vector. */ +/* > */ +/* > Eventually to be replaced by BLAS_zge_diag_scale in the new BLAS */ +/* > standard. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of D and X. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of X. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, length M */ +/* > Diagonal matrix D, stored as a vector of length M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (LDX,N) */ +/* > On entry, the vector X to be scaled by D. */ +/* > On exit, the scaled vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the vector X. LDX >= M. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16OTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zlascl2_(integer *m, integer *n, doublereal *d__, + doublecomplex *x, integer *ldx) +{ + /* System generated locals */ + integer x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1; + + /* Local variables */ + integer i__, j; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --d__; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + + /* Function Body */ + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * x_dim1; + i__4 = i__ + j * x_dim1; + i__5 = i__; + z__1.r = d__[i__5] * x[i__4].r, z__1.i = d__[i__5] * x[i__4].i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + } + } + return 0; +} /* zlascl2_ */ + diff --git a/lapack-netlib/SRC/zlaset.c b/lapack-netlib/SRC/zlaset.c new file mode 100644 index 000000000..9f99ec191 --- /dev/null +++ b/lapack-netlib/SRC/zlaset.c @@ -0,0 +1,596 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given val +ues. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLASET + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) */ + +/* CHARACTER UPLO */ +/* INTEGER LDA, M, N */ +/* COMPLEX*16 ALPHA, BETA */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLASET initializes a 2-D array A to BETA on the diagonal and */ +/* > ALPHA on the offdiagonals. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies the part of the matrix A to be set. */ +/* > = 'U': Upper triangular part is set. The lower triangle */ +/* > is unchanged. */ +/* > = 'L': Lower triangular part is set. The upper triangle */ +/* > is unchanged. */ +/* > Otherwise: All of the matrix A is set. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > On entry, M specifies the number of rows of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > On entry, N specifies the number of columns of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is COMPLEX*16 */ +/* > All the offdiagonal array elements are set to ALPHA. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BETA */ +/* > \verbatim */ +/* > BETA is COMPLEX*16 */ +/* > All the diagonal array elements are set to BETA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the m by n matrix A. */ +/* > On exit, A(i,j) = ALPHA, 1 <= i <= m, 1 <= j <= n, i.ne.j; */ +/* > A(i,i) = BETA , 1 <= i <= f2cmin(m,n) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlaset_(char *uplo, integer *m, integer *n, + doublecomplex *alpha, doublecomplex *beta, doublecomplex *a, integer * + lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + + +/* -- 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 */ + if (lsame_(uplo, "U")) { + +/* Set the diagonal to BETA and the strictly upper triangular */ +/* part of the array to ALPHA. */ + + i__1 = *n; + for (j = 2; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = j - 1; + i__2 = f2cmin(i__3,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = alpha->r, a[i__3].i = alpha->i; +/* L10: */ + } +/* L20: */ + } + i__1 = f2cmin(*n,*m); + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + a[i__2].r = beta->r, a[i__2].i = beta->i; +/* L30: */ + } + + } else if (lsame_(uplo, "L")) { + +/* Set the diagonal to BETA and the strictly lower triangular */ +/* part of the array to ALPHA. */ + + i__1 = f2cmin(*m,*n); + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = alpha->r, a[i__3].i = alpha->i; +/* L40: */ + } +/* L50: */ + } + i__1 = f2cmin(*n,*m); + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + a[i__2].r = beta->r, a[i__2].i = beta->i; +/* L60: */ + } + + } else { + +/* Set the array to BETA on the diagonal and ALPHA on the */ +/* offdiagonal. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + a[i__3].r = alpha->r, a[i__3].i = alpha->i; +/* L70: */ + } +/* L80: */ + } + i__1 = f2cmin(*m,*n); + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + i__ * a_dim1; + a[i__2].r = beta->r, a[i__2].i = beta->i; +/* L90: */ + } + } + + return 0; + +/* End of ZLASET */ + +} /* zlaset_ */ + diff --git a/lapack-netlib/SRC/zlasr.c b/lapack-netlib/SRC/zlasr.c new file mode 100644 index 000000000..6275b3643 --- /dev/null +++ b/lapack-netlib/SRC/zlasr.c @@ -0,0 +1,1045 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLASR applies a sequence of plane rotations to a general rectangular matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLASR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) */ + +/* CHARACTER DIRECT, PIVOT, SIDE */ +/* INTEGER LDA, M, N */ +/* DOUBLE PRECISION C( * ), S( * ) */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLASR applies a sequence of real plane rotations to a complex matrix */ +/* > A, from either the left or the right. */ +/* > */ +/* > When SIDE = 'L', the transformation takes the form */ +/* > */ +/* > A := P*A */ +/* > */ +/* > and when SIDE = 'R', the transformation takes the form */ +/* > */ +/* > A := A*P**T */ +/* > */ +/* > where P is an orthogonal matrix consisting of a sequence of z plane */ +/* > rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', */ +/* > and P**T is the transpose of P. */ +/* > */ +/* > When DIRECT = 'F' (Forward sequence), then */ +/* > */ +/* > P = P(z-1) * ... * P(2) * P(1) */ +/* > */ +/* > and when DIRECT = 'B' (Backward sequence), then */ +/* > */ +/* > P = P(1) * P(2) * ... * P(z-1) */ +/* > */ +/* > where P(k) is a plane rotation matrix defined by the 2-by-2 rotation */ +/* > */ +/* > R(k) = ( c(k) s(k) ) */ +/* > = ( -s(k) c(k) ). */ +/* > */ +/* > When PIVOT = 'V' (Variable pivot), the rotation is performed */ +/* > for the plane (k,k+1), i.e., P(k) has the form */ +/* > */ +/* > P(k) = ( 1 ) */ +/* > ( ... ) */ +/* > ( 1 ) */ +/* > ( c(k) s(k) ) */ +/* > ( -s(k) c(k) ) */ +/* > ( 1 ) */ +/* > ( ... ) */ +/* > ( 1 ) */ +/* > */ +/* > where R(k) appears as a rank-2 modification to the identity matrix in */ +/* > rows and columns k and k+1. */ +/* > */ +/* > When PIVOT = 'T' (Top pivot), the rotation is performed for the */ +/* > plane (1,k+1), so P(k) has the form */ +/* > */ +/* > P(k) = ( c(k) s(k) ) */ +/* > ( 1 ) */ +/* > ( ... ) */ +/* > ( 1 ) */ +/* > ( -s(k) c(k) ) */ +/* > ( 1 ) */ +/* > ( ... ) */ +/* > ( 1 ) */ +/* > */ +/* > where R(k) appears in rows and columns 1 and k+1. */ +/* > */ +/* > Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is */ +/* > performed for the plane (k,z), giving P(k) the form */ +/* > */ +/* > P(k) = ( 1 ) */ +/* > ( ... ) */ +/* > ( 1 ) */ +/* > ( c(k) s(k) ) */ +/* > ( 1 ) */ +/* > ( ... ) */ +/* > ( 1 ) */ +/* > ( -s(k) c(k) ) */ +/* > */ +/* > where R(k) appears in rows and columns k and z. The rotations are */ +/* > performed without ever forming P(k) explicitly. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > Specifies whether the plane rotation matrix P is applied to */ +/* > A on the left or the right. */ +/* > = 'L': Left, compute A := P*A */ +/* > = 'R': Right, compute A:= A*P**T */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PIVOT */ +/* > \verbatim */ +/* > PIVOT is CHARACTER*1 */ +/* > Specifies the plane for which P(k) is a plane rotation */ +/* > matrix. */ +/* > = 'V': Variable pivot, the plane (k,k+1) */ +/* > = 'T': Top pivot, the plane (1,k+1) */ +/* > = 'B': Bottom pivot, the plane (k,z) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIRECT */ +/* > \verbatim */ +/* > DIRECT is CHARACTER*1 */ +/* > Specifies whether P is a forward or backward sequence of */ +/* > plane rotations. */ +/* > = 'F': Forward, P = P(z-1)*...*P(2)*P(1) */ +/* > = 'B': Backward, P = P(1)*P(2)*...*P(z-1) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. If m <= 1, an immediate */ +/* > return is effected. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. If n <= 1, an */ +/* > immediate return is effected. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension */ +/* > (M-1) if SIDE = 'L' */ +/* > (N-1) if SIDE = 'R' */ +/* > The cosines c(k) of the plane rotations. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is DOUBLE PRECISION array, dimension */ +/* > (M-1) if SIDE = 'L' */ +/* > (N-1) if SIDE = 'R' */ +/* > The sines s(k) of the plane rotations. The 2-by-2 plane */ +/* > rotation part of the matrix P(k), R(k), has the form */ +/* > R(k) = ( c(k) s(k) ) */ +/* > ( -s(k) c(k) ). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > The M-by-N matrix A. On exit, A is overwritten by P*A if */ +/* > SIDE = 'R' or by A*P**T if SIDE = 'L'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlasr_(char *side, char *pivot, char *direct, integer *m, + integer *n, doublereal *c__, doublereal *s, doublecomplex *a, + integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + integer info; + doublecomplex temp; + integer i__, j; + extern logical lsame_(char *, char *); + doublereal ctemp, stemp; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + --c__; + --s; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + info = 0; + if (! (lsame_(side, "L") || lsame_(side, "R"))) { + info = 1; + } else if (! (lsame_(pivot, "V") || lsame_(pivot, + "T") || lsame_(pivot, "B"))) { + info = 2; + } else if (! (lsame_(direct, "F") || lsame_(direct, + "B"))) { + info = 3; + } else if (*m < 0) { + info = 4; + } else if (*n < 0) { + info = 5; + } else if (*lda < f2cmax(1,*m)) { + info = 9; + } + if (info != 0) { + xerbla_("ZLASR ", &info, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + if (lsame_(side, "L")) { + +/* Form P * A */ + + if (lsame_(pivot, "V")) { + if (lsame_(direct, "F")) { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = j + 1 + i__ * a_dim1; + temp.r = a[i__3].r, temp.i = a[i__3].i; + i__3 = j + 1 + i__ * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__4 = j + i__ * a_dim1; + z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[ + i__4].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = j + i__ * a_dim1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__4 = j + i__ * a_dim1; + z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[ + i__4].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L10: */ + } + } +/* L20: */ + } + } else if (lsame_(direct, "B")) { + for (j = *m - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = j + 1 + i__ * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = j + 1 + i__ * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__3 = j + i__ * a_dim1; + z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[ + i__3].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + i__ * a_dim1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__3 = j + i__ * a_dim1; + z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[ + i__3].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L30: */ + } + } +/* L40: */ + } + } + } else if (lsame_(pivot, "T")) { + if (lsame_(direct, "F")) { + i__1 = *m; + for (j = 2; j <= i__1; ++j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = j + i__ * a_dim1; + temp.r = a[i__3].r, temp.i = a[i__3].i; + i__3 = j + i__ * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__4 = i__ * a_dim1 + 1; + z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[ + i__4].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = i__ * a_dim1 + 1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__4 = i__ * a_dim1 + 1; + z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[ + i__4].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L50: */ + } + } +/* L60: */ + } + } else if (lsame_(direct, "B")) { + for (j = *m; j >= 2; --j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = j + i__ * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = j + i__ * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__3 = i__ * a_dim1 + 1; + z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[ + i__3].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = i__ * a_dim1 + 1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__3 = i__ * a_dim1 + 1; + z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[ + i__3].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L70: */ + } + } +/* L80: */ + } + } + } else if (lsame_(pivot, "B")) { + if (lsame_(direct, "F")) { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = j + i__ * a_dim1; + temp.r = a[i__3].r, temp.i = a[i__3].i; + i__3 = j + i__ * a_dim1; + i__4 = *m + i__ * a_dim1; + z__2.r = stemp * a[i__4].r, z__2.i = stemp * a[ + i__4].i; + z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = *m + i__ * a_dim1; + i__4 = *m + i__ * a_dim1; + z__2.r = ctemp * a[i__4].r, z__2.i = ctemp * a[ + i__4].i; + z__3.r = stemp * temp.r, z__3.i = stemp * temp.i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L90: */ + } + } +/* L100: */ + } + } else if (lsame_(direct, "B")) { + for (j = *m - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = j + i__ * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = j + i__ * a_dim1; + i__3 = *m + i__ * a_dim1; + z__2.r = stemp * a[i__3].r, z__2.i = stemp * a[ + i__3].i; + z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = *m + i__ * a_dim1; + i__3 = *m + i__ * a_dim1; + z__2.r = ctemp * a[i__3].r, z__2.i = ctemp * a[ + i__3].i; + z__3.r = stemp * temp.r, z__3.i = stemp * temp.i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L110: */ + } + } +/* L120: */ + } + } + } + } else if (lsame_(side, "R")) { + +/* Form A * P**T */ + + if (lsame_(pivot, "V")) { + if (lsame_(direct, "F")) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j + 1) * a_dim1; + temp.r = a[i__3].r, temp.i = a[i__3].i; + i__3 = i__ + (j + 1) * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__4 = i__ + j * a_dim1; + z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[ + i__4].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = i__ + j * a_dim1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__4 = i__ + j * a_dim1; + z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[ + i__4].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L130: */ + } + } +/* L140: */ + } + } else if (lsame_(direct, "B")) { + for (j = *n - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + (j + 1) * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = i__ + (j + 1) * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__3 = i__ + j * a_dim1; + z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[ + i__3].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = i__ + j * a_dim1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__3 = i__ + j * a_dim1; + z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[ + i__3].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L150: */ + } + } +/* L160: */ + } + } + } else if (lsame_(pivot, "T")) { + if (lsame_(direct, "F")) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + temp.r = a[i__3].r, temp.i = a[i__3].i; + i__3 = i__ + j * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__4 = i__ + a_dim1; + z__3.r = stemp * a[i__4].r, z__3.i = stemp * a[ + i__4].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = i__ + a_dim1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__4 = i__ + a_dim1; + z__3.r = ctemp * a[i__4].r, z__3.i = ctemp * a[ + i__4].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L170: */ + } + } +/* L180: */ + } + } else if (lsame_(direct, "B")) { + for (j = *n; j >= 2; --j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + j * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = i__ + j * a_dim1; + z__2.r = ctemp * temp.r, z__2.i = ctemp * temp.i; + i__3 = i__ + a_dim1; + z__3.r = stemp * a[i__3].r, z__3.i = stemp * a[ + i__3].i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = i__ + a_dim1; + z__2.r = stemp * temp.r, z__2.i = stemp * temp.i; + i__3 = i__ + a_dim1; + z__3.r = ctemp * a[i__3].r, z__3.i = ctemp * a[ + i__3].i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L190: */ + } + } +/* L200: */ + } + } + } else if (lsame_(pivot, "B")) { + if (lsame_(direct, "F")) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + temp.r = a[i__3].r, temp.i = a[i__3].i; + i__3 = i__ + j * a_dim1; + i__4 = i__ + *n * a_dim1; + z__2.r = stemp * a[i__4].r, z__2.i = stemp * a[ + i__4].i; + z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = i__ + *n * a_dim1; + i__4 = i__ + *n * a_dim1; + z__2.r = ctemp * a[i__4].r, z__2.i = ctemp * a[ + i__4].i; + z__3.r = stemp * temp.r, z__3.i = stemp * temp.i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; +/* L210: */ + } + } +/* L220: */ + } + } else if (lsame_(direct, "B")) { + for (j = *n - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1. || stemp != 0.) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + j * a_dim1; + temp.r = a[i__2].r, temp.i = a[i__2].i; + i__2 = i__ + j * a_dim1; + i__3 = i__ + *n * a_dim1; + z__2.r = stemp * a[i__3].r, z__2.i = stemp * a[ + i__3].i; + z__3.r = ctemp * temp.r, z__3.i = ctemp * temp.i; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = i__ + *n * a_dim1; + i__3 = i__ + *n * a_dim1; + z__2.r = ctemp * a[i__3].r, z__2.i = ctemp * a[ + i__3].i; + z__3.r = stemp * temp.r, z__3.i = stemp * temp.i; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - + z__3.i; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L230: */ + } + } +/* L240: */ + } + } + } + } + + return 0; + +/* End of ZLASR */ + +} /* zlasr_ */ + diff --git a/lapack-netlib/SRC/zlassq.c b/lapack-netlib/SRC/zlassq.c new file mode 100644 index 000000000..1bb5b67d7 --- /dev/null +++ b/lapack-netlib/SRC/zlassq.c @@ -0,0 +1,560 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLASSQ updates a sum of squares represented in scaled form. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLASSQ + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLASSQ( N, X, INCX, SCALE, SUMSQ ) */ + +/* INTEGER INCX, N */ +/* DOUBLE PRECISION SCALE, SUMSQ */ +/* COMPLEX*16 X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLASSQ returns the values scl and ssq such that */ +/* > */ +/* > ( scl**2 )*ssq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, */ +/* > */ +/* > where x( i ) = abs( X( 1 + ( i - 1 )*INCX ) ). The value of sumsq is */ +/* > assumed to be at least unity and the value of ssq will then satisfy */ +/* > */ +/* > 1.0 <= ssq <= ( sumsq + 2*n ). */ +/* > */ +/* > scale is assumed to be non-negative and scl returns the value */ +/* > */ +/* > scl = f2cmax( scale, abs( real( x( i ) ) ), abs( aimag( x( i ) ) ) ), */ +/* > i */ +/* > */ +/* > scale and sumsq must be supplied in SCALE and SUMSQ respectively. */ +/* > SCALE and SUMSQ are overwritten by scl and ssq respectively. */ +/* > */ +/* > The routine makes only one pass through the vector X. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of elements to be used from the vector X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (1+(N-1)*INCX) */ +/* > The vector x as described above. */ +/* > x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The increment between successive values of the vector X. */ +/* > INCX > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] SCALE */ +/* > \verbatim */ +/* > SCALE is DOUBLE PRECISION */ +/* > On entry, the value scale in the equation above. */ +/* > On exit, SCALE is overwritten with the value scl . */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] SUMSQ */ +/* > \verbatim */ +/* > SUMSQ is DOUBLE PRECISION */ +/* > On entry, the value sumsq in the equation above. */ +/* > On exit, SUMSQ is overwritten with the value ssq . */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlassq_(integer *n, doublecomplex *x, integer *incx, + doublereal *scale, doublereal *sumsq) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + doublereal d__1; + + /* Local variables */ + doublereal temp1; + integer ix; + extern logical disnan_(doublereal *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --x; + + /* Function Body */ + if (*n > 0) { + i__1 = (*n - 1) * *incx + 1; + i__2 = *incx; + for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { + i__3 = ix; + temp1 = (d__1 = x[i__3].r, abs(d__1)); + if (temp1 > 0. || disnan_(&temp1)) { + if (*scale < temp1) { +/* Computing 2nd power */ + d__1 = *scale / temp1; + *sumsq = *sumsq * (d__1 * d__1) + 1; + *scale = temp1; + } else { +/* Computing 2nd power */ + d__1 = temp1 / *scale; + *sumsq += d__1 * d__1; + } + } + temp1 = (d__1 = d_imag(&x[ix]), abs(d__1)); + if (temp1 > 0. || disnan_(&temp1)) { + if (*scale < temp1) { +/* Computing 2nd power */ + d__1 = *scale / temp1; + *sumsq = *sumsq * (d__1 * d__1) + 1; + *scale = temp1; + } else { +/* Computing 2nd power */ + d__1 = temp1 / *scale; + *sumsq += d__1 * d__1; + } + } +/* L10: */ + } + } + + return 0; + +/* End of ZLASSQ */ + +} /* zlassq_ */ + diff --git a/lapack-netlib/SRC/zlaswlq.c b/lapack-netlib/SRC/zlaswlq.c new file mode 100644 index 000000000..66e56cb30 --- /dev/null +++ b/lapack-netlib/SRC/zlaswlq.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 +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLASWLQ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, */ +/* LWORK, INFO) */ + +/* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK */ +/* COMPLEX*16 A( LDA, * ), T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLASWLQ computes a blocked Tall-Skinny LQ factorization of */ +/* > a complexx M-by-N matrix A for M <= N: */ +/* > */ +/* > A = ( L 0 ) * Q, */ +/* > */ +/* > where: */ +/* > */ +/* > Q is a n-by-N orthogonal matrix, stored on exit in an implicit */ +/* > form in the elements above the digonal of the array A and in */ +/* > the elemenst of the array T; */ +/* > L is an lower-triangular M-by-M matrix stored on exit in */ +/* > the elements on and below the diagonal of the array A. */ +/* > 0 is a M-by-(N-M) zero matrix, if M < N, and is not stored. */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MB */ +/* > \verbatim */ +/* > MB is INTEGER */ +/* > The row block size to be used in the blocked QR. */ +/* > M >= MB >= 1 */ +/* > \endverbatim */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The column block size to be used in the blocked QR. */ +/* > NB > M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, the elements on and below the diagonal */ +/* > of the array contain the N-by-N lower triangular matrix L; */ +/* > the elements above the diagonal represent Q by the rows */ +/* > of blocked V (see Further Details). */ +/* > */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is COMPLEX*16 array, */ +/* > dimension (LDT, N * Number_of_row_blocks) */ +/* > where Number_of_row_blocks = CEIL((N-M)/(NB-M)) */ +/* > The blocked upper triangular block reflectors stored in compact form */ +/* > as a sequence of upper triangular blocks. */ +/* > See Further Details below. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= MB. */ +/* > \endverbatim */ +/* > */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > */ +/* > \endverbatim */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > The dimension of the array WORK. LWORK >= MB*M. */ +/* > 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. */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations, */ +/* > representing Q as a product of other orthogonal matrices */ +/* > Q = Q(1) * Q(2) * . . . * Q(k) */ +/* > where each Q(i) zeros out upper diagonal entries of a block of NB rows of A: */ +/* > Q(1) zeros out the upper diagonal entries of rows 1:NB of A */ +/* > Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A */ +/* > Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A */ +/* > . . . */ +/* > */ +/* > Q(1) is computed by GELQT, which represents Q(1) by Householder vectors */ +/* > stored under the diagonal of rows 1:MB of A, and by upper triangular */ +/* > block reflectors, stored in array T(1:LDT,1:N). */ +/* > For more information see Further Details in GELQT. */ +/* > */ +/* > Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors */ +/* > stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular */ +/* > block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M). */ +/* > The last Q(k) may use fewer rows. */ +/* > For more information see Further Details in TPQRT. */ +/* > */ +/* > For more details of the overall algorithm, see the description of */ +/* > Sequential TSQR in Section 2.2 of [1]. */ +/* > */ +/* > [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations, */ +/* > J. Demmel, L. Grigori, M. Hoemmen, J. Langou, */ +/* > SIAM J. Sci. Comput, vol. 34, no. 1, 2012 */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlaswlq_(integer *m, integer *n, integer *mb, integer * + nb, doublecomplex *a, integer *lda, doublecomplex *t, integer *ldt, + doublecomplex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, t_dim1, t_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, ii, kk; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zgelqt_( + integer *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + logical lquery; + extern /* Subroutine */ int ztplqt_(integer *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + integer ctr; + + +/* -- LAPACK computational routine (version 3.9.0) -- */ +/* -- 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 ARGUMENTS */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + --work; + + /* Function Body */ + *info = 0; + + lquery = *lwork == -1; + + if (*m < 0) { + *info = -1; + } else if (*n < 0 || *n < *m) { + *info = -2; + } else if (*mb < 1 || *mb > *m && *m > 0) { + *info = -3; + } else if (*nb <= *m) { + *info = -4; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } else if (*ldt < *mb) { + *info = -8; + } else if (*lwork < *m * *mb && ! lquery) { + *info = -10; + } + if (*info == 0) { + i__1 = *mb * *m; + work[1].r = (doublereal) i__1, work[1].i = 0.; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLASWLQ", &i__1, (ftnlen)7); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (f2cmin(*m,*n) == 0) { + return 0; + } + +/* The LQ Decomposition */ + + if (*m >= *n || *nb <= *m || *nb >= *n) { + zgelqt_(m, n, mb, &a[a_offset], lda, &t[t_offset], ldt, &work[1], + info); + return 0; + } + + kk = (*n - *m) % (*nb - *m); + ii = *n - kk + 1; + +/* Compute the LQ factorization of the first block A(1:M,1:NB) */ + + zgelqt_(m, nb, mb, &a[a_dim1 + 1], lda, &t[t_offset], ldt, &work[1], info) + ; + ctr = 1; + + i__1 = ii - *nb + *m; + i__2 = *nb - *m; + for (i__ = *nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + +/* Compute the QR factorization of the current block A(1:M,I:I+NB-M) */ + + i__3 = *nb - *m; + ztplqt_(m, &i__3, &c__0, mb, &a[a_dim1 + 1], lda, &a[i__ * a_dim1 + 1] + , lda, &t[(ctr * *m + 1) * t_dim1 + 1], ldt, &work[1], info); + ++ctr; + } + +/* Compute the QR factorization of the last block A(1:M,II:N) */ + + if (ii <= *n) { + ztplqt_(m, &kk, &c__0, mb, &a[a_dim1 + 1], lda, &a[ii * a_dim1 + 1], + lda, &t[(ctr * *m + 1) * t_dim1 + 1], ldt, &work[1], info); + } + + i__2 = *m * *mb; + work[1].r = (doublereal) i__2, work[1].i = 0.; + return 0; + +/* End of ZLASWLQ */ + +} /* zlaswlq_ */ + diff --git a/lapack-netlib/SRC/zlaswp.c b/lapack-netlib/SRC/zlaswp.c new file mode 100644 index 000000000..cc9cf2943 --- /dev/null +++ b/lapack-netlib/SRC/zlaswp.c @@ -0,0 +1,606 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLASWP performs a series of row interchanges on a general rectangular matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLASWP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLASWP( N, A, LDA, K1, K2, IPIV, INCX ) */ + +/* INTEGER INCX, K1, K2, LDA, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLASWP performs a series of row interchanges on the matrix A. */ +/* > One row interchange is initiated for each of rows K1 through K2 of A. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the matrix of column dimension N to which the row */ +/* > interchanges will be applied. */ +/* > On exit, the permuted matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K1 */ +/* > \verbatim */ +/* > K1 is INTEGER */ +/* > The first element of IPIV for which a row interchange will */ +/* > be done. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K2 */ +/* > \verbatim */ +/* > K2 is INTEGER */ +/* > (K2-K1+1) is the number of elements of IPIV for which a row */ +/* > interchange will be done. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (K1+(K2-K1)*abs(INCX)) */ +/* > The vector of pivot indices. Only the elements in positions */ +/* > K1 through K1+(K2-K1)*abs(INCX) of IPIV are accessed. */ +/* > IPIV(K1+(K-K1)*abs(INCX)) = L implies rows K and L are to be */ +/* > interchanged. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The increment between successive values of IPIV. If INCX */ +/* > is negative, the pivots are applied in reverse order. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Modified by */ +/* > R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlaswp_(integer *n, doublecomplex *a, integer *lda, + integer *k1, integer *k2, integer *ipiv, integer *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6; + + /* Local variables */ + doublecomplex temp; + integer i__, j, k, i1, i2, n32, ip, ix, ix0, inc; + + +/* -- LAPACK auxiliary 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 */ + + +/* ===================================================================== */ + + +/* Interchange row I with row IPIV(K1+(I-K1)*abs(INCX)) for each of rows */ +/* K1 through K2. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + + /* Function Body */ + if (*incx > 0) { + ix0 = *k1; + i1 = *k1; + i2 = *k2; + inc = 1; + } else if (*incx < 0) { + ix0 = *k1 + (*k1 - *k2) * *incx; + i1 = *k2; + i2 = *k1; + inc = -1; + } else { + return 0; + } + + n32 = *n / 32 << 5; + if (n32 != 0) { + i__1 = n32; + for (j = 1; j <= i__1; j += 32) { + ix = ix0; + i__2 = i2; + i__3 = inc; + for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) + { + ip = ipiv[ix]; + if (ip != i__) { + i__4 = j + 31; + for (k = j; k <= i__4; ++k) { + i__5 = i__ + k * a_dim1; + temp.r = a[i__5].r, temp.i = a[i__5].i; + i__5 = i__ + k * a_dim1; + i__6 = ip + k * a_dim1; + a[i__5].r = a[i__6].r, a[i__5].i = a[i__6].i; + i__5 = ip + k * a_dim1; + a[i__5].r = temp.r, a[i__5].i = temp.i; +/* L10: */ + } + } + ix += *incx; +/* L20: */ + } +/* L30: */ + } + } + if (n32 != *n) { + ++n32; + ix = ix0; + i__1 = i2; + i__3 = inc; + for (i__ = i1; i__3 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__3) { + ip = ipiv[ix]; + if (ip != i__) { + i__2 = *n; + for (k = n32; k <= i__2; ++k) { + i__4 = i__ + k * a_dim1; + temp.r = a[i__4].r, temp.i = a[i__4].i; + i__4 = i__ + k * a_dim1; + i__5 = ip + k * a_dim1; + a[i__4].r = a[i__5].r, a[i__4].i = a[i__5].i; + i__4 = ip + k * a_dim1; + a[i__4].r = temp.r, a[i__4].i = temp.i; +/* L40: */ + } + } + ix += *incx; +/* L50: */ + } + } + + return 0; + +/* End of ZLASWP */ + +} /* zlaswp_ */ + diff --git a/lapack-netlib/SRC/zlasyf.c b/lapack-netlib/SRC/zlasyf.c new file mode 100644 index 000000000..4c3e44609 --- /dev/null +++ b/lapack-netlib/SRC/zlasyf.c @@ -0,0 +1,1422 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLASYF computes a partial factorization of a complex symmetric matrix using the Bunch-Kaufman d +iagonal pivoting method. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLASYF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, KB, LDA, LDW, N, NB */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), W( LDW, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLASYF computes a partial factorization of a complex symmetric matrix */ +/* > A using the Bunch-Kaufman diagonal pivoting method. The partial */ +/* > factorization has the form: */ +/* > */ +/* > A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: */ +/* > ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) */ +/* > */ +/* > A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L' */ +/* > ( L21 I ) ( 0 A22 ) ( 0 I ) */ +/* > */ +/* > where the order of D is at most NB. The actual order is returned in */ +/* > the argument KB, and is either NB or NB-1, or N if N <= NB. */ +/* > Note that U**T denotes the transpose of U. */ +/* > */ +/* > ZLASYF is an auxiliary routine called by ZSYTRF. It uses blocked code */ +/* > (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or */ +/* > A22 (if UPLO = 'L'). */ +/* > \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] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The maximum number of columns of the matrix A that should be */ +/* > factored. NB should be at least 2 to allow for 2-by-2 pivot */ +/* > blocks. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] KB */ +/* > \verbatim */ +/* > KB is INTEGER */ +/* > The number of columns of A that were actually factored. */ +/* > KB is either NB-1 or NB, or N if N <= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 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, A contains details of the partial factorization. */ +/* > \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': */ +/* > Only the last KB elements of IPIV are set. */ +/* > */ +/* > 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) = 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': */ +/* > Only the first KB elements of IPIV are set. */ +/* > */ +/* > 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) = 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] W */ +/* > \verbatim */ +/* > W is COMPLEX*16 array, dimension (LDW,NB) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDW */ +/* > \verbatim */ +/* > LDW is INTEGER */ +/* > The leading dimension of the array W. LDW >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > > 0: if INFO = k, D(k,k) is exactly zero. The factorization */ +/* > has been completed, but the block diagonal matrix D is */ +/* > exactly singular. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2013 */ + +/* > \ingroup complex16SYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2013, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int zlasyf_(char *uplo, integer *n, integer *nb, integer *kb, + doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *w, + integer *ldw, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5; + doublereal d__1, d__2, d__3, d__4; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + integer imax, jmax, j, k; + doublecomplex t; + doublereal alpha; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *), zgemm_(char *, char *, integer *, + integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + integer kstep; + extern /* Subroutine */ int zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + doublecomplex r1; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zswap_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *); + doublecomplex d11, d21, d22; + integer jb, jj, kk, jp, kp; + doublereal absakk; + integer kw; + doublereal colmax; + extern integer izamax_(integer *, doublecomplex *, integer *); + doublereal rowmax; + integer kkw; + + +/* -- LAPACK computational routine (version 3.5.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2013 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1 * 1; + w -= w_offset; + + /* Function Body */ + *info = 0; + +/* Initialize ALPHA for use in choosing pivot block size. */ + + alpha = (sqrt(17.) + 1.) / 8.; + + if (lsame_(uplo, "U")) { + +/* Factorize the trailing columns of A using the upper triangle */ +/* of A and working backwards, and compute the matrix W = U12*D */ +/* for use in updating A11 */ + +/* K is the main loop index, decreasing from N in steps of 1 or 2 */ + +/* KW is the column of W which corresponds to column K of A */ + + k = *n; +L10: + kw = *nb + k - *n; + +/* Exit from loop */ + + if (k <= *n - *nb + 1 && *nb < *n || k < 1) { + goto L30; + } + +/* Copy column K of A to column KW of W and update it */ + + zcopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); + if (k < *n) { + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * + w_dim1 + 1], &c__1); + } + + kstep = 1; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = k + kw * w_dim1; + absakk = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[k + kw * + w_dim1]), abs(d__2)); + +/* IMAX is the row-index of the largest off-diagonal element in */ + + if (k > 1) { + i__1 = k - 1; + imax = izamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = imax + kw * w_dim1; + colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + kw * w_dim1]), abs(d__2)); + } else { + colmax = 0.; + } + + if (f2cmax(absakk,colmax) == 0.) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + +/* Copy column IMAX to column KW-1 of W and update it */ + + zcopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + i__1 = k - imax; + zcopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + if (k < *n) { + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1); + } + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value */ + + i__1 = k - imax; + jmax = imax + izamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], + &c__1); + i__1 = jmax + (kw - 1) * w_dim1; + rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + jmax + (kw - 1) * w_dim1]), abs(d__2)); + if (imax > 1) { + i__1 = imax - 1; + jmax = izamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); +/* Computing MAX */ + i__1 = jmax + (kw - 1) * w_dim1; + d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) + ( + d__2 = d_imag(&w[jmax + (kw - 1) * w_dim1]), abs( + d__2)); + rowmax = f2cmax(d__3,d__4); + } + + if (absakk >= alpha * colmax * (colmax / rowmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else /* if(complicated condition) */ { + i__1 = imax + (kw - 1) * w_dim1; + if ((d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + imax + (kw - 1) * w_dim1]), abs(d__2)) >= alpha * + rowmax) { + +/* interchange rows and columns K and IMAX, use 1-by-1 */ +/* pivot block */ + + kp = imax; + +/* copy column KW-1 of W to column KW of W */ + + zcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + } else { + +/* interchange rows and columns K-1 and IMAX, use 2-by-2 */ +/* pivot block */ + + kp = imax; + kstep = 2; + } + } + } + +/* ============================================================ */ + +/* KK is the column of A where pivoting step stopped */ + + kk = k - kstep + 1; + +/* KKW is the column of W which corresponds to column KK of A */ + + kkw = *nb + kk - *n; + +/* Interchange rows and columns KP and KK. */ +/* Updated column KP is already stored in column KKW of W. */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP of submatrix A */ +/* at step K. No need to copy element into column K */ +/* (or K and K-1 for 2-by-2 pivot) of A, since these columns */ +/* will be later overwritten. */ + + i__1 = kp + kp * a_dim1; + i__2 = kk + kk * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kk - 1 - kp; + zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + if (kp > 1) { + i__1 = kp - 1; + zcopy_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + +/* Interchange rows KK and KP in last K+1 to N columns of A */ +/* (columns K (or K and K-1 for 2-by-2 pivot) of A will be */ +/* later overwritten). Interchange rows KK and KP */ +/* in last KKW to NB columns of W. */ + + if (k < *n) { + i__1 = *n - k; + zswap_(&i__1, &a[kk + (k + 1) * a_dim1], lda, &a[kp + (k + + 1) * a_dim1], lda); + } + i__1 = *n - kk + 1; + zswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column kw of W now holds */ + +/* W(kw) = U(k)*D(k), */ + +/* where U(k) is the k-th column of U */ + +/* Store subdiag. elements of column U(k) */ +/* and 1-by-1 block D(k) in column k of A. */ +/* NOTE: Diagonal element U(k,k) is a UNIT element */ +/* and not stored. */ +/* A(k,k) := D(k,k) = W(k,kw) */ +/* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k) */ + + zcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + z_div(&z__1, &c_b1, &a[k + k * a_dim1]); + r1.r = z__1.r, r1.i = z__1.i; + i__1 = k - 1; + zscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + + } else { + +/* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold */ + +/* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k) */ + +/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ +/* of U */ + +/* Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2 */ +/* block D(k-1:k,k-1:k) in columns k-1 and k of A. */ +/* NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT */ +/* block and not stored. */ +/* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw) */ +/* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) = */ +/* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) ) */ + + if (k > 2) { + +/* Compose the columns of the inverse of 2-by-2 pivot */ +/* block D in the following way to reduce the number */ +/* of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by */ +/* this inverse */ + +/* D**(-1) = ( d11 d21 )**(-1) = */ +/* ( d21 d22 ) */ + +/* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = */ +/* ( (-d21 ) ( d11 ) ) */ + +/* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * */ + +/* * ( ( d22/d21 ) ( -1 ) ) = */ +/* ( ( -1 ) ( d11/d21 ) ) */ + +/* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = 1/d21 * T * ( ( D11 ) ( -1 ) ) */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = D21 * ( ( D11 ) ( -1 ) ) */ +/* ( ( -1 ) ( D22 ) ) */ + + i__1 = k - 1 + kw * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + z_div(&z__1, &w[k + kw * w_dim1], &d21); + d11.r = z__1.r, d11.i = z__1.i; + z_div(&z__1, &w[k - 1 + (kw - 1) * w_dim1], &d21); + d22.r = z__1.r, d22.i = z__1.i; + z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r * + d22.i + d11.i * d22.r; + z__2.r = z__3.r - 1., z__2.i = z__3.i + 0.; + z_div(&z__1, &c_b1, &z__2); + t.r = z__1.r, t.i = z__1.i; + z_div(&z__1, &t, &d21); + d21.r = z__1.r, d21.i = z__1.i; + +/* Update elements in columns A(k-1) and A(k) as */ +/* dot products of rows of ( W(kw-1) W(kw) ) and columns */ +/* of D**(-1) */ + + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + i__2 = j + (k - 1) * a_dim1; + i__3 = j + (kw - 1) * w_dim1; + z__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__3.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + kw * w_dim1; + z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4] + .i; + z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i = + d21.r * z__2.i + d21.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + k * a_dim1; + i__3 = j + kw * w_dim1; + z__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__3.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + (kw - 1) * w_dim1; + z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4] + .i; + z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i = + d21.r * z__2.i + d21.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L20: */ + } + } + +/* Copy D(k) to A */ + + i__1 = k - 1 + (k - 1) * a_dim1; + i__2 = k - 1 + (kw - 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k - 1 + k * a_dim1; + i__2 = k - 1 + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + k * a_dim1; + i__2 = k + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + + } + + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + goto L10; + +L30: + +/* Update the upper triangle of A11 (= A(1:k,1:k)) as */ + +/* A11 := A11 - U12*D*U12**T = A11 - U12*W**T */ + +/* computing blocks of NB columns at a time */ + + i__1 = -(*nb); + for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += + i__1) { +/* Computing MIN */ + i__2 = *nb, i__3 = k - j + 1; + jb = f2cmin(i__2,i__3); + +/* Update the upper triangle of the diagonal block */ + + i__2 = j + jb - 1; + for (jj = j; jj <= i__2; ++jj) { + i__3 = jj - j + 1; + i__4 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__3, &i__4, &z__1, &a[j + (k + 1) * + a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b1, + &a[j + jj * a_dim1], &c__1); +/* L40: */ + } + +/* Update the rectangular superdiagonal block */ + + i__2 = j - 1; + i__3 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &z__1, &a[( + k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * w_dim1], ldw, + &c_b1, &a[j * a_dim1 + 1], lda); +/* L50: */ + } + +/* Put U12 in standard form by partially undoing the interchanges */ +/* in columns k+1:n looping backwards from k+1 to n */ + + j = k + 1; +L60: + +/* Undo the interchanges (if any) of rows JJ and JP at each */ +/* step J */ + +/* (Here, J is a diagonal index) */ + jj = j; + jp = ipiv[j]; + if (jp < 0) { + jp = -jp; +/* (Here, J is a diagonal index) */ + ++j; + } +/* (NOTE: Here, J is used to determine row length. Length N-J+1 */ +/* of the rows to swap back doesn't include diagonal element) */ + ++j; + if (jp != jj && j <= *n) { + i__1 = *n - j + 1; + zswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda); + } + if (j < *n) { + goto L60; + } + +/* Set KB to the number of columns factorized */ + + *kb = *n - k; + + } else { + +/* Factorize the leading columns of A using the lower triangle */ +/* of A and working forwards, and compute the matrix W = L21*D */ +/* for use in updating A22 */ + +/* K is the main loop index, increasing from 1 in steps of 1 or 2 */ + + k = 1; +L70: + +/* Exit from loop */ + + if (k >= *nb && *nb < *n || k > *n) { + goto L90; + } + +/* Copy column K of A to column K of W and update it */ + + i__1 = *n - k + 1; + zcopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1); + i__1 = *n - k + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], lda, &w[k + + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1); + + kstep = 1; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = k + k * w_dim1; + absakk = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[k + k * + w_dim1]), abs(d__2)); + +/* IMAX is the row-index of the largest off-diagonal element in */ + + if (k < *n) { + i__1 = *n - k; + imax = k + izamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = imax + k * w_dim1; + colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + k * w_dim1]), abs(d__2)); + } else { + colmax = 0.; + } + + if (f2cmax(absakk,colmax) == 0.) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + +/* Copy column IMAX to column K+1 of W and update it */ + + i__1 = imax - k; + zcopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = *n - imax + 1; + zcopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + + 1) * w_dim1], &c__1); + i__1 = *n - k + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], + lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + 1) * + w_dim1], &c__1); + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value */ + + i__1 = imax - k; + jmax = k - 1 + izamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1) + ; + i__1 = jmax + (k + 1) * w_dim1; + rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + jmax + (k + 1) * w_dim1]), abs(d__2)); + if (imax < *n) { + i__1 = *n - imax; + jmax = imax + izamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); +/* Computing MAX */ + i__1 = jmax + (k + 1) * w_dim1; + d__3 = rowmax, d__4 = (d__1 = w[i__1].r, abs(d__1)) + ( + d__2 = d_imag(&w[jmax + (k + 1) * w_dim1]), abs( + d__2)); + rowmax = f2cmax(d__3,d__4); + } + + if (absakk >= alpha * colmax * (colmax / rowmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else /* if(complicated condition) */ { + i__1 = imax + (k + 1) * w_dim1; + if ((d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + imax + (k + 1) * w_dim1]), abs(d__2)) >= alpha * + rowmax) { + +/* interchange rows and columns K and IMAX, use 1-by-1 */ +/* pivot block */ + + kp = imax; + +/* copy column K+1 of W to column K of W */ + + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + + k * w_dim1], &c__1); + } else { + +/* interchange rows and columns K+1 and IMAX, use 2-by-2 */ +/* pivot block */ + + kp = imax; + kstep = 2; + } + } + } + +/* ============================================================ */ + +/* KK is the column of A where pivoting step stopped */ + + kk = k + kstep - 1; + +/* Interchange rows and columns KP and KK. */ +/* Updated column KP is already stored in column KK of W. */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP of submatrix A */ +/* at step K. No need to copy element into column K */ +/* (or K and K+1 for 2-by-2 pivot) of A, since these columns */ +/* will be later overwritten. */ + + i__1 = kp + kp * a_dim1; + i__2 = kk + kk * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp - kk - 1; + zcopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + + 1) * a_dim1], lda); + if (kp < *n) { + i__1 = *n - kp; + zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + +/* Interchange rows KK and KP in first K-1 columns of A */ +/* (columns K (or K and K+1 for 2-by-2 pivot) of A will be */ +/* later overwritten). Interchange rows KK and KP */ +/* in first KK columns of W. */ + + if (k > 1) { + i__1 = k - 1; + zswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + } + zswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k of W now holds */ + +/* W(k) = L(k)*D(k), */ + +/* where L(k) is the k-th column of L */ + +/* Store subdiag. elements of column L(k) */ +/* and 1-by-1 block D(k) in column k of A. */ +/* (NOTE: Diagonal element L(k,k) is a UNIT element */ +/* and not stored) */ +/* A(k,k) := D(k,k) = W(k,k) */ +/* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k) */ + + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + z_div(&z__1, &c_b1, &a[k + k * a_dim1]); + r1.r = z__1.r, r1.i = z__1.i; + i__1 = *n - k; + zscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + } + + } else { + +/* 2-by-2 pivot block D(k): columns k and k+1 of W now hold */ + +/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */ + +/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */ +/* of L */ + +/* Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2 */ +/* block D(k:k+1,k:k+1) in columns k and k+1 of A. */ +/* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT */ +/* block and not stored) */ +/* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1) */ +/* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) = */ +/* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) ) */ + + if (k < *n - 1) { + +/* Compose the columns of the inverse of 2-by-2 pivot */ +/* block D in the following way to reduce the number */ +/* of FLOPS when we myltiply panel ( W(k) W(k+1) ) by */ +/* this inverse */ + +/* D**(-1) = ( d11 d21 )**(-1) = */ +/* ( d21 d22 ) */ + +/* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = */ +/* ( (-d21 ) ( d11 ) ) */ + +/* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * */ + +/* * ( ( d22/d21 ) ( -1 ) ) = */ +/* ( ( -1 ) ( d11/d21 ) ) */ + +/* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = 1/d21 * T * ( ( D11 ) ( -1 ) ) */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = D21 * ( ( D11 ) ( -1 ) ) */ +/* ( ( -1 ) ( D22 ) ) */ + + i__1 = k + 1 + k * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + z_div(&z__1, &w[k + 1 + (k + 1) * w_dim1], &d21); + d11.r = z__1.r, d11.i = z__1.i; + z_div(&z__1, &w[k + k * w_dim1], &d21); + d22.r = z__1.r, d22.i = z__1.i; + z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r * + d22.i + d11.i * d22.r; + z__2.r = z__3.r - 1., z__2.i = z__3.i + 0.; + z_div(&z__1, &c_b1, &z__2); + t.r = z__1.r, t.i = z__1.i; + z_div(&z__1, &t, &d21); + d21.r = z__1.r, d21.i = z__1.i; + +/* Update elements in columns A(k) and A(k+1) as */ +/* dot products of rows of ( W(k) W(k+1) ) and columns */ +/* of D**(-1) */ + + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + i__3 = j + k * w_dim1; + z__3.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__3.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + (k + 1) * w_dim1; + z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4] + .i; + z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i = + d21.r * z__2.i + d21.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + (k + 1) * a_dim1; + i__3 = j + (k + 1) * w_dim1; + z__3.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__3.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + k * w_dim1; + z__2.r = z__3.r - w[i__4].r, z__2.i = z__3.i - w[i__4] + .i; + z__1.r = d21.r * z__2.r - d21.i * z__2.i, z__1.i = + d21.r * z__2.i + d21.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L80: */ + } + } + +/* Copy D(k) to A */ + + i__1 = k + k * a_dim1; + i__2 = k + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + k * a_dim1; + i__2 = k + 1 + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + (k + 1) * a_dim1; + i__2 = k + 1 + (k + 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + + } + + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + goto L70; + +L90: + +/* Update the lower triangle of A22 (= A(k:n,k:n)) as */ + +/* A22 := A22 - L21*D*L21**T = A22 - L21*W**T */ + +/* computing blocks of NB columns at a time */ + + i__1 = *n; + i__2 = *nb; + for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = *nb, i__4 = *n - j + 1; + jb = f2cmin(i__3,i__4); + +/* Update the lower triangle of the diagonal block */ + + i__3 = j + jb - 1; + for (jj = j; jj <= i__3; ++jj) { + i__4 = j + jb - jj; + i__5 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__4, &i__5, &z__1, &a[jj + a_dim1], + lda, &w[jj + w_dim1], ldw, &c_b1, &a[jj + jj * a_dim1] + , &c__1); +/* L100: */ + } + +/* Update the rectangular subdiagonal block */ + + if (j + jb <= *n) { + i__3 = *n - j - jb + 1; + i__4 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &z__1, + &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b1, + &a[j + jb + j * a_dim1], lda); + } +/* L110: */ + } + +/* Put L21 in standard form by partially undoing the interchanges */ +/* of rows in columns 1:k-1 looping backwards from k-1 to 1 */ + + j = k - 1; +L120: + +/* Undo the interchanges (if any) of rows JJ and JP at each */ +/* step J */ + +/* (Here, J is a diagonal index) */ + jj = j; + jp = ipiv[j]; + if (jp < 0) { + jp = -jp; +/* (Here, J is a diagonal index) */ + --j; + } +/* (NOTE: Here, J is used to determine row length. Length J */ +/* of the rows to swap back doesn't include diagonal element) */ + --j; + if (jp != jj && j >= 1) { + zswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda); + } + if (j > 1) { + goto L120; + } + +/* Set KB to the number of columns factorized */ + + *kb = k - 1; + + } + return 0; + +/* End of ZLASYF */ + +} /* zlasyf_ */ + diff --git a/lapack-netlib/SRC/zlasyf_aa.c b/lapack-netlib/SRC/zlasyf_aa.c new file mode 100644 index 000000000..475ad1b4c --- /dev/null +++ b/lapack-netlib/SRC/zlasyf_aa.c @@ -0,0 +1,962 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLASYF_AA */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLASYF_AA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLASYF_AA( UPLO, J1, M, NB, A, LDA, IPIV, */ +/* H, LDH, WORK ) */ + +/* CHARACTER UPLO */ +/* INTEGER J1, M, NB, LDA, LDH */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), H( LDH, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLATRF_AA factorizes a panel of a complex symmetric matrix A using */ +/* > the Aasen's algorithm. The panel consists of a set of NB rows of A */ +/* > when UPLO is U, or a set of NB columns when UPLO is L. */ +/* > */ +/* > In order to factorize the panel, the Aasen's algorithm requires the */ +/* > last row, or column, of the previous panel. The first row, or column, */ +/* > of A is set to be the first row, or column, of an identity matrix, */ +/* > which is used to factorize the first panel. */ +/* > */ +/* > The resulting J-th row of U, or J-th column of L, is stored in the */ +/* > (J-1)-th row, or column, of A (without the unit diagonals), while */ +/* > the diagonal and subdiagonal of A are overwritten by those of 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] J1 */ +/* > \verbatim */ +/* > J1 is INTEGER */ +/* > The location of the first row, or column, of the panel */ +/* > within the submatrix of A, passed to this routine, e.g., */ +/* > when called by ZSYTRF_AA, for the first panel, J1 is 1, */ +/* > while for the remaining panels, J1 is 2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The dimension of the submatrix. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The dimension of the panel to be facotorized. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,M) for */ +/* > the first panel, while dimension (LDA,M+1) for the */ +/* > remaining panels. */ +/* > */ +/* > On entry, A contains the last row, or column, of */ +/* > the previous panel, and the trailing submatrix of A */ +/* > to be factorized, except for the first panel, only */ +/* > the panel is passed. */ +/* > */ +/* > On exit, the leading panel is factorized. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (M) */ +/* > Details of the row and column interchanges, */ +/* > the row and column k were interchanged with the row and */ +/* > column IPIV(k). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] H */ +/* > \verbatim */ +/* > H is COMPLEX*16 workspace, dimension (LDH,NB). */ +/* > */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > The leading dimension of the workspace H. LDH >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 workspace, dimension (M). */ +/* > \endverbatim */ +/* > */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup complex16SYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zlasyf_aa_(char *uplo, integer *j1, integer *m, integer + *nb, doublecomplex *a, integer *lda, integer *ipiv, doublecomplex * + h__, integer *ldh, doublecomplex *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, h_dim1, h_offset, i__1, i__2; + doublecomplex z__1; + + /* Local variables */ + integer j, k; + doublecomplex alpha; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *), zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + integer i1, k1, i2; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zswap_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *), zaxpy_(integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *); + integer mj; + extern integer izamax_(integer *, doublecomplex *, integer *); + extern /* Subroutine */ int zlaset_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *); + doublecomplex piv; + + +/* -- 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; + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + --work; + + /* Function Body */ + j = 1; + +/* K1 is the first column of the panel to be factorized */ +/* i.e., K1 is 2 for the first block column, and 1 for the rest of the blocks */ + + k1 = 2 - *j1 + 1; + + if (lsame_(uplo, "U")) { + +/* ..................................................... */ +/* Factorize A as U**T*D*U using the upper triangle of A */ +/* ..................................................... */ + +L10: + if (j > f2cmin(*m,*nb)) { + goto L20; + } + +/* K is the column to be factorized */ +/* when being called from ZSYTRF_AA, */ +/* > for the first block column, J1 is 1, hence J1+J-1 is J, */ +/* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, */ + + k = *j1 + j - 1; + if (j == *m) { + +/* Only need to compute T(J, J) */ + + mj = 1; + } else { + mj = *m - j + 1; + } + +/* H(J:M, J) := A(J, J:M) - H(J:M, 1:(J-1)) * L(J1:(J-1), J), */ +/* where H(J:M, J) has been initialized to be A(J, J:M) */ + + if (k > 2) { + +/* K is the column to be factorized */ +/* > for the first block column, K is J, skipping the first two */ +/* columns */ +/* > for the rest of the columns, K is J+1, skipping only the */ +/* first column */ + + i__1 = j - k1; + zgemv_("No transpose", &mj, &i__1, &c_b6, &h__[j + k1 * h_dim1], + ldh, &a[j * a_dim1 + 1], &c__1, &c_b8, &h__[j + j * + h_dim1], &c__1); + } + +/* Copy H(i:M, i) into WORK */ + + zcopy_(&mj, &h__[j + j * h_dim1], &c__1, &work[1], &c__1); + + if (j > k1) { + +/* Compute WORK := WORK - L(J-1, J:M) * T(J-1,J), */ +/* where A(J-1, J) stores T(J-1, J) and A(J-2, J:M) stores U(J-1, J:M) */ + + i__1 = k - 1 + j * a_dim1; + z__1.r = -a[i__1].r, z__1.i = -a[i__1].i; + alpha.r = z__1.r, alpha.i = z__1.i; + zaxpy_(&mj, &alpha, &a[k - 2 + j * a_dim1], lda, &work[1], &c__1); + } + +/* Set A(J, J) = T(J, J) */ + + i__1 = k + j * a_dim1; + a[i__1].r = work[1].r, a[i__1].i = work[1].i; + + if (j < *m) { + +/* Compute WORK(2:M) = T(J, J) L(J, (J+1):M) */ +/* where A(J, J) stores T(J, J) and A(J-1, (J+1):M) stores U(J, (J+1):M) */ + + if (k > 1) { + i__1 = k + j * a_dim1; + z__1.r = -a[i__1].r, z__1.i = -a[i__1].i; + alpha.r = z__1.r, alpha.i = z__1.i; + i__1 = *m - j; + zaxpy_(&i__1, &alpha, &a[k - 1 + (j + 1) * a_dim1], lda, & + work[2], &c__1); + } + +/* Find f2cmax(|WORK(2:M)|) */ + + i__1 = *m - j; + i2 = izamax_(&i__1, &work[2], &c__1) + 1; + i__1 = i2; + piv.r = work[i__1].r, piv.i = work[i__1].i; + +/* Apply symmetric pivot */ + + if (i2 != 2 && (piv.r != 0. || piv.i != 0.)) { + +/* Swap WORK(I1) and WORK(I2) */ + + i1 = 2; + i__1 = i2; + i__2 = i1; + work[i__1].r = work[i__2].r, work[i__1].i = work[i__2].i; + i__1 = i1; + work[i__1].r = piv.r, work[i__1].i = piv.i; + +/* Swap A(I1, I1+1:M) with A(I1+1:M, I2) */ + + i1 = i1 + j - 1; + i2 = i2 + j - 1; + i__1 = i2 - i1 - 1; + zswap_(&i__1, &a[*j1 + i1 - 1 + (i1 + 1) * a_dim1], lda, &a[* + j1 + i1 + i2 * a_dim1], &c__1); + +/* Swap A(I1, I2+1:M) with A(I2, I2+1:M) */ + + if (i2 < *m) { + i__1 = *m - i2; + zswap_(&i__1, &a[*j1 + i1 - 1 + (i2 + 1) * a_dim1], lda, & + a[*j1 + i2 - 1 + (i2 + 1) * a_dim1], lda); + } + +/* Swap A(I1, I1) with A(I2,I2) */ + + i__1 = i1 + *j1 - 1 + i1 * a_dim1; + piv.r = a[i__1].r, piv.i = a[i__1].i; + i__1 = *j1 + i1 - 1 + i1 * a_dim1; + i__2 = *j1 + i2 - 1 + i2 * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = *j1 + i2 - 1 + i2 * a_dim1; + a[i__1].r = piv.r, a[i__1].i = piv.i; + +/* Swap H(I1, 1:J1) with H(I2, 1:J1) */ + + i__1 = i1 - 1; + zswap_(&i__1, &h__[i1 + h_dim1], ldh, &h__[i2 + h_dim1], ldh); + ipiv[i1] = i2; + + if (i1 > k1 - 1) { + +/* Swap L(1:I1-1, I1) with L(1:I1-1, I2), */ +/* skipping the first column */ + + i__1 = i1 - k1 + 1; + zswap_(&i__1, &a[i1 * a_dim1 + 1], &c__1, &a[i2 * a_dim1 + + 1], &c__1); + } + } else { + ipiv[j + 1] = j + 1; + } + +/* Set A(J, J+1) = T(J, J+1) */ + + i__1 = k + (j + 1) * a_dim1; + a[i__1].r = work[2].r, a[i__1].i = work[2].i; + + if (j < *nb) { + +/* Copy A(J+1:M, J+1) into H(J:M, J), */ + + i__1 = *m - j; + zcopy_(&i__1, &a[k + 1 + (j + 1) * a_dim1], lda, &h__[j + 1 + + (j + 1) * h_dim1], &c__1); + } + +/* Compute L(J+2, J+1) = WORK( 3:M ) / T(J, J+1), */ +/* where A(J, J+1) = T(J, J+1) and A(J+2:M, J) = L(J+2:M, J+1) */ + + if (j < *m - 1) { + i__1 = k + (j + 1) * a_dim1; + if (a[i__1].r != 0. || a[i__1].i != 0.) { + z_div(&z__1, &c_b8, &a[k + (j + 1) * a_dim1]); + alpha.r = z__1.r, alpha.i = z__1.i; + i__1 = *m - j - 1; + zcopy_(&i__1, &work[3], &c__1, &a[k + (j + 2) * a_dim1], + lda); + i__1 = *m - j - 1; + zscal_(&i__1, &alpha, &a[k + (j + 2) * a_dim1], lda); + } else { + i__1 = *m - j - 1; + zlaset_("Full", &c__1, &i__1, &c_b19, &c_b19, &a[k + (j + + 2) * a_dim1], lda); + } + } + } + ++j; + goto L10; +L20: + + ; + } else { + +/* ..................................................... */ +/* Factorize A as L*D*L**T using the lower triangle of A */ +/* ..................................................... */ + +L30: + if (j > f2cmin(*m,*nb)) { + goto L40; + } + +/* K is the column to be factorized */ +/* when being called from ZSYTRF_AA, */ +/* > for the first block column, J1 is 1, hence J1+J-1 is J, */ +/* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, */ + + k = *j1 + j - 1; + if (j == *m) { + +/* Only need to compute T(J, J) */ + + mj = 1; + } else { + mj = *m - j + 1; + } + +/* H(J:M, J) := A(J:M, J) - H(J:M, 1:(J-1)) * L(J, J1:(J-1))^T, */ +/* where H(J:M, J) has been initialized to be A(J:M, J) */ + + if (k > 2) { + +/* K is the column to be factorized */ +/* > for the first block column, K is J, skipping the first two */ +/* columns */ +/* > for the rest of the columns, K is J+1, skipping only the */ +/* first column */ + + i__1 = j - k1; + zgemv_("No transpose", &mj, &i__1, &c_b6, &h__[j + k1 * h_dim1], + ldh, &a[j + a_dim1], lda, &c_b8, &h__[j + j * h_dim1], & + c__1); + } + +/* Copy H(J:M, J) into WORK */ + + zcopy_(&mj, &h__[j + j * h_dim1], &c__1, &work[1], &c__1); + + if (j > k1) { + +/* Compute WORK := WORK - L(J:M, J-1) * T(J-1,J), */ +/* where A(J-1, J) = T(J-1, J) and A(J, J-2) = L(J, J-1) */ + + i__1 = j + (k - 1) * a_dim1; + z__1.r = -a[i__1].r, z__1.i = -a[i__1].i; + alpha.r = z__1.r, alpha.i = z__1.i; + zaxpy_(&mj, &alpha, &a[j + (k - 2) * a_dim1], &c__1, &work[1], & + c__1); + } + +/* Set A(J, J) = T(J, J) */ + + i__1 = j + k * a_dim1; + a[i__1].r = work[1].r, a[i__1].i = work[1].i; + + if (j < *m) { + +/* Compute WORK(2:M) = T(J, J) L((J+1):M, J) */ +/* where A(J, J) = T(J, J) and A((J+1):M, J-1) = L((J+1):M, J) */ + + if (k > 1) { + i__1 = j + k * a_dim1; + z__1.r = -a[i__1].r, z__1.i = -a[i__1].i; + alpha.r = z__1.r, alpha.i = z__1.i; + i__1 = *m - j; + zaxpy_(&i__1, &alpha, &a[j + 1 + (k - 1) * a_dim1], &c__1, & + work[2], &c__1); + } + +/* Find f2cmax(|WORK(2:M)|) */ + + i__1 = *m - j; + i2 = izamax_(&i__1, &work[2], &c__1) + 1; + i__1 = i2; + piv.r = work[i__1].r, piv.i = work[i__1].i; + +/* Apply symmetric pivot */ + + if (i2 != 2 && (piv.r != 0. || piv.i != 0.)) { + +/* Swap WORK(I1) and WORK(I2) */ + + i1 = 2; + i__1 = i2; + i__2 = i1; + work[i__1].r = work[i__2].r, work[i__1].i = work[i__2].i; + i__1 = i1; + work[i__1].r = piv.r, work[i__1].i = piv.i; + +/* Swap A(I1+1:M, I1) with A(I2, I1+1:M) */ + + i1 = i1 + j - 1; + i2 = i2 + j - 1; + i__1 = i2 - i1 - 1; + zswap_(&i__1, &a[i1 + 1 + (*j1 + i1 - 1) * a_dim1], &c__1, &a[ + i2 + (*j1 + i1) * a_dim1], lda); + +/* Swap A(I2+1:M, I1) with A(I2+1:M, I2) */ + + if (i2 < *m) { + i__1 = *m - i2; + zswap_(&i__1, &a[i2 + 1 + (*j1 + i1 - 1) * a_dim1], &c__1, + &a[i2 + 1 + (*j1 + i2 - 1) * a_dim1], &c__1); + } + +/* Swap A(I1, I1) with A(I2, I2) */ + + i__1 = i1 + (*j1 + i1 - 1) * a_dim1; + piv.r = a[i__1].r, piv.i = a[i__1].i; + i__1 = i1 + (*j1 + i1 - 1) * a_dim1; + i__2 = i2 + (*j1 + i2 - 1) * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = i2 + (*j1 + i2 - 1) * a_dim1; + a[i__1].r = piv.r, a[i__1].i = piv.i; + +/* Swap H(I1, I1:J1) with H(I2, I2:J1) */ + + i__1 = i1 - 1; + zswap_(&i__1, &h__[i1 + h_dim1], ldh, &h__[i2 + h_dim1], ldh); + ipiv[i1] = i2; + + if (i1 > k1 - 1) { + +/* Swap L(1:I1-1, I1) with L(1:I1-1, I2), */ +/* skipping the first column */ + + i__1 = i1 - k1 + 1; + zswap_(&i__1, &a[i1 + a_dim1], lda, &a[i2 + a_dim1], lda); + } + } else { + ipiv[j + 1] = j + 1; + } + +/* Set A(J+1, J) = T(J+1, J) */ + + i__1 = j + 1 + k * a_dim1; + a[i__1].r = work[2].r, a[i__1].i = work[2].i; + + if (j < *nb) { + +/* Copy A(J+1:M, J+1) into H(J+1:M, J), */ + + i__1 = *m - j; + zcopy_(&i__1, &a[j + 1 + (k + 1) * a_dim1], &c__1, &h__[j + 1 + + (j + 1) * h_dim1], &c__1); + } + +/* Compute L(J+2, J+1) = WORK( 3:M ) / T(J, J+1), */ +/* where A(J, J+1) = T(J, J+1) and A(J+2:M, J) = L(J+2:M, J+1) */ + + if (j < *m - 1) { + i__1 = j + 1 + k * a_dim1; + if (a[i__1].r != 0. || a[i__1].i != 0.) { + z_div(&z__1, &c_b8, &a[j + 1 + k * a_dim1]); + alpha.r = z__1.r, alpha.i = z__1.i; + i__1 = *m - j - 1; + zcopy_(&i__1, &work[3], &c__1, &a[j + 2 + k * a_dim1], & + c__1); + i__1 = *m - j - 1; + zscal_(&i__1, &alpha, &a[j + 2 + k * a_dim1], &c__1); + } else { + i__1 = *m - j - 1; + zlaset_("Full", &i__1, &c__1, &c_b19, &c_b19, &a[j + 2 + + k * a_dim1], lda); + } + } + } + ++j; + goto L30; +L40: + ; + } + return 0; + +/* End of ZLASYF_AA */ + +} /* zlasyf_aa__ */ + diff --git a/lapack-netlib/SRC/zlasyf_rk.c b/lapack-netlib/SRC/zlasyf_rk.c new file mode 100644 index 000000000..c949de6a6 --- /dev/null +++ b/lapack-netlib/SRC/zlasyf_rk.c @@ -0,0 +1,1597 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLASYF_RK computes a partial factorization of a complex symmetric indefinite matrix using bound +ed Bunch-Kaufman (rook) diagonal pivoting method. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLASYF_RK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, */ +/* INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, KB, LDA, LDW, N, NB */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), E( * ), W( LDW, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > ZLASYF_RK computes a partial factorization of a complex symmetric */ +/* > matrix A using the bounded Bunch-Kaufman (rook) diagonal */ +/* > pivoting method. The partial factorization has the form: */ +/* > */ +/* > A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: */ +/* > ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) */ +/* > */ +/* > A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L', */ +/* > ( L21 I ) ( 0 A22 ) ( 0 I ) */ +/* > */ +/* > where the order of D is at most NB. The actual order is returned in */ +/* > the argument KB, and is either NB or NB-1, or N if N <= NB. */ +/* > */ +/* > ZLASYF_RK is an auxiliary routine called by ZSYTRF_RK. It uses */ +/* > blocked code (calling Level 3 BLAS) to update the submatrix */ +/* > A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). */ +/* > \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] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The maximum number of columns of the matrix A that should be */ +/* > factored. NB should be at least 2 to allow for 2-by-2 pivot */ +/* > blocks. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] KB */ +/* > \verbatim */ +/* > KB is INTEGER */ +/* > The number of columns of A that were actually factored. */ +/* > KB is either NB-1 or NB, or N if N <= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 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 COMPLEX*16 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. */ +/* > */ +/* > 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 submatrix A(1:N,N-KB+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,N-KB+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 submatrix A(1:N,N-KB+1:N). */ +/* > If -IPIV(k-1) = k-1, no interchange occurred. */ +/* > */ +/* > c) In both cases a) and b) is 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 submatrix A(1:N,1:KB). */ +/* > 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 submatrix A(1:N,1:KB). */ +/* > 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 submatrix A(1:N,1:KB). */ +/* > If -IPIV(k+1) = k+1, no interchange occurred. */ +/* > */ +/* > c) In both cases a) and b) is always ABS( IPIV(k) ) >= k. */ +/* > */ +/* > d) NOTE: Any entry IPIV(k) is always NONZERO on output. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is COMPLEX*16 array, dimension (LDW,NB) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDW */ +/* > \verbatim */ +/* > LDW is INTEGER */ +/* > The leading dimension of the array W. LDW >= f2cmax(1,N). */ +/* > \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 complex16SYcomputational */ + +/* > \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 zlasyf_rk_(char *uplo, integer *n, integer *nb, integer + *kb, doublecomplex *a, integer *lda, doublecomplex *e, integer *ipiv, + doublecomplex *w, integer *ldw, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5; + doublereal d__1, d__2; + doublecomplex z__1, z__2, z__3, z__4; + + /* Local variables */ + logical done; + integer imax, jmax, j, k, p; + doublecomplex t; + doublereal alpha; + extern logical lsame_(char *, char *); + doublereal dtemp, sfmin; + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *); + integer itemp; + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + integer kstep; + extern /* Subroutine */ int zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + doublecomplex r1; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zswap_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *); + doublecomplex d11, d12, d21, d22; + integer jb, ii, jj, kk; + extern doublereal dlamch_(char *); + integer kp; + doublereal absakk; + integer kw; + doublereal colmax; + extern integer izamax_(integer *, doublecomplex *, integer *); + doublereal rowmax; + integer kkw; + + +/* -- 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; + --e; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1 * 1; + w -= w_offset; + + /* Function Body */ + *info = 0; + +/* Initialize ALPHA for use in choosing pivot block size. */ + + alpha = (sqrt(17.) + 1.) / 8.; + +/* Compute machine safe minimum */ + + sfmin = dlamch_("S"); + + if (lsame_(uplo, "U")) { + +/* Factorize the trailing columns of A using the upper triangle */ +/* of A and working backwards, and compute the matrix W = U12*D */ +/* for use in updating A11 */ + +/* Initialize the first entry of array E, where superdiagonal */ +/* elements of D are stored */ + + e[1].r = 0., e[1].i = 0.; + +/* K is the main loop index, decreasing from N in steps of 1 or 2 */ + + k = *n; +L10: + +/* KW is the column of W which corresponds to column K of A */ + + kw = *nb + k - *n; + +/* Exit from loop */ + + if (k <= *n - *nb + 1 && *nb < *n || k < 1) { + goto L30; + } + + kstep = 1; + p = k; + +/* Copy column K of A to column KW of W and update it */ + + zcopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); + if (k < *n) { + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * + w_dim1 + 1], &c__1); + } + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = k + kw * w_dim1; + absakk = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[k + kw * + w_dim1]), abs(d__2)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k > 1) { + i__1 = k - 1; + imax = izamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = imax + kw * w_dim1; + colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + kw * w_dim1]), abs(d__2)); + } else { + colmax = 0.; + } + + if (f2cmax(absakk,colmax) == 0.) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + zcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + +/* Set E( K ) to zero */ + + if (k > 1) { + i__1 = k; + e[i__1].r = 0., e[i__1].i = 0.; + } + + } else { + +/* ============================================================ */ + +/* Test for interchange */ + +/* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX */ +/* (used to handle NaN and Inf) */ + + if (! (absakk < alpha * colmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + + } else { + + done = FALSE_; + +/* Loop until pivot found */ + +L12: + +/* Begin pivot search loop body */ + + +/* Copy column IMAX to column KW-1 of W and update it */ + + zcopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + i__1 = k - imax; + zcopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + + if (k < *n) { + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1); + } + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine both ROWMAX and JMAX. */ + + if (imax != k) { + i__1 = k - imax; + jmax = imax + izamax_(&i__1, &w[imax + 1 + (kw - 1) * + w_dim1], &c__1); + i__1 = jmax + (kw - 1) * w_dim1; + rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(& + w[jmax + (kw - 1) * w_dim1]), abs(d__2)); + } else { + rowmax = 0.; + } + + if (imax > 1) { + i__1 = imax - 1; + itemp = izamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); + i__1 = itemp + (kw - 1) * w_dim1; + dtemp = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + itemp + (kw - 1) * w_dim1]), abs(d__2)); + if (dtemp > rowmax) { + rowmax = dtemp; + jmax = itemp; + } + } + +/* Equivalent to testing for */ +/* CABS1( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX */ +/* (used to handle NaN and Inf) */ + + i__1 = imax + (kw - 1) * w_dim1; + if (! ((d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + (kw - 1) * w_dim1]), abs(d__2)) < alpha * rowmax)) { + +/* interchange rows and columns K and IMAX, */ +/* use 1-by-1 pivot block */ + + kp = imax; + +/* copy column KW-1 of W to column KW of W */ + + zcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + + done = TRUE_; + +/* Equivalent to testing for ROWMAX.EQ.COLMAX, */ +/* (used to handle NaN and Inf) */ + + } else if (p == jmax || rowmax <= colmax) { + +/* interchange rows and columns K-1 and IMAX, */ +/* use 2-by-2 pivot block */ + + kp = imax; + kstep = 2; + done = TRUE_; + } else { + +/* Pivot not found: set params and repeat */ + + p = imax; + colmax = rowmax; + imax = jmax; + +/* Copy updated JMAXth (next IMAXth) column to Kth of W */ + + zcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + + } + +/* End pivot search loop body */ + + if (! done) { + goto L12; + } + + } + +/* ============================================================ */ + + kk = k - kstep + 1; + +/* KKW is the column of W which corresponds to column KK of A */ + + kkw = *nb + kk - *n; + + if (kstep == 2 && p != k) { + +/* Copy non-updated column K to column P */ + + i__1 = k - p; + zcopy_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + (p + 1) * + a_dim1], lda); + zcopy_(&p, &a[k * a_dim1 + 1], &c__1, &a[p * a_dim1 + 1], & + c__1); + +/* Interchange rows K and P in last N-K+1 columns of A */ +/* and last N-K+2 columns of W */ + + i__1 = *n - k + 1; + zswap_(&i__1, &a[k + k * a_dim1], lda, &a[p + k * a_dim1], + lda); + i__1 = *n - kk + 1; + zswap_(&i__1, &w[k + kkw * w_dim1], ldw, &w[p + kkw * w_dim1], + ldw); + } + +/* Updated column KP is already stored in column KKW of W */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP */ + + i__1 = kp + k * a_dim1; + i__2 = kk + k * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = k - 1 - kp; + zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + zcopy_(&kp, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], & + c__1); + +/* Interchange rows KK and KP in last N-KK+1 columns */ +/* of A and W */ + + i__1 = *n - kk + 1; + zswap_(&i__1, &a[kk + kk * a_dim1], lda, &a[kp + kk * a_dim1], + lda); + i__1 = *n - kk + 1; + zswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column KW of W now holds */ + +/* W(k) = U(k)*D(k) */ + +/* where U(k) is the k-th column of U */ + +/* Store U(k) in column k of A */ + + zcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + if (k > 1) { + i__1 = k + k * a_dim1; + if ((d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[k + + k * a_dim1]), abs(d__2)) >= sfmin) { + z_div(&z__1, &c_b1, &a[k + k * a_dim1]); + r1.r = z__1.r, r1.i = z__1.i; + i__1 = k - 1; + zscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + } else /* if(complicated condition) */ { + i__1 = k + k * a_dim1; + if (a[i__1].r != 0. || a[i__1].i != 0.) { + i__1 = k - 1; + for (ii = 1; ii <= i__1; ++ii) { + i__2 = ii + k * a_dim1; + z_div(&z__1, &a[ii + k * a_dim1], &a[k + k * + a_dim1]); + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L14: */ + } + } + } + +/* Store the superdiagonal element of D in array E */ + + i__1 = k; + e[i__1].r = 0., e[i__1].i = 0.; + + } + + } else { + +/* 2-by-2 pivot block D(k): columns KW and KW-1 of W now */ +/* hold */ + +/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */ + +/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ +/* of U */ + + if (k > 2) { + +/* Store U(k) and U(k-1) in columns k and k-1 of A */ + + i__1 = k - 1 + kw * w_dim1; + d12.r = w[i__1].r, d12.i = w[i__1].i; + z_div(&z__1, &w[k + kw * w_dim1], &d12); + d11.r = z__1.r, d11.i = z__1.i; + z_div(&z__1, &w[k - 1 + (kw - 1) * w_dim1], &d12); + d22.r = z__1.r, d22.i = z__1.i; + z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r * + d22.i + d11.i * d22.r; + z__2.r = z__3.r - 1., z__2.i = z__3.i + 0.; + z_div(&z__1, &c_b1, &z__2); + t.r = z__1.r, t.i = z__1.i; + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + i__2 = j + (k - 1) * a_dim1; + i__3 = j + (kw - 1) * w_dim1; + z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + kw * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + z_div(&z__2, &z__3, &d12); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + k * a_dim1; + i__3 = j + kw * w_dim1; + z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + (kw - 1) * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + z_div(&z__2, &z__3, &d12); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L20: */ + } + } + +/* Copy diagonal elements of D(K) to A, */ +/* copy superdiagonal element of D(K) to E(K) and */ +/* ZERO out superdiagonal entry of A */ + + i__1 = k - 1 + (k - 1) * a_dim1; + i__2 = k - 1 + (kw - 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k - 1 + k * a_dim1; + a[i__1].r = 0., a[i__1].i = 0.; + i__1 = k + k * a_dim1; + i__2 = k + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k; + i__2 = k - 1 + kw * w_dim1; + e[i__1].r = w[i__2].r, e[i__1].i = w[i__2].i; + i__1 = k - 1; + e[i__1].r = 0., e[i__1].i = 0.; + + } + +/* End column K is nonsingular */ + + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + goto L10; + +L30: + +/* Update the upper triangle of A11 (= A(1:k,1:k)) as */ + +/* A11 := A11 - U12*D*U12**T = A11 - U12*W**T */ + +/* computing blocks of NB columns at a time */ + + i__1 = -(*nb); + for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += + i__1) { +/* Computing MIN */ + i__2 = *nb, i__3 = k - j + 1; + jb = f2cmin(i__2,i__3); + +/* Update the upper triangle of the diagonal block */ + + i__2 = j + jb - 1; + for (jj = j; jj <= i__2; ++jj) { + i__3 = jj - j + 1; + i__4 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__3, &i__4, &z__1, &a[j + (k + 1) * + a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b1, + &a[j + jj * a_dim1], &c__1); +/* L40: */ + } + +/* Update the rectangular superdiagonal block */ + + if (j >= 2) { + i__2 = j - 1; + i__3 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &z__1, + &a[(k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * + w_dim1], ldw, &c_b1, &a[j * a_dim1 + 1], lda); + } +/* L50: */ + } + +/* Set KB to the number of columns factorized */ + + *kb = *n - k; + + } else { + +/* Factorize the leading columns of A using the lower triangle */ +/* of A and working forwards, and compute the matrix W = L21*D */ +/* for use in updating A22 */ + +/* Initialize the unused last entry of the subdiagonal array E. */ + + i__1 = *n; + e[i__1].r = 0., e[i__1].i = 0.; + +/* K is the main loop index, increasing from 1 in steps of 1 or 2 */ + + k = 1; +L70: + +/* Exit from loop */ + + if (k >= *nb && *nb < *n || k > *n) { + goto L90; + } + + kstep = 1; + p = k; + +/* Copy column K of A to column K of W and update it */ + + i__1 = *n - k + 1; + zcopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1); + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], lda, & + w[k + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1); + } + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = k + k * w_dim1; + absakk = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[k + k * + w_dim1]), abs(d__2)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k < *n) { + i__1 = *n - k; + imax = k + izamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = imax + k * w_dim1; + colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + k * w_dim1]), abs(d__2)); + } else { + colmax = 0.; + } + + if (f2cmax(absakk,colmax) == 0.) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + +/* Set E( K ) to zero */ + + if (k < *n) { + i__1 = k; + e[i__1].r = 0., e[i__1].i = 0.; + } + + } else { + +/* ============================================================ */ + +/* Test for interchange */ + +/* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX */ +/* (used to handle NaN and Inf) */ + + if (! (absakk < alpha * colmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + + } else { + + done = FALSE_; + +/* Loop until pivot found */ + +L72: + +/* Begin pivot search loop body */ + + +/* Copy column IMAX to column K+1 of W and update it */ + + i__1 = imax - k; + zcopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = *n - imax + 1; + zcopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + + 1) * w_dim1], &c__1); + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1] + , lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + + 1) * w_dim1], &c__1); + } + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine both ROWMAX and JMAX. */ + + if (imax != k) { + i__1 = imax - k; + jmax = k - 1 + izamax_(&i__1, &w[k + (k + 1) * w_dim1], & + c__1); + i__1 = jmax + (k + 1) * w_dim1; + rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(& + w[jmax + (k + 1) * w_dim1]), abs(d__2)); + } else { + rowmax = 0.; + } + + if (imax < *n) { + i__1 = *n - imax; + itemp = imax + izamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); + i__1 = itemp + (k + 1) * w_dim1; + dtemp = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + itemp + (k + 1) * w_dim1]), abs(d__2)); + if (dtemp > rowmax) { + rowmax = dtemp; + jmax = itemp; + } + } + +/* Equivalent to testing for */ +/* CABS1( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX */ +/* (used to handle NaN and Inf) */ + + i__1 = imax + (k + 1) * w_dim1; + if (! ((d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + (k + 1) * w_dim1]), abs(d__2)) < alpha * rowmax)) { + +/* interchange rows and columns K and IMAX, */ +/* use 1-by-1 pivot block */ + + kp = imax; + +/* copy column K+1 of W to column K of W */ + + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + + done = TRUE_; + +/* Equivalent to testing for ROWMAX.EQ.COLMAX, */ +/* (used to handle NaN and Inf) */ + + } else if (p == jmax || rowmax <= colmax) { + +/* interchange rows and columns K+1 and IMAX, */ +/* use 2-by-2 pivot block */ + + kp = imax; + kstep = 2; + done = TRUE_; + } else { + +/* Pivot not found: set params and repeat */ + + p = imax; + colmax = rowmax; + imax = jmax; + +/* Copy updated JMAXth (next IMAXth) column to Kth of W */ + + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + + } + +/* End pivot search loop body */ + + if (! done) { + goto L72; + } + + } + +/* ============================================================ */ + + kk = k + kstep - 1; + + if (kstep == 2 && p != k) { + +/* Copy non-updated column K to column P */ + + i__1 = p - k; + zcopy_(&i__1, &a[k + k * a_dim1], &c__1, &a[p + k * a_dim1], + lda); + i__1 = *n - p + 1; + zcopy_(&i__1, &a[p + k * a_dim1], &c__1, &a[p + p * a_dim1], & + c__1); + +/* Interchange rows K and P in first K columns of A */ +/* and first K+1 columns of W */ + + zswap_(&k, &a[k + a_dim1], lda, &a[p + a_dim1], lda); + zswap_(&kk, &w[k + w_dim1], ldw, &w[p + w_dim1], ldw); + } + +/* Updated column KP is already stored in column KK of W */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP */ + + i__1 = kp + k * a_dim1; + i__2 = kk + k * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp - k - 1; + zcopy_(&i__1, &a[k + 1 + kk * a_dim1], &c__1, &a[kp + (k + 1) + * a_dim1], lda); + i__1 = *n - kp + 1; + zcopy_(&i__1, &a[kp + kk * a_dim1], &c__1, &a[kp + kp * + a_dim1], &c__1); + +/* Interchange rows KK and KP in first KK columns of A and W */ + + zswap_(&kk, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + zswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k of W now holds */ + +/* W(k) = L(k)*D(k) */ + +/* where L(k) is the k-th column of L */ + +/* Store L(k) in column k of A */ + + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + i__1 = k + k * a_dim1; + if ((d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[k + + k * a_dim1]), abs(d__2)) >= sfmin) { + z_div(&z__1, &c_b1, &a[k + k * a_dim1]); + r1.r = z__1.r, r1.i = z__1.i; + i__1 = *n - k; + zscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + } else /* if(complicated condition) */ { + i__1 = k + k * a_dim1; + if (a[i__1].r != 0. || a[i__1].i != 0.) { + i__1 = *n; + for (ii = k + 1; ii <= i__1; ++ii) { + i__2 = ii + k * a_dim1; + z_div(&z__1, &a[ii + k * a_dim1], &a[k + k * + a_dim1]); + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L74: */ + } + } + } + +/* Store the subdiagonal element of D in array E */ + + i__1 = k; + e[i__1].r = 0., e[i__1].i = 0.; + + } + + } else { + +/* 2-by-2 pivot block D(k): columns k and k+1 of W now hold */ + +/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */ + +/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */ +/* of L */ + + if (k < *n - 1) { + +/* Store L(k) and L(k+1) in columns k and k+1 of A */ + + i__1 = k + 1 + k * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + z_div(&z__1, &w[k + 1 + (k + 1) * w_dim1], &d21); + d11.r = z__1.r, d11.i = z__1.i; + z_div(&z__1, &w[k + k * w_dim1], &d21); + d22.r = z__1.r, d22.i = z__1.i; + z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r * + d22.i + d11.i * d22.r; + z__2.r = z__3.r - 1., z__2.i = z__3.i + 0.; + z_div(&z__1, &c_b1, &z__2); + t.r = z__1.r, t.i = z__1.i; + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + i__3 = j + k * w_dim1; + z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + (k + 1) * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + z_div(&z__2, &z__3, &d21); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + (k + 1) * a_dim1; + i__3 = j + (k + 1) * w_dim1; + z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + k * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + z_div(&z__2, &z__3, &d21); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L80: */ + } + } + +/* Copy diagonal elements of D(K) to A, */ +/* copy subdiagonal element of D(K) to E(K) and */ +/* ZERO out subdiagonal entry of A */ + + i__1 = k + k * a_dim1; + i__2 = k + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + k * a_dim1; + a[i__1].r = 0., a[i__1].i = 0.; + i__1 = k + 1 + (k + 1) * a_dim1; + i__2 = k + 1 + (k + 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k; + i__2 = k + 1 + k * w_dim1; + e[i__1].r = w[i__2].r, e[i__1].i = w[i__2].i; + i__1 = k + 1; + e[i__1].r = 0., e[i__1].i = 0.; + + } + +/* End column K is nonsingular */ + + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + goto L70; + +L90: + +/* Update the lower triangle of A22 (= A(k:n,k:n)) as */ + +/* A22 := A22 - L21*D*L21**T = A22 - L21*W**T */ + +/* computing blocks of NB columns at a time */ + + i__1 = *n; + i__2 = *nb; + for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = *nb, i__4 = *n - j + 1; + jb = f2cmin(i__3,i__4); + +/* Update the lower triangle of the diagonal block */ + + i__3 = j + jb - 1; + for (jj = j; jj <= i__3; ++jj) { + i__4 = j + jb - jj; + i__5 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__4, &i__5, &z__1, &a[jj + a_dim1], + lda, &w[jj + w_dim1], ldw, &c_b1, &a[jj + jj * a_dim1] + , &c__1); +/* L100: */ + } + +/* Update the rectangular subdiagonal block */ + + if (j + jb <= *n) { + i__3 = *n - j - jb + 1; + i__4 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &z__1, + &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b1, + &a[j + jb + j * a_dim1], lda); + } +/* L110: */ + } + +/* Set KB to the number of columns factorized */ + + *kb = k - 1; + + } + + return 0; + +/* End of ZLASYF_RK */ + +} /* zlasyf_rk__ */ + diff --git a/lapack-netlib/SRC/zlasyf_rook.c b/lapack-netlib/SRC/zlasyf_rook.c new file mode 100644 index 000000000..2e654b204 --- /dev/null +++ b/lapack-netlib/SRC/zlasyf_rook.c @@ -0,0 +1,1522 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLASYF_ROOK computes a partial factorization of a complex symmetric matrix using the bounded Bu +nch-Kaufman ("rook") diagonal pivoting method. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLASYF_ROOK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, KB, LDA, LDW, N, NB */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), W( LDW, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLASYF_ROOK computes a partial factorization of a complex symmetric */ +/* > matrix A using the bounded Bunch-Kaufman ("rook") diagonal */ +/* > pivoting method. The partial factorization has the form: */ +/* > */ +/* > A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: */ +/* > ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) */ +/* > */ +/* > A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L' */ +/* > ( L21 I ) ( 0 A22 ) ( 0 I ) */ +/* > */ +/* > where the order of D is at most NB. The actual order is returned in */ +/* > the argument KB, and is either NB or NB-1, or N if N <= NB. */ +/* > */ +/* > ZLASYF_ROOK is an auxiliary routine called by ZSYTRF_ROOK. It uses */ +/* > blocked code (calling Level 3 BLAS) to update the submatrix */ +/* > A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). */ +/* > \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] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The maximum number of columns of the matrix A that should be */ +/* > factored. NB should be at least 2 to allow for 2-by-2 pivot */ +/* > blocks. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] KB */ +/* > \verbatim */ +/* > KB is INTEGER */ +/* > The number of columns of A that were actually factored. */ +/* > KB is either NB-1 or NB, or N if N <= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 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, A contains details of the partial factorization. */ +/* > \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': */ +/* > Only the last KB elements of IPIV are set. */ +/* > */ +/* > 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': */ +/* > Only the first KB elements of IPIV are set. */ +/* > */ +/* > 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] W */ +/* > \verbatim */ +/* > W is COMPLEX*16 array, dimension (LDW,NB) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDW */ +/* > \verbatim */ +/* > LDW is INTEGER */ +/* > The leading dimension of the array W. LDW >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > > 0: if INFO = k, D(k,k) is exactly zero. The factorization */ +/* > has been completed, but the block diagonal matrix D is */ +/* > exactly singular. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2013 */ + +/* > \ingroup complex16SYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2013, 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 zlasyf_rook_(char *uplo, integer *n, integer *nb, + integer *kb, doublecomplex *a, integer *lda, integer *ipiv, + doublecomplex *w, integer *ldw, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5; + doublereal d__1, d__2; + doublecomplex z__1, z__2, z__3, z__4; + + /* Local variables */ + logical done; + integer imax, jmax, j, k, p; + doublecomplex t; + doublereal alpha; + extern logical lsame_(char *, char *); + doublereal dtemp, sfmin; + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *); + integer itemp; + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + integer kstep; + extern /* Subroutine */ int zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + doublecomplex r1; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zswap_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *); + doublecomplex d11, d12, d21, d22; + integer jb, ii, jj, kk; + extern doublereal dlamch_(char *); + integer kp; + doublereal absakk; + integer kw; + doublereal colmax; + extern integer izamax_(integer *, doublecomplex *, integer *); + integer jp1, jp2; + doublereal rowmax; + integer kkw; + + +/* -- LAPACK computational routine (version 3.5.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2013 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1 * 1; + w -= w_offset; + + /* Function Body */ + *info = 0; + +/* Initialize ALPHA for use in choosing pivot block size. */ + + alpha = (sqrt(17.) + 1.) / 8.; + +/* Compute machine safe minimum */ + + sfmin = dlamch_("S"); + + if (lsame_(uplo, "U")) { + +/* Factorize the trailing columns of A using the upper triangle */ +/* of A and working backwards, and compute the matrix W = U12*D */ +/* for use in updating A11 */ + +/* K is the main loop index, decreasing from N in steps of 1 or 2 */ + + k = *n; +L10: + +/* KW is the column of W which corresponds to column K of A */ + + kw = *nb + k - *n; + +/* Exit from loop */ + + if (k <= *n - *nb + 1 && *nb < *n || k < 1) { + goto L30; + } + + kstep = 1; + p = k; + +/* Copy column K of A to column KW of W and update it */ + + zcopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); + if (k < *n) { + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b1, &w[kw * + w_dim1 + 1], &c__1); + } + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = k + kw * w_dim1; + absakk = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[k + kw * + w_dim1]), abs(d__2)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k > 1) { + i__1 = k - 1; + imax = izamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + i__1 = imax + kw * w_dim1; + colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + kw * w_dim1]), abs(d__2)); + } else { + colmax = 0.; + } + + if (f2cmax(absakk,colmax) == 0.) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + zcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + } else { + +/* ============================================================ */ + +/* Test for interchange */ + +/* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX */ +/* (used to handle NaN and Inf) */ + + if (! (absakk < alpha * colmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + + } else { + + done = FALSE_; + +/* Loop until pivot found */ + +L12: + +/* Begin pivot search loop body */ + + +/* Copy column IMAX to column KW-1 of W and update it */ + + zcopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + i__1 = k - imax; + zcopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + + if (k < *n) { + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &k, &i__1, &z__1, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b1, &w[(kw - 1) * w_dim1 + 1], &c__1); + } + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine both ROWMAX and JMAX. */ + + if (imax != k) { + i__1 = k - imax; + jmax = imax + izamax_(&i__1, &w[imax + 1 + (kw - 1) * + w_dim1], &c__1); + i__1 = jmax + (kw - 1) * w_dim1; + rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(& + w[jmax + (kw - 1) * w_dim1]), abs(d__2)); + } else { + rowmax = 0.; + } + + if (imax > 1) { + i__1 = imax - 1; + itemp = izamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); + i__1 = itemp + (kw - 1) * w_dim1; + dtemp = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + itemp + (kw - 1) * w_dim1]), abs(d__2)); + if (dtemp > rowmax) { + rowmax = dtemp; + jmax = itemp; + } + } + +/* Equivalent to testing for */ +/* CABS1( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX */ +/* (used to handle NaN and Inf) */ + + i__1 = imax + (kw - 1) * w_dim1; + if (! ((d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + (kw - 1) * w_dim1]), abs(d__2)) < alpha * rowmax)) { + +/* interchange rows and columns K and IMAX, */ +/* use 1-by-1 pivot block */ + + kp = imax; + +/* copy column KW-1 of W to column KW of W */ + + zcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + + done = TRUE_; + +/* Equivalent to testing for ROWMAX.EQ.COLMAX, */ +/* (used to handle NaN and Inf) */ + + } else if (p == jmax || rowmax <= colmax) { + +/* interchange rows and columns K-1 and IMAX, */ +/* use 2-by-2 pivot block */ + + kp = imax; + kstep = 2; + done = TRUE_; + } else { + +/* Pivot not found: set params and repeat */ + + p = imax; + colmax = rowmax; + imax = jmax; + +/* Copy updated JMAXth (next IMAXth) column to Kth of W */ + + zcopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + + } + +/* End pivot search loop body */ + + if (! done) { + goto L12; + } + + } + +/* ============================================================ */ + + kk = k - kstep + 1; + +/* KKW is the column of W which corresponds to column KK of A */ + + kkw = *nb + kk - *n; + + if (kstep == 2 && p != k) { + +/* Copy non-updated column K to column P */ + + i__1 = k - p; + zcopy_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + (p + 1) * + a_dim1], lda); + zcopy_(&p, &a[k * a_dim1 + 1], &c__1, &a[p * a_dim1 + 1], & + c__1); + +/* Interchange rows K and P in last N-K+1 columns of A */ +/* and last N-K+2 columns of W */ + + i__1 = *n - k + 1; + zswap_(&i__1, &a[k + k * a_dim1], lda, &a[p + k * a_dim1], + lda); + i__1 = *n - kk + 1; + zswap_(&i__1, &w[k + kkw * w_dim1], ldw, &w[p + kkw * w_dim1], + ldw); + } + +/* Updated column KP is already stored in column KKW of W */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP */ + + i__1 = kp + k * a_dim1; + i__2 = kk + k * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = k - 1 - kp; + zcopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + zcopy_(&kp, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], & + c__1); + +/* Interchange rows KK and KP in last N-KK+1 columns */ +/* of A and W */ + + i__1 = *n - kk + 1; + zswap_(&i__1, &a[kk + kk * a_dim1], lda, &a[kp + kk * a_dim1], + lda); + i__1 = *n - kk + 1; + zswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column KW of W now holds */ + +/* W(k) = U(k)*D(k) */ + +/* where U(k) is the k-th column of U */ + +/* Store U(k) in column k of A */ + + zcopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + if (k > 1) { + i__1 = k + k * a_dim1; + if ((d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[k + + k * a_dim1]), abs(d__2)) >= sfmin) { + z_div(&z__1, &c_b1, &a[k + k * a_dim1]); + r1.r = z__1.r, r1.i = z__1.i; + i__1 = k - 1; + zscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + } else /* if(complicated condition) */ { + i__1 = k + k * a_dim1; + if (a[i__1].r != 0. || a[i__1].i != 0.) { + i__1 = k - 1; + for (ii = 1; ii <= i__1; ++ii) { + i__2 = ii + k * a_dim1; + z_div(&z__1, &a[ii + k * a_dim1], &a[k + k * + a_dim1]); + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L14: */ + } + } + } + } + + } else { + +/* 2-by-2 pivot block D(k): columns KW and KW-1 of W now */ +/* hold */ + +/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */ + +/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ +/* of U */ + + if (k > 2) { + +/* Store U(k) and U(k-1) in columns k and k-1 of A */ + + i__1 = k - 1 + kw * w_dim1; + d12.r = w[i__1].r, d12.i = w[i__1].i; + z_div(&z__1, &w[k + kw * w_dim1], &d12); + d11.r = z__1.r, d11.i = z__1.i; + z_div(&z__1, &w[k - 1 + (kw - 1) * w_dim1], &d12); + d22.r = z__1.r, d22.i = z__1.i; + z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r * + d22.i + d11.i * d22.r; + z__2.r = z__3.r - 1., z__2.i = z__3.i + 0.; + z_div(&z__1, &c_b1, &z__2); + t.r = z__1.r, t.i = z__1.i; + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + i__2 = j + (k - 1) * a_dim1; + i__3 = j + (kw - 1) * w_dim1; + z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + kw * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + z_div(&z__2, &z__3, &d12); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + k * a_dim1; + i__3 = j + kw * w_dim1; + z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + (kw - 1) * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + z_div(&z__2, &z__3, &d12); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L20: */ + } + } + +/* Copy D(k) to A */ + + i__1 = k - 1 + (k - 1) * a_dim1; + i__2 = k - 1 + (kw - 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k - 1 + k * a_dim1; + i__2 = k - 1 + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + k * a_dim1; + i__2 = k + kw * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + goto L10; + +L30: + +/* Update the upper triangle of A11 (= A(1:k,1:k)) as */ + +/* A11 := A11 - U12*D*U12**T = A11 - U12*W**T */ + +/* computing blocks of NB columns at a time */ + + i__1 = -(*nb); + for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += + i__1) { +/* Computing MIN */ + i__2 = *nb, i__3 = k - j + 1; + jb = f2cmin(i__2,i__3); + +/* Update the upper triangle of the diagonal block */ + + i__2 = j + jb - 1; + for (jj = j; jj <= i__2; ++jj) { + i__3 = jj - j + 1; + i__4 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__3, &i__4, &z__1, &a[j + (k + 1) * + a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b1, + &a[j + jj * a_dim1], &c__1); +/* L40: */ + } + +/* Update the rectangular superdiagonal block */ + + if (j >= 2) { + i__2 = j - 1; + i__3 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &z__1, + &a[(k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * + w_dim1], ldw, &c_b1, &a[j * a_dim1 + 1], lda); + } +/* L50: */ + } + +/* Put U12 in standard form by partially undoing the interchanges */ +/* in columns k+1:n */ + + j = k + 1; +L60: + + kstep = 1; + jp1 = 1; + jj = j; + jp2 = ipiv[j]; + if (jp2 < 0) { + jp2 = -jp2; + ++j; + jp1 = -ipiv[j]; + kstep = 2; + } + + ++j; + if (jp2 != jj && j <= *n) { + i__1 = *n - j + 1; + zswap_(&i__1, &a[jp2 + j * a_dim1], lda, &a[jj + j * a_dim1], lda) + ; + } + jj = j - 1; + if (jp1 != jj && kstep == 2) { + i__1 = *n - j + 1; + zswap_(&i__1, &a[jp1 + j * a_dim1], lda, &a[jj + j * a_dim1], lda) + ; + } + if (j <= *n) { + goto L60; + } + +/* Set KB to the number of columns factorized */ + + *kb = *n - k; + + } else { + +/* Factorize the leading columns of A using the lower triangle */ +/* of A and working forwards, and compute the matrix W = L21*D */ +/* for use in updating A22 */ + +/* K is the main loop index, increasing from 1 in steps of 1 or 2 */ + + k = 1; +L70: + +/* Exit from loop */ + + if (k >= *nb && *nb < *n || k > *n) { + goto L90; + } + + kstep = 1; + p = k; + +/* Copy column K of A to column K of W and update it */ + + i__1 = *n - k + 1; + zcopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1); + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1], lda, & + w[k + w_dim1], ldw, &c_b1, &w[k + k * w_dim1], &c__1); + } + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = k + k * w_dim1; + absakk = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[k + k * + w_dim1]), abs(d__2)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k < *n) { + i__1 = *n - k; + imax = k + izamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + i__1 = imax + k * w_dim1; + colmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + k * w_dim1]), abs(d__2)); + } else { + colmax = 0.; + } + + if (f2cmax(absakk,colmax) == 0.) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + } else { + +/* ============================================================ */ + +/* Test for interchange */ + +/* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX */ +/* (used to handle NaN and Inf) */ + + if (! (absakk < alpha * colmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + + } else { + + done = FALSE_; + +/* Loop until pivot found */ + +L72: + +/* Begin pivot search loop body */ + + +/* Copy column IMAX to column K+1 of W and update it */ + + i__1 = imax - k; + zcopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = *n - imax + 1; + zcopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + + 1) * w_dim1], &c__1); + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__1, &i__2, &z__1, &a[k + a_dim1] + , lda, &w[imax + w_dim1], ldw, &c_b1, &w[k + (k + + 1) * w_dim1], &c__1); + } + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine both ROWMAX and JMAX. */ + + if (imax != k) { + i__1 = imax - k; + jmax = k - 1 + izamax_(&i__1, &w[k + (k + 1) * w_dim1], & + c__1); + i__1 = jmax + (k + 1) * w_dim1; + rowmax = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(& + w[jmax + (k + 1) * w_dim1]), abs(d__2)); + } else { + rowmax = 0.; + } + + if (imax < *n) { + i__1 = *n - imax; + itemp = imax + izamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); + i__1 = itemp + (k + 1) * w_dim1; + dtemp = (d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[ + itemp + (k + 1) * w_dim1]), abs(d__2)); + if (dtemp > rowmax) { + rowmax = dtemp; + jmax = itemp; + } + } + +/* Equivalent to testing for */ +/* CABS1( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX */ +/* (used to handle NaN and Inf) */ + + i__1 = imax + (k + 1) * w_dim1; + if (! ((d__1 = w[i__1].r, abs(d__1)) + (d__2 = d_imag(&w[imax + + (k + 1) * w_dim1]), abs(d__2)) < alpha * rowmax)) { + +/* interchange rows and columns K and IMAX, */ +/* use 1-by-1 pivot block */ + + kp = imax; + +/* copy column K+1 of W to column K of W */ + + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + + done = TRUE_; + +/* Equivalent to testing for ROWMAX.EQ.COLMAX, */ +/* (used to handle NaN and Inf) */ + + } else if (p == jmax || rowmax <= colmax) { + +/* interchange rows and columns K+1 and IMAX, */ +/* use 2-by-2 pivot block */ + + kp = imax; + kstep = 2; + done = TRUE_; + } else { + +/* Pivot not found: set params and repeat */ + + p = imax; + colmax = rowmax; + imax = jmax; + +/* Copy updated JMAXth (next IMAXth) column to Kth of W */ + + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + + } + +/* End pivot search loop body */ + + if (! done) { + goto L72; + } + + } + +/* ============================================================ */ + + kk = k + kstep - 1; + + if (kstep == 2 && p != k) { + +/* Copy non-updated column K to column P */ + + i__1 = p - k; + zcopy_(&i__1, &a[k + k * a_dim1], &c__1, &a[p + k * a_dim1], + lda); + i__1 = *n - p + 1; + zcopy_(&i__1, &a[p + k * a_dim1], &c__1, &a[p + p * a_dim1], & + c__1); + +/* Interchange rows K and P in first K columns of A */ +/* and first K+1 columns of W */ + + zswap_(&k, &a[k + a_dim1], lda, &a[p + a_dim1], lda); + zswap_(&kk, &w[k + w_dim1], ldw, &w[p + w_dim1], ldw); + } + +/* Updated column KP is already stored in column KK of W */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP */ + + i__1 = kp + k * a_dim1; + i__2 = kk + k * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp - k - 1; + zcopy_(&i__1, &a[k + 1 + kk * a_dim1], &c__1, &a[kp + (k + 1) + * a_dim1], lda); + i__1 = *n - kp + 1; + zcopy_(&i__1, &a[kp + kk * a_dim1], &c__1, &a[kp + kp * + a_dim1], &c__1); + +/* Interchange rows KK and KP in first KK columns of A and W */ + + zswap_(&kk, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + zswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k of W now holds */ + +/* W(k) = L(k)*D(k) */ + +/* where L(k) is the k-th column of L */ + +/* Store L(k) in column k of A */ + + i__1 = *n - k + 1; + zcopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + i__1 = k + k * a_dim1; + if ((d__1 = a[i__1].r, abs(d__1)) + (d__2 = d_imag(&a[k + + k * a_dim1]), abs(d__2)) >= sfmin) { + z_div(&z__1, &c_b1, &a[k + k * a_dim1]); + r1.r = z__1.r, r1.i = z__1.i; + i__1 = *n - k; + zscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + } else /* if(complicated condition) */ { + i__1 = k + k * a_dim1; + if (a[i__1].r != 0. || a[i__1].i != 0.) { + i__1 = *n; + for (ii = k + 1; ii <= i__1; ++ii) { + i__2 = ii + k * a_dim1; + z_div(&z__1, &a[ii + k * a_dim1], &a[k + k * + a_dim1]); + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L74: */ + } + } + } + } + + } else { + +/* 2-by-2 pivot block D(k): columns k and k+1 of W now hold */ + +/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */ + +/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */ +/* of L */ + + if (k < *n - 1) { + +/* Store L(k) and L(k+1) in columns k and k+1 of A */ + + i__1 = k + 1 + k * w_dim1; + d21.r = w[i__1].r, d21.i = w[i__1].i; + z_div(&z__1, &w[k + 1 + (k + 1) * w_dim1], &d21); + d11.r = z__1.r, d11.i = z__1.i; + z_div(&z__1, &w[k + k * w_dim1], &d21); + d22.r = z__1.r, d22.i = z__1.i; + z__3.r = d11.r * d22.r - d11.i * d22.i, z__3.i = d11.r * + d22.i + d11.i * d22.r; + z__2.r = z__3.r - 1., z__2.i = z__3.i + 0.; + z_div(&z__1, &c_b1, &z__2); + t.r = z__1.r, t.i = z__1.i; + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + i__2 = j + k * a_dim1; + i__3 = j + k * w_dim1; + z__4.r = d11.r * w[i__3].r - d11.i * w[i__3].i, + z__4.i = d11.r * w[i__3].i + d11.i * w[i__3] + .r; + i__4 = j + (k + 1) * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + z_div(&z__2, &z__3, &d21); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = j + (k + 1) * a_dim1; + i__3 = j + (k + 1) * w_dim1; + z__4.r = d22.r * w[i__3].r - d22.i * w[i__3].i, + z__4.i = d22.r * w[i__3].i + d22.i * w[i__3] + .r; + i__4 = j + k * w_dim1; + z__3.r = z__4.r - w[i__4].r, z__3.i = z__4.i - w[i__4] + .i; + z_div(&z__2, &z__3, &d21); + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * + z__2.i + t.i * z__2.r; + a[i__2].r = z__1.r, a[i__2].i = z__1.i; +/* L80: */ + } + } + +/* Copy D(k) to A */ + + i__1 = k + k * a_dim1; + i__2 = k + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + k * a_dim1; + i__2 = k + 1 + k * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + i__1 = k + 1 + (k + 1) * a_dim1; + i__2 = k + 1 + (k + 1) * w_dim1; + a[i__1].r = w[i__2].r, a[i__1].i = w[i__2].i; + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + goto L70; + +L90: + +/* Update the lower triangle of A22 (= A(k:n,k:n)) as */ + +/* A22 := A22 - L21*D*L21**T = A22 - L21*W**T */ + +/* computing blocks of NB columns at a time */ + + i__1 = *n; + i__2 = *nb; + for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = *nb, i__4 = *n - j + 1; + jb = f2cmin(i__3,i__4); + +/* Update the lower triangle of the diagonal block */ + + i__3 = j + jb - 1; + for (jj = j; jj <= i__3; ++jj) { + i__4 = j + jb - jj; + i__5 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__4, &i__5, &z__1, &a[jj + a_dim1], + lda, &w[jj + w_dim1], ldw, &c_b1, &a[jj + jj * a_dim1] + , &c__1); +/* L100: */ + } + +/* Update the rectangular subdiagonal block */ + + if (j + jb <= *n) { + i__3 = *n - j - jb + 1; + i__4 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &z__1, + &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b1, + &a[j + jb + j * a_dim1], lda); + } +/* L110: */ + } + +/* Put L21 in standard form by partially undoing the interchanges */ +/* in columns 1:k-1 */ + + j = k - 1; +L120: + + kstep = 1; + jp1 = 1; + jj = j; + jp2 = ipiv[j]; + if (jp2 < 0) { + jp2 = -jp2; + --j; + jp1 = -ipiv[j]; + kstep = 2; + } + + --j; + if (jp2 != jj && j >= 1) { + zswap_(&j, &a[jp2 + a_dim1], lda, &a[jj + a_dim1], lda); + } + jj = j + 1; + if (jp1 != jj && kstep == 2) { + zswap_(&j, &a[jp1 + a_dim1], lda, &a[jj + a_dim1], lda); + } + if (j >= 1) { + goto L120; + } + +/* Set KB to the number of columns factorized */ + + *kb = k - 1; + + } + return 0; + +/* End of ZLASYF_ROOK */ + +} /* zlasyf_rook__ */ + diff --git a/lapack-netlib/SRC/zlat2c.c b/lapack-netlib/SRC/zlat2c.c new file mode 100644 index 000000000..ac9a826c0 --- /dev/null +++ b/lapack-netlib/SRC/zlat2c.c @@ -0,0 +1,581 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLAT2C converts a double complex triangular matrix to a complex triangular matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLAT2C + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLAT2C( UPLO, N, A, LDA, SA, LDSA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDSA, N */ +/* COMPLEX SA( LDSA, * ) */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLAT2C converts a COMPLEX*16 triangular matrix, SA, to a COMPLEX */ +/* > triangular matrix, A. */ +/* > */ +/* > RMAX is the overflow for the SINGLE PRECISION arithmetic */ +/* > ZLAT2C checks that all the entries of A are between -RMAX and */ +/* > RMAX. If not the conversion is aborted and a flag is raised. */ +/* > */ +/* > This is an auxiliary routine so there is no argument checking. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of rows and columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the N-by-N triangular coefficient matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SA */ +/* > \verbatim */ +/* > SA is COMPLEX array, dimension (LDSA,N) */ +/* > Only the UPLO part of SA is referenced. On exit, if INFO=0, */ +/* > the N-by-N coefficient matrix SA; if INFO>0, the content of */ +/* > the UPLO part of SA is unspecified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDSA */ +/* > \verbatim */ +/* > LDSA is INTEGER */ +/* > The leading dimension of the array SA. LDSA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > = 1: an entry of the matrix A is greater than the SINGLE */ +/* > PRECISION overflow threshold, in this case, the content */ +/* > of the UPLO part of SA in exit is unspecified. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlat2c_(char *uplo, integer *n, doublecomplex *a, + integer *lda, complex *sa, integer *ldsa, integer *info) +{ + /* System generated locals */ + integer sa_dim1, sa_offset, a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + doublereal rmax; + integer i__, j; + extern logical lsame_(char *, char *); + logical upper; + extern real slamch_(char *); + + +/* -- 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; + sa_dim1 = *ldsa; + sa_offset = 1 + sa_dim1 * 1; + sa -= sa_offset; + + /* Function Body */ + rmax = slamch_("O"); + upper = lsame_(uplo, "U"); + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + if (a[i__3].r < -rmax || a[i__4].r > rmax || d_imag(&a[i__ + + j * a_dim1]) < -rmax || d_imag(&a[i__ + j * a_dim1]) + > rmax) { + *info = 1; + goto L50; + } + i__3 = i__ + j * sa_dim1; + i__4 = i__ + j * a_dim1; + sa[i__3].r = a[i__4].r, sa[i__3].i = a[i__4].i; +/* L10: */ + } +/* L20: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + j * a_dim1; + i__4 = i__ + j * a_dim1; + if (a[i__3].r < -rmax || a[i__4].r > rmax || d_imag(&a[i__ + + j * a_dim1]) < -rmax || d_imag(&a[i__ + j * a_dim1]) + > rmax) { + *info = 1; + goto L50; + } + i__3 = i__ + j * sa_dim1; + i__4 = i__ + j * a_dim1; + sa[i__3].r = a[i__4].r, sa[i__3].i = a[i__4].i; +/* L30: */ + } +/* L40: */ + } + } +L50: + + return 0; + +/* End of ZLAT2C */ + +} /* zlat2c_ */ + diff --git a/lapack-netlib/SRC/zlatbs.c b/lapack-netlib/SRC/zlatbs.c new file mode 100644 index 000000000..fb3c8696d --- /dev/null +++ b/lapack-netlib/SRC/zlatbs.c @@ -0,0 +1,1636 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLATBS solves a triangular banded system of equations. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLATBS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, */ +/* SCALE, CNORM, INFO ) */ + +/* CHARACTER DIAG, NORMIN, TRANS, UPLO */ +/* INTEGER INFO, KD, LDAB, N */ +/* DOUBLE PRECISION SCALE */ +/* DOUBLE PRECISION CNORM( * ) */ +/* COMPLEX*16 AB( LDAB, * ), X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLATBS solves one of the triangular systems */ +/* > */ +/* > A * x = s*b, A**T * x = s*b, or A**H * x = s*b, */ +/* > */ +/* > with scaling to prevent overflow, where A is an upper or lower */ +/* > triangular band matrix. Here A**T denotes the transpose of A, x and b */ +/* > are n-element vectors, and s is a scaling factor, usually less than */ +/* > or equal to 1, chosen so that the components of x will be less than */ +/* > the overflow threshold. If the unscaled problem will not cause */ +/* > overflow, the Level 2 BLAS routine ZTBSV is called. If the matrix A */ +/* > is singular (A(j,j) = 0 for some j), then s is set to 0 and a */ +/* > non-trivial solution to A*x = 0 is returned. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the matrix A is upper or lower triangular. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the operation applied to A. */ +/* > = 'N': Solve A * x = s*b (No transpose) */ +/* > = 'T': Solve A**T * x = s*b (Transpose) */ +/* > = 'C': Solve A**H * x = s*b (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > Specifies whether or not the matrix A is unit triangular. */ +/* > = 'N': Non-unit triangular */ +/* > = 'U': Unit triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NORMIN */ +/* > \verbatim */ +/* > NORMIN is CHARACTER*1 */ +/* > Specifies whether CNORM has been set or not. */ +/* > = 'Y': CNORM contains the column norms on entry */ +/* > = 'N': CNORM is not set on entry. On exit, the norms will */ +/* > be computed and stored in CNORM. */ +/* > \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 subdiagonals or superdiagonals in the */ +/* > triangular matrix A. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is COMPLEX*16 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). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (N) */ +/* > On entry, the right hand side b of the triangular system. */ +/* > On exit, X is overwritten by the solution vector x. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE */ +/* > \verbatim */ +/* > SCALE is DOUBLE PRECISION */ +/* > The scaling factor s for the triangular system */ +/* > A * x = s*b, A**T * x = s*b, or A**H * x = s*b. */ +/* > If SCALE = 0, the matrix A is singular or badly scaled, and */ +/* > the vector x is an exact or approximate solution to A*x = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] CNORM */ +/* > \verbatim */ +/* > CNORM is DOUBLE PRECISION array, dimension (N) */ +/* > */ +/* > If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */ +/* > contains the norm of the off-diagonal part of the j-th column */ +/* > of A. If TRANS = 'N', CNORM(j) must be greater than or equal */ +/* > to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */ +/* > must be greater than or equal to the 1-norm. */ +/* > */ +/* > If NORMIN = 'N', CNORM is an output argument and CNORM(j) */ +/* > returns the 1-norm of the offdiagonal part of the j-th column */ +/* > of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-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 complex16OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > A rough bound on x is computed; if that is less than overflow, ZTBSV */ +/* > is called, otherwise, specific code is used which checks for possible */ +/* > overflow or divide-by-zero at every operation. */ +/* > */ +/* > A columnwise scheme is used for solving A*x = b. The basic algorithm */ +/* > if A is lower triangular is */ +/* > */ +/* > x[1:n] := b[1:n] */ +/* > for j = 1, ..., n */ +/* > x(j) := x(j) / A(j,j) */ +/* > x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */ +/* > end */ +/* > */ +/* > Define bounds on the components of x after j iterations of the loop: */ +/* > M(j) = bound on x[1:j] */ +/* > G(j) = bound on x[j+1:n] */ +/* > Initially, let M(0) = 0 and G(0) = f2cmax{x(i), i=1,...,n}. */ +/* > */ +/* > Then for iteration j+1 we have */ +/* > M(j+1) <= G(j) / | A(j+1,j+1) | */ +/* > G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */ +/* > <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */ +/* > */ +/* > where CNORM(j+1) is greater than or equal to the infinity-norm of */ +/* > column j+1 of A, not counting the diagonal. Hence */ +/* > */ +/* > G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */ +/* > 1<=i<=j */ +/* > and */ +/* > */ +/* > |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */ +/* > 1<=i< j */ +/* > */ +/* > Since |x(j)| <= M(j), we use the Level 2 BLAS routine ZTBSV if the */ +/* > reciprocal of the largest M(j), j=1,..,n, is larger than */ +/* > f2cmax(underflow, 1/overflow). */ +/* > */ +/* > The bound on x(j) is also used to determine when a step in the */ +/* > columnwise method can be performed without fear of overflow. If */ +/* > the computed bound is greater than a large constant, x is scaled to */ +/* > prevent overflow, but if the bound overflows, x is set to 0, x(j) to */ +/* > 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */ +/* > */ +/* > Similarly, a row-wise scheme is used to solve A**T *x = b or */ +/* > A**H *x = b. The basic algorithm for A upper triangular is */ +/* > */ +/* > for j = 1, ..., n */ +/* > x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */ +/* > end */ +/* > */ +/* > We simultaneously compute two bounds */ +/* > G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */ +/* > M(j) = bound on x(i), 1<=i<=j */ +/* > */ +/* > The initial values are G(0) = 0, M(0) = f2cmax{b(i), i=1,..,n}, and we */ +/* > add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */ +/* > Then the bound on x(j) is */ +/* > */ +/* > M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */ +/* > */ +/* > <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */ +/* > 1<=i<=j */ +/* > */ +/* > and we can safely call ZTBSV if 1/M(n) and 1/G(n) are both greater */ +/* > than f2cmax(underflow, 1/overflow). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlatbs_(char *uplo, char *trans, char *diag, char * + normin, integer *n, integer *kd, doublecomplex *ab, integer *ldab, + doublecomplex *x, doublereal *scale, doublereal *cnorm, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5; + doublereal d__1, d__2, d__3, d__4; + doublecomplex z__1, z__2, z__3, z__4; + + /* Local variables */ + integer jinc, jlen; + doublereal xbnd; + integer imax; + doublereal tmax; + doublecomplex tjjs; + doublereal xmax, grow; + integer i__, j; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + integer maind; + extern logical lsame_(char *, char *); + doublereal tscal; + doublecomplex uscal; + integer jlast; + doublecomplex csumj; + extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + logical upper; + extern /* Double Complex */ VOID zdotu_(doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + extern /* Subroutine */ int ztbsv_(char *, char *, char *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *), dlabad_( + doublereal *, doublereal *); + extern doublereal dlamch_(char *); + doublereal xj; + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zdscal_( + integer *, doublereal *, doublecomplex *, integer *); + doublereal bignum; + extern integer izamax_(integer *, doublecomplex *, integer *); + extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *, + doublecomplex *); + logical notran; + integer jfirst; + extern doublereal dzasum_(integer *, doublecomplex *, integer *); + doublereal smlnum; + logical nounit; + doublereal rec, tjj; + + +/* -- LAPACK auxiliary 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 */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --x; + --cnorm; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + notran = lsame_(trans, "N"); + nounit = lsame_(diag, "N"); + +/* Test the input parameters. */ + + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (! lsame_(normin, "Y") && ! lsame_(normin, + "N")) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*kd < 0) { + *info = -6; + } else if (*ldab < *kd + 1) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLATBS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Determine machine dependent parameters to control overflow. */ + + smlnum = dlamch_("Safe minimum"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + smlnum /= dlamch_("Precision"); + bignum = 1. / smlnum; + *scale = 1.; + + if (lsame_(normin, "N")) { + +/* Compute the 1-norm of each column, not including the diagonal. */ + + if (upper) { + +/* A is upper triangular. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = *kd, i__3 = j - 1; + jlen = f2cmin(i__2,i__3); + cnorm[j] = dzasum_(&jlen, &ab[*kd + 1 - jlen + j * ab_dim1], & + c__1); +/* L10: */ + } + } else { + +/* A is lower triangular. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = *kd, i__3 = *n - j; + jlen = f2cmin(i__2,i__3); + if (jlen > 0) { + cnorm[j] = dzasum_(&jlen, &ab[j * ab_dim1 + 2], &c__1); + } else { + cnorm[j] = 0.; + } +/* L20: */ + } + } + } + +/* Scale the column norms by TSCAL if the maximum element in CNORM is */ +/* greater than BIGNUM/2. */ + + imax = idamax_(n, &cnorm[1], &c__1); + tmax = cnorm[imax]; + if (tmax <= bignum * .5) { + tscal = 1.; + } else { + tscal = .5 / (smlnum * tmax); + dscal_(n, &tscal, &cnorm[1], &c__1); + } + +/* Compute a bound on the computed solution vector to see if the */ +/* Level 2 BLAS routine ZTBSV can be used. */ + + xmax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = j; + d__3 = xmax, d__4 = (d__1 = x[i__2].r / 2., abs(d__1)) + (d__2 = + d_imag(&x[j]) / 2., abs(d__2)); + xmax = f2cmax(d__3,d__4); +/* L30: */ + } + xbnd = xmax; + if (notran) { + +/* Compute the growth in A * x = b. */ + + if (upper) { + jfirst = *n; + jlast = 1; + jinc = -1; + maind = *kd + 1; + } else { + jfirst = 1; + jlast = *n; + jinc = 1; + maind = 1; + } + + if (tscal != 1.) { + grow = 0.; + goto L60; + } + + if (nounit) { + +/* A is non-unit triangular. */ + +/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ +/* Initially, G(0) = f2cmax{x(i), i=1,...,n}. */ + + grow = .5 / f2cmax(xbnd,smlnum); + xbnd = grow; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L60; + } + + i__3 = maind + j * ab_dim1; + tjjs.r = ab[i__3].r, tjjs.i = ab[i__3].i; + tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs( + d__2)); + + if (tjj >= smlnum) { + +/* M(j) = G(j-1) / abs(A(j,j)) */ + +/* Computing MIN */ + d__1 = xbnd, d__2 = f2cmin(1.,tjj) * grow; + xbnd = f2cmin(d__1,d__2); + } else { + +/* M(j) could overflow, set XBND to 0. */ + + xbnd = 0.; + } + + if (tjj + cnorm[j] >= smlnum) { + +/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */ + + grow *= tjj / (tjj + cnorm[j]); + } else { + +/* G(j) could overflow, set GROW to 0. */ + + grow = 0.; + } +/* L40: */ + } + grow = xbnd; + } else { + +/* A is unit triangular. */ + +/* Compute GROW = 1/G(j), where G(0) = f2cmax{x(i), i=1,...,n}. */ + +/* Computing MIN */ + d__1 = 1., d__2 = .5 / f2cmax(xbnd,smlnum); + grow = f2cmin(d__1,d__2); + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L60; + } + +/* G(j) = G(j-1)*( 1 + CNORM(j) ) */ + + grow *= 1. / (cnorm[j] + 1.); +/* L50: */ + } + } +L60: + + ; + } else { + +/* Compute the growth in A**T * x = b or A**H * x = b. */ + + if (upper) { + jfirst = 1; + jlast = *n; + jinc = 1; + maind = *kd + 1; + } else { + jfirst = *n; + jlast = 1; + jinc = -1; + maind = 1; + } + + if (tscal != 1.) { + grow = 0.; + goto L90; + } + + if (nounit) { + +/* A is non-unit triangular. */ + +/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ +/* Initially, M(0) = f2cmax{x(i), i=1,...,n}. */ + + grow = .5 / f2cmax(xbnd,smlnum); + xbnd = grow; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L90; + } + +/* G(j) = f2cmax( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */ + + xj = cnorm[j] + 1.; +/* Computing MIN */ + d__1 = grow, d__2 = xbnd / xj; + grow = f2cmin(d__1,d__2); + + i__3 = maind + j * ab_dim1; + tjjs.r = ab[i__3].r, tjjs.i = ab[i__3].i; + tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs( + d__2)); + + if (tjj >= smlnum) { + +/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */ + + if (xj > tjj) { + xbnd *= tjj / xj; + } + } else { + +/* M(j) could overflow, set XBND to 0. */ + + xbnd = 0.; + } +/* L70: */ + } + grow = f2cmin(grow,xbnd); + } else { + +/* A is unit triangular. */ + +/* Compute GROW = 1/G(j), where G(0) = f2cmax{x(i), i=1,...,n}. */ + +/* Computing MIN */ + d__1 = 1., d__2 = .5 / f2cmax(xbnd,smlnum); + grow = f2cmin(d__1,d__2); + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L90; + } + +/* G(j) = ( 1 + CNORM(j) )*G(j-1) */ + + xj = cnorm[j] + 1.; + grow /= xj; +/* L80: */ + } + } +L90: + ; + } + + if (grow * tscal > smlnum) { + +/* Use the Level 2 BLAS solve if the reciprocal of the bound on */ +/* elements of X is not too small. */ + + ztbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &x[1], &c__1); + } else { + +/* Use a Level 1 BLAS solve, scaling intermediate results. */ + + if (xmax > bignum * .5) { + +/* Scale X so that its components are less than or equal to */ +/* BIGNUM in absolute value. */ + + *scale = bignum * .5 / xmax; + zdscal_(n, scale, &x[1], &c__1); + xmax = bignum; + } else { + xmax *= 2.; + } + + if (notran) { + +/* Solve A * x = b */ + + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */ + + i__3 = j; + xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), + abs(d__2)); + if (nounit) { + i__3 = maind + j * ab_dim1; + z__1.r = tscal * ab[i__3].r, z__1.i = tscal * ab[i__3].i; + tjjs.r = z__1.r, tjjs.i = z__1.i; + } else { + tjjs.r = tscal, tjjs.i = 0.; + if (tscal == 1.) { + goto L110; + } + } + tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), abs( + d__2)); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.) { + if (xj > tjj * bignum) { + +/* Scale x by 1/b(j). */ + + rec = 1. / xj; + zdscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + i__3 = j; + zladiv_(&z__1, &x[j], &tjjs); + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + i__3 = j; + xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]) + , abs(d__2)); + } else if (tjj > 0.) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */ +/* to avoid overflow when dividing by A(j,j). */ + + rec = tjj * bignum / xj; + if (cnorm[j] > 1.) { + +/* Scale by 1/CNORM(j) to avoid overflow when */ +/* multiplying x(j) times column j. */ + + rec /= cnorm[j]; + } + zdscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + i__3 = j; + zladiv_(&z__1, &x[j], &tjjs); + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + i__3 = j; + xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]) + , abs(d__2)); + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0, and compute a solution to A*x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + x[i__4].r = 0., x[i__4].i = 0.; +/* L100: */ + } + i__3 = j; + x[i__3].r = 1., x[i__3].i = 0.; + xj = 1.; + *scale = 0.; + xmax = 0.; + } +L110: + +/* Scale x if necessary to avoid overflow when adding a */ +/* multiple of column j of A. */ + + if (xj > 1.) { + rec = 1. / xj; + if (cnorm[j] > (bignum - xmax) * rec) { + +/* Scale x by 1/(2*abs(x(j))). */ + + rec *= .5; + zdscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + } + } else if (xj * cnorm[j] > bignum - xmax) { + +/* Scale x by 1/2. */ + + zdscal_(n, &c_b36, &x[1], &c__1); + *scale *= .5; + } + + if (upper) { + if (j > 1) { + +/* Compute the update */ +/* x(f2cmax(1,j-kd):j-1) := x(f2cmax(1,j-kd):j-1) - */ +/* x(j)* A(f2cmax(1,j-kd):j-1,j) */ + +/* Computing MIN */ + i__3 = *kd, i__4 = j - 1; + jlen = f2cmin(i__3,i__4); + i__3 = j; + z__2.r = -x[i__3].r, z__2.i = -x[i__3].i; + z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i; + zaxpy_(&jlen, &z__1, &ab[*kd + 1 - jlen + j * ab_dim1] + , &c__1, &x[j - jlen], &c__1); + i__3 = j - 1; + i__ = izamax_(&i__3, &x[1], &c__1); + i__3 = i__; + xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag( + &x[i__]), abs(d__2)); + } + } else if (j < *n) { + +/* Compute the update */ +/* x(j+1:f2cmin(j+kd,n)) := x(j+1:f2cmin(j+kd,n)) - */ +/* x(j) * A(j+1:f2cmin(j+kd,n),j) */ + +/* Computing MIN */ + i__3 = *kd, i__4 = *n - j; + jlen = f2cmin(i__3,i__4); + if (jlen > 0) { + i__3 = j; + z__2.r = -x[i__3].r, z__2.i = -x[i__3].i; + z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i; + zaxpy_(&jlen, &z__1, &ab[j * ab_dim1 + 2], &c__1, &x[ + j + 1], &c__1); + } + i__3 = *n - j; + i__ = j + izamax_(&i__3, &x[j + 1], &c__1); + i__3 = i__; + xmax = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[ + i__]), abs(d__2)); + } +/* L120: */ + } + + } else if (lsame_(trans, "T")) { + +/* Solve A**T * x = b */ + + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Compute x(j) = b(j) - sum A(k,j)*x(k). */ +/* k<>j */ + + i__3 = j; + xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), + abs(d__2)); + uscal.r = tscal, uscal.i = 0.; + rec = 1. / f2cmax(xmax,1.); + if (cnorm[j] > (bignum - xj) * rec) { + +/* If x(j) could overflow, scale x by 1/(2*XMAX). */ + + rec *= .5; + if (nounit) { + i__3 = maind + j * ab_dim1; + z__1.r = tscal * ab[i__3].r, z__1.i = tscal * ab[i__3] + .i; + tjjs.r = z__1.r, tjjs.i = z__1.i; + } else { + tjjs.r = tscal, tjjs.i = 0.; + } + tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), + abs(d__2)); + if (tjj > 1.) { + +/* Divide by A(j,j) when scaling x if A(j,j) > 1. */ + +/* Computing MIN */ + d__1 = 1., d__2 = rec * tjj; + rec = f2cmin(d__1,d__2); + zladiv_(&z__1, &uscal, &tjjs); + uscal.r = z__1.r, uscal.i = z__1.i; + } + if (rec < 1.) { + zdscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + + csumj.r = 0., csumj.i = 0.; + if (uscal.r == 1. && uscal.i == 0.) { + +/* If the scaling needed for A in the dot product is 1, */ +/* call ZDOTU to perform the dot product. */ + + if (upper) { +/* Computing MIN */ + i__3 = *kd, i__4 = j - 1; + jlen = f2cmin(i__3,i__4); + zdotu_(&z__1, &jlen, &ab[*kd + 1 - jlen + j * ab_dim1] + , &c__1, &x[j - jlen], &c__1); + csumj.r = z__1.r, csumj.i = z__1.i; + } else { +/* Computing MIN */ + i__3 = *kd, i__4 = *n - j; + jlen = f2cmin(i__3,i__4); + if (jlen > 1) { + zdotu_(&z__1, &jlen, &ab[j * ab_dim1 + 2], &c__1, + &x[j + 1], &c__1); + csumj.r = z__1.r, csumj.i = z__1.i; + } + } + } else { + +/* Otherwise, use in-line code for the dot product. */ + + if (upper) { +/* Computing MIN */ + i__3 = *kd, i__4 = j - 1; + jlen = f2cmin(i__3,i__4); + i__3 = jlen; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = *kd + i__ - jlen + j * ab_dim1; + z__3.r = ab[i__4].r * uscal.r - ab[i__4].i * + uscal.i, z__3.i = ab[i__4].r * uscal.i + + ab[i__4].i * uscal.r; + i__5 = j - jlen - 1 + i__; + z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i, + z__2.i = z__3.r * x[i__5].i + z__3.i * x[ + i__5].r; + z__1.r = csumj.r + z__2.r, z__1.i = csumj.i + + z__2.i; + csumj.r = z__1.r, csumj.i = z__1.i; +/* L130: */ + } + } else { +/* Computing MIN */ + i__3 = *kd, i__4 = *n - j; + jlen = f2cmin(i__3,i__4); + i__3 = jlen; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + 1 + j * ab_dim1; + z__3.r = ab[i__4].r * uscal.r - ab[i__4].i * + uscal.i, z__3.i = ab[i__4].r * uscal.i + + ab[i__4].i * uscal.r; + i__5 = j + i__; + z__2.r = z__3.r * x[i__5].r - z__3.i * x[i__5].i, + z__2.i = z__3.r * x[i__5].i + z__3.i * x[ + i__5].r; + z__1.r = csumj.r + z__2.r, z__1.i = csumj.i + + z__2.i; + csumj.r = z__1.r, csumj.i = z__1.i; +/* L140: */ + } + } + } + + z__1.r = tscal, z__1.i = 0.; + if (uscal.r == z__1.r && uscal.i == z__1.i) { + +/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */ +/* was not used to scale the dotproduct. */ + + i__3 = j; + i__4 = j; + z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i - + csumj.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + i__3 = j; + xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]) + , abs(d__2)); + if (nounit) { + +/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ + + i__3 = maind + j * ab_dim1; + z__1.r = tscal * ab[i__3].r, z__1.i = tscal * ab[i__3] + .i; + tjjs.r = z__1.r, tjjs.i = z__1.i; + } else { + tjjs.r = tscal, tjjs.i = 0.; + if (tscal == 1.) { + goto L160; + } + } + tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), + abs(d__2)); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.) { + if (xj > tjj * bignum) { + +/* Scale X by 1/abs(x(j)). */ + + rec = 1. / xj; + zdscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + i__3 = j; + zladiv_(&z__1, &x[j], &tjjs); + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + } else if (tjj > 0.) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ + + rec = tjj * bignum / xj; + zdscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + i__3 = j; + zladiv_(&z__1, &x[j], &tjjs); + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0 and compute a solution to A**T *x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + x[i__4].r = 0., x[i__4].i = 0.; +/* L150: */ + } + i__3 = j; + x[i__3].r = 1., x[i__3].i = 0.; + *scale = 0.; + xmax = 0.; + } +L160: + ; + } else { + +/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */ +/* product has already been divided by 1/A(j,j). */ + + i__3 = j; + zladiv_(&z__2, &x[j], &tjjs); + z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + } +/* Computing MAX */ + i__3 = j; + d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = + d_imag(&x[j]), abs(d__2)); + xmax = f2cmax(d__3,d__4); +/* L170: */ + } + + } else { + +/* Solve A**H * x = b */ + + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Compute x(j) = b(j) - sum A(k,j)*x(k). */ +/* k<>j */ + + i__3 = j; + xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]), + abs(d__2)); + uscal.r = tscal, uscal.i = 0.; + rec = 1. / f2cmax(xmax,1.); + if (cnorm[j] > (bignum - xj) * rec) { + +/* If x(j) could overflow, scale x by 1/(2*XMAX). */ + + rec *= .5; + if (nounit) { + d_cnjg(&z__2, &ab[maind + j * ab_dim1]); + z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i; + tjjs.r = z__1.r, tjjs.i = z__1.i; + } else { + tjjs.r = tscal, tjjs.i = 0.; + } + tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), + abs(d__2)); + if (tjj > 1.) { + +/* Divide by A(j,j) when scaling x if A(j,j) > 1. */ + +/* Computing MIN */ + d__1 = 1., d__2 = rec * tjj; + rec = f2cmin(d__1,d__2); + zladiv_(&z__1, &uscal, &tjjs); + uscal.r = z__1.r, uscal.i = z__1.i; + } + if (rec < 1.) { + zdscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + + csumj.r = 0., csumj.i = 0.; + if (uscal.r == 1. && uscal.i == 0.) { + +/* If the scaling needed for A in the dot product is 1, */ +/* call ZDOTC to perform the dot product. */ + + if (upper) { +/* Computing MIN */ + i__3 = *kd, i__4 = j - 1; + jlen = f2cmin(i__3,i__4); + zdotc_(&z__1, &jlen, &ab[*kd + 1 - jlen + j * ab_dim1] + , &c__1, &x[j - jlen], &c__1); + csumj.r = z__1.r, csumj.i = z__1.i; + } else { +/* Computing MIN */ + i__3 = *kd, i__4 = *n - j; + jlen = f2cmin(i__3,i__4); + if (jlen > 1) { + zdotc_(&z__1, &jlen, &ab[j * ab_dim1 + 2], &c__1, + &x[j + 1], &c__1); + csumj.r = z__1.r, csumj.i = z__1.i; + } + } + } else { + +/* Otherwise, use in-line code for the dot product. */ + + if (upper) { +/* Computing MIN */ + i__3 = *kd, i__4 = j - 1; + jlen = f2cmin(i__3,i__4); + i__3 = jlen; + for (i__ = 1; i__ <= i__3; ++i__) { + d_cnjg(&z__4, &ab[*kd + i__ - jlen + j * ab_dim1]) + ; + z__3.r = z__4.r * uscal.r - z__4.i * uscal.i, + z__3.i = z__4.r * uscal.i + z__4.i * + uscal.r; + i__4 = j - jlen - 1 + i__; + z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, + z__2.i = z__3.r * x[i__4].i + z__3.i * x[ + i__4].r; + z__1.r = csumj.r + z__2.r, z__1.i = csumj.i + + z__2.i; + csumj.r = z__1.r, csumj.i = z__1.i; +/* L180: */ + } + } else { +/* Computing MIN */ + i__3 = *kd, i__4 = *n - j; + jlen = f2cmin(i__3,i__4); + i__3 = jlen; + for (i__ = 1; i__ <= i__3; ++i__) { + d_cnjg(&z__4, &ab[i__ + 1 + j * ab_dim1]); + z__3.r = z__4.r * uscal.r - z__4.i * uscal.i, + z__3.i = z__4.r * uscal.i + z__4.i * + uscal.r; + i__4 = j + i__; + z__2.r = z__3.r * x[i__4].r - z__3.i * x[i__4].i, + z__2.i = z__3.r * x[i__4].i + z__3.i * x[ + i__4].r; + z__1.r = csumj.r + z__2.r, z__1.i = csumj.i + + z__2.i; + csumj.r = z__1.r, csumj.i = z__1.i; +/* L190: */ + } + } + } + + z__1.r = tscal, z__1.i = 0.; + if (uscal.r == z__1.r && uscal.i == z__1.i) { + +/* Compute x(j) := ( x(j) - CSUMJ ) / A(j,j) if 1/A(j,j) */ +/* was not used to scale the dotproduct. */ + + i__3 = j; + i__4 = j; + z__1.r = x[i__4].r - csumj.r, z__1.i = x[i__4].i - + csumj.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + i__3 = j; + xj = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[j]) + , abs(d__2)); + if (nounit) { + +/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ + + d_cnjg(&z__2, &ab[maind + j * ab_dim1]); + z__1.r = tscal * z__2.r, z__1.i = tscal * z__2.i; + tjjs.r = z__1.r, tjjs.i = z__1.i; + } else { + tjjs.r = tscal, tjjs.i = 0.; + if (tscal == 1.) { + goto L210; + } + } + tjj = (d__1 = tjjs.r, abs(d__1)) + (d__2 = d_imag(&tjjs), + abs(d__2)); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.) { + if (xj > tjj * bignum) { + +/* Scale X by 1/abs(x(j)). */ + + rec = 1. / xj; + zdscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + i__3 = j; + zladiv_(&z__1, &x[j], &tjjs); + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + } else if (tjj > 0.) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ + + rec = tjj * bignum / xj; + zdscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + i__3 = j; + zladiv_(&z__1, &x[j], &tjjs); + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0 and compute a solution to A**H *x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + x[i__4].r = 0., x[i__4].i = 0.; +/* L200: */ + } + i__3 = j; + x[i__3].r = 1., x[i__3].i = 0.; + *scale = 0.; + xmax = 0.; + } +L210: + ; + } else { + +/* Compute x(j) := x(j) / A(j,j) - CSUMJ if the dot */ +/* product has already been divided by 1/A(j,j). */ + + i__3 = j; + zladiv_(&z__2, &x[j], &tjjs); + z__1.r = z__2.r - csumj.r, z__1.i = z__2.i - csumj.i; + x[i__3].r = z__1.r, x[i__3].i = z__1.i; + } +/* Computing MAX */ + i__3 = j; + d__3 = xmax, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = + d_imag(&x[j]), abs(d__2)); + xmax = f2cmax(d__3,d__4); +/* L220: */ + } + } + *scale /= tscal; + } + +/* Scale the column norms by 1/TSCAL for return. */ + + if (tscal != 1.) { + d__1 = 1. / tscal; + dscal_(n, &d__1, &cnorm[1], &c__1); + } + + return 0; + +/* End of ZLATBS */ + +} /* zlatbs_ */ + diff --git a/lapack-netlib/SRC/zlatdf.c b/lapack-netlib/SRC/zlatdf.c new file mode 100644 index 000000000..a475ce32a --- /dev/null +++ b/lapack-netlib/SRC/zlatdf.c @@ -0,0 +1,794 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define 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 \brief \b ZLATDF uses the LU factorization of the n-by-n matrix computed by sgetc2 and computes a contrib +ution to the reciprocal Dif-estimate. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLATDF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, */ +/* JPIV ) */ + +/* INTEGER IJOB, LDZ, N */ +/* DOUBLE PRECISION RDSCAL, RDSUM */ +/* INTEGER IPIV( * ), JPIV( * ) */ +/* COMPLEX*16 RHS( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLATDF computes the contribution to the reciprocal Dif-estimate */ +/* > by solving for x in Z * x = b, where b is chosen such that the norm */ +/* > of x is as large as possible. It is assumed that LU decomposition */ +/* > of Z has been computed by ZGETC2. On entry RHS = f holds the */ +/* > contribution from earlier solved sub-systems, and on return RHS = x. */ +/* > */ +/* > The factorization of Z returned by ZGETC2 has the form */ +/* > Z = P * L * U * Q, where P and Q are permutation matrices. L is lower */ +/* > triangular with unit diagonal elements and U is upper triangular. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] IJOB */ +/* > \verbatim */ +/* > IJOB is INTEGER */ +/* > IJOB = 2: First compute an approximative null-vector e */ +/* > of Z using ZGECON, e is normalized and solve for */ +/* > Zx = +-e - f with the sign giving the greater value of */ +/* > 2-norm(x). About 5 times as expensive as Default. */ +/* > IJOB .ne. 2: Local look ahead strategy where */ +/* > all entries of the r.h.s. b is chosen as either +1 or */ +/* > -1. Default. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Z */ +/* > \verbatim */ +/* > Z is COMPLEX*16 array, dimension (LDZ, N) */ +/* > On entry, the LU part of the factorization of the n-by-n */ +/* > matrix Z computed by ZGETC2: Z = P * L * U * Q */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDA >= f2cmax(1, N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] RHS */ +/* > \verbatim */ +/* > RHS is COMPLEX*16 array, dimension (N). */ +/* > On entry, RHS contains contributions from other subsystems. */ +/* > On exit, RHS contains the solution of the subsystem with */ +/* > entries according to the value of IJOB (see above). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] RDSUM */ +/* > \verbatim */ +/* > RDSUM is DOUBLE PRECISION */ +/* > On entry, the sum of squares of computed contributions to */ +/* > the Dif-estimate under computation by ZTGSYL, where the */ +/* > scaling factor RDSCAL (see below) has been factored out. */ +/* > On exit, the corresponding sum of squares updated with the */ +/* > contributions from the current sub-system. */ +/* > If TRANS = 'T' RDSUM is not touched. */ +/* > NOTE: RDSUM only makes sense when ZTGSY2 is called by CTGSYL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] RDSCAL */ +/* > \verbatim */ +/* > RDSCAL is DOUBLE PRECISION */ +/* > On entry, scaling factor used to prevent overflow in RDSUM. */ +/* > On exit, RDSCAL is updated w.r.t. the current contributions */ +/* > in RDSUM. */ +/* > If TRANS = 'T', RDSCAL is not touched. */ +/* > NOTE: RDSCAL only makes sense when ZTGSY2 is called by */ +/* > ZTGSYL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N). */ +/* > The pivot indices; for 1 <= i <= N, row i of the */ +/* > matrix has been interchanged with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JPIV */ +/* > \verbatim */ +/* > JPIV is INTEGER array, dimension (N). */ +/* > The pivot indices; for 1 <= j <= N, column j of the */ +/* > matrix has been interchanged with column JPIV(j). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > This routine is a further developed implementation of algorithm */ +/* > BSOLVE in [1] using complete pivoting in the LU factorization. */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* > Umea University, S-901 87 Umea, Sweden. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > [1] Bo Kagstrom and Lars Westin, */ +/* > Generalized Schur Methods with Condition Estimators for */ +/* > Solving the Generalized Sylvester Equation, IEEE Transactions */ +/* > on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. */ +/* >\n */ +/* > [2] Peter Poromaa, */ +/* > On Efficient and Robust Estimators for the Separation */ +/* > between two Regular Matrix Pairs with Applications in */ +/* > Condition Estimation. Report UMINF-95.05, Department of */ +/* > Computing Science, Umea University, S-901 87 Umea, Sweden, */ +/* > 1995. */ + +/* ===================================================================== */ +/* Subroutine */ int zlatdf_(integer *ijob, integer *n, doublecomplex *z__, + integer *ldz, doublecomplex *rhs, doublereal *rdsum, doublereal * + rdscal, integer *ipiv, integer *jpiv) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + integer info; + doublecomplex temp, work[8]; + integer i__, j, k; + doublereal scale; + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *); + doublecomplex pmone; + extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + doublereal rtemp, sminu, rwork[2]; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + doublereal splus; + extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *), zgesc2_( + integer *, doublecomplex *, integer *, doublecomplex *, integer *, + integer *, doublereal *); + doublecomplex bm, bp, xm[2], xp[2]; + extern /* Subroutine */ int zgecon_(char *, integer *, doublecomplex *, + integer *, doublereal *, doublereal *, doublecomplex *, + doublereal *, integer *); + extern doublereal dzasum_(integer *, doublecomplex *, integer *); + extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *, + doublereal *, doublereal *), zlaswp_(integer *, doublecomplex *, + integer *, integer *, integer *, integer *, integer *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --rhs; + --ipiv; + --jpiv; + + /* Function Body */ + if (*ijob != 2) { + +/* Apply permutations IPIV to RHS */ + + i__1 = *n - 1; + zlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &ipiv[1], &c__1); + +/* Solve for L-part choosing RHS either to +1 or -1. */ + + z__1.r = -1., z__1.i = 0.; + pmone.r = z__1.r, pmone.i = z__1.i; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + z__1.r = rhs[i__2].r + 1., z__1.i = rhs[i__2].i + 0.; + bp.r = z__1.r, bp.i = z__1.i; + i__2 = j; + z__1.r = rhs[i__2].r - 1., z__1.i = rhs[i__2].i + 0.; + bm.r = z__1.r, bm.i = z__1.i; + splus = 1.; + +/* Lockahead for L- part RHS(1:N-1) = +-1 */ +/* SPLUS and SMIN computed more efficiently than in BSOLVE[1]. */ + + i__2 = *n - j; + zdotc_(&z__1, &i__2, &z__[j + 1 + j * z_dim1], &c__1, &z__[j + 1 + + j * z_dim1], &c__1); + splus += z__1.r; + i__2 = *n - j; + zdotc_(&z__1, &i__2, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1], + &c__1); + sminu = z__1.r; + i__2 = j; + splus *= rhs[i__2].r; + if (splus > sminu) { + i__2 = j; + rhs[i__2].r = bp.r, rhs[i__2].i = bp.i; + } else if (sminu > splus) { + i__2 = j; + rhs[i__2].r = bm.r, rhs[i__2].i = bm.i; + } else { + +/* In this case the updating sums are equal and we can */ +/* choose RHS(J) +1 or -1. The first time this happens we */ +/* choose -1, thereafter +1. This is a simple way to get */ +/* good estimates of matrices like Byers well-known example */ +/* (see [1]). (Not done in BSOLVE.) */ + + i__2 = j; + i__3 = j; + z__1.r = rhs[i__3].r + pmone.r, z__1.i = rhs[i__3].i + + pmone.i; + rhs[i__2].r = z__1.r, rhs[i__2].i = z__1.i; + pmone.r = 1., pmone.i = 0.; + } + +/* Compute the remaining r.h.s. */ + + i__2 = j; + z__1.r = -rhs[i__2].r, z__1.i = -rhs[i__2].i; + temp.r = z__1.r, temp.i = z__1.i; + i__2 = *n - j; + zaxpy_(&i__2, &temp, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1], + &c__1); +/* L10: */ + } + +/* Solve for U- part, lockahead for RHS(N) = +-1. This is not done */ +/* In BSOLVE and will hopefully give us a better estimate because */ +/* any ill-conditioning of the original matrix is transferred to U */ +/* and not to L. U(N, N) is an approximation to sigma_min(LU). */ + + i__1 = *n - 1; + zcopy_(&i__1, &rhs[1], &c__1, work, &c__1); + i__1 = *n - 1; + i__2 = *n; + z__1.r = rhs[i__2].r + 1., z__1.i = rhs[i__2].i + 0.; + work[i__1].r = z__1.r, work[i__1].i = z__1.i; + i__1 = *n; + i__2 = *n; + z__1.r = rhs[i__2].r - 1., z__1.i = rhs[i__2].i + 0.; + rhs[i__1].r = z__1.r, rhs[i__1].i = z__1.i; + splus = 0.; + sminu = 0.; + for (i__ = *n; i__ >= 1; --i__) { + z_div(&z__1, &c_b1, &z__[i__ + i__ * z_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + i__1 = i__ - 1; + i__2 = i__ - 1; + z__1.r = work[i__2].r * temp.r - work[i__2].i * temp.i, z__1.i = + work[i__2].r * temp.i + work[i__2].i * temp.r; + work[i__1].r = z__1.r, work[i__1].i = z__1.i; + i__1 = i__; + i__2 = i__; + z__1.r = rhs[i__2].r * temp.r - rhs[i__2].i * temp.i, z__1.i = + rhs[i__2].r * temp.i + rhs[i__2].i * temp.r; + rhs[i__1].r = z__1.r, rhs[i__1].i = z__1.i; + i__1 = *n; + for (k = i__ + 1; k <= i__1; ++k) { + i__2 = i__ - 1; + i__3 = i__ - 1; + i__4 = k - 1; + i__5 = i__ + k * z_dim1; + z__3.r = z__[i__5].r * temp.r - z__[i__5].i * temp.i, z__3.i = + z__[i__5].r * temp.i + z__[i__5].i * temp.r; + z__2.r = work[i__4].r * z__3.r - work[i__4].i * z__3.i, + z__2.i = work[i__4].r * z__3.i + work[i__4].i * + z__3.r; + z__1.r = work[i__3].r - z__2.r, z__1.i = work[i__3].i - + z__2.i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + i__2 = i__; + i__3 = i__; + i__4 = k; + i__5 = i__ + k * z_dim1; + z__3.r = z__[i__5].r * temp.r - z__[i__5].i * temp.i, z__3.i = + z__[i__5].r * temp.i + z__[i__5].i * temp.r; + z__2.r = rhs[i__4].r * z__3.r - rhs[i__4].i * z__3.i, z__2.i = + rhs[i__4].r * z__3.i + rhs[i__4].i * z__3.r; + z__1.r = rhs[i__3].r - z__2.r, z__1.i = rhs[i__3].i - z__2.i; + rhs[i__2].r = z__1.r, rhs[i__2].i = z__1.i; +/* L20: */ + } + splus += z_abs(&work[i__ - 1]); + sminu += z_abs(&rhs[i__]); +/* L30: */ + } + if (splus > sminu) { + zcopy_(n, work, &c__1, &rhs[1], &c__1); + } + +/* Apply the permutations JPIV to the computed solution (RHS) */ + + i__1 = *n - 1; + zlaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1); + +/* Compute the sum of squares */ + + zlassq_(n, &rhs[1], &c__1, rdscal, rdsum); + return 0; + } + +/* ENTRY IJOB = 2 */ + +/* Compute approximate nullvector XM of Z */ + + zgecon_("I", n, &z__[z_offset], ldz, &c_b24, &rtemp, work, rwork, &info); + zcopy_(n, &work[*n], &c__1, xm, &c__1); + +/* Compute RHS */ + + i__1 = *n - 1; + zlaswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1); + zdotc_(&z__3, n, xm, &c__1, xm, &c__1); + z_sqrt(&z__2, &z__3); + z_div(&z__1, &c_b1, &z__2); + temp.r = z__1.r, temp.i = z__1.i; + zscal_(n, &temp, xm, &c__1); + zcopy_(n, xm, &c__1, xp, &c__1); + zaxpy_(n, &c_b1, &rhs[1], &c__1, xp, &c__1); + z__1.r = -1., z__1.i = 0.; + zaxpy_(n, &z__1, xm, &c__1, &rhs[1], &c__1); + zgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &scale); + zgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &scale); + if (dzasum_(n, xp, &c__1) > dzasum_(n, &rhs[1], &c__1)) { + zcopy_(n, xp, &c__1, &rhs[1], &c__1); + } + +/* Compute the sum of squares */ + + zlassq_(n, &rhs[1], &c__1, rdscal, rdsum); + return 0; + +/* End of ZLATDF */ + +} /* zlatdf_ */ +