diff --git a/lapack-netlib/SRC/stbrfs.c b/lapack-netlib/SRC/stbrfs.c new file mode 100644 index 000000000..dce4ba195 --- /dev/null +++ b/lapack-netlib/SRC/stbrfs.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 STBRFS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STBRFS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, */ +/* LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) */ + +/* CHARACTER DIAG, TRANS, UPLO */ +/* INTEGER INFO, KD, LDAB, LDB, LDX, N, NRHS */ +/* INTEGER IWORK( * ) */ +/* REAL AB( LDAB, * ), B( LDB, * ), BERR( * ), */ +/* $ FERR( * ), WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STBRFS provides error bounds and backward error estimates for the */ +/* > solution to a system of linear equations with a triangular band */ +/* > coefficient matrix. */ +/* > */ +/* > The solution matrix X must be computed by STBTRS or some other */ +/* > means before entering this routine. STBRFS does not do iterative */ +/* > refinement because doing so cannot improve the backward error. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of superdiagonals or subdiagonals of the */ +/* > triangular band matrix A. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is REAL array, dimension (LDAB,N) */ +/* > The upper or lower triangular band matrix A, stored in the */ +/* > first kd+1 rows of the array. The j-th column of A is stored */ +/* > in the j-th column of the array AB as follows: */ +/* > if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > If DIAG = 'U', the diagonal elements of A are not referenced */ +/* > and are assumed to be 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,NRHS) */ +/* > The right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (LDX,NRHS) */ +/* > The solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is REAL array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is REAL array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int stbrfs_(char *uplo, char *trans, char *diag, integer *n, + integer *kd, integer *nrhs, real *ab, integer *ldab, real *b, integer + *ldb, real *x, integer *ldx, real *ferr, real *berr, real *work, + integer *iwork, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, + i__2, i__3, i__4, i__5; + real r__1, r__2, r__3; + + /* Local variables */ + integer kase; + real safe1, safe2; + integer i__, j, k; + real s; + extern logical lsame_(char *, char *); + integer isave[3]; + logical upper; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *), stbmv_(char *, char *, char *, integer *, integer *, + real *, integer *, real *, integer *), + stbsv_(char *, char *, char *, integer *, integer *, real *, + integer *, real *, integer *), saxpy_( + integer *, real *, real *, integer *, real *, integer *), slacn2_( + integer *, real *, real *, integer *, real *, integer *, integer * + ); + real xk; + extern real slamch_(char *); + integer nz; + real safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical notran; + char transt[1]; + logical nounit; + real lstres, eps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + notran = lsame_(trans, "N"); + nounit = lsame_(diag, "N"); + + 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 (*n < 0) { + *info = -4; + } else if (*kd < 0) { + *info = -5; + } else if (*nrhs < 0) { + *info = -6; + } else if (*ldab < *kd + 1) { + *info = -8; + } else if (*ldb < f2cmax(1,*n)) { + *info = -10; + } else if (*ldx < f2cmax(1,*n)) { + *info = -12; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STBRFS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.f; + berr[j] = 0.f; +/* L10: */ + } + return 0; + } + + if (notran) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = *kd + 2; + eps = slamch_("Epsilon"); + safmin = slamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Compute residual R = B - op(A) * X, */ +/* where op(A) = A or A**T, depending on TRANS. */ + + scopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1); + stbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[*n + 1], + &c__1); + saxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* f2cmax(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] = (r__1 = b[i__ + j * b_dim1], abs(r__1)); +/* L20: */ + } + + if (notran) { + +/* Compute abs(A)*abs(X) + abs(B). */ + + if (upper) { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (r__1 = x[k + j * x_dim1], abs(r__1)); +/* Computing MAX */ + i__3 = 1, i__4 = k - *kd; + i__5 = k; + for (i__ = f2cmax(i__3,i__4); i__ <= i__5; ++i__) { + work[i__] += (r__1 = ab[*kd + 1 + i__ - k + k * + ab_dim1], abs(r__1)) * xk; +/* L30: */ + } +/* L40: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (r__1 = x[k + j * x_dim1], abs(r__1)); +/* Computing MAX */ + i__5 = 1, i__3 = k - *kd; + i__4 = k - 1; + for (i__ = f2cmax(i__5,i__3); i__ <= i__4; ++i__) { + work[i__] += (r__1 = ab[*kd + 1 + i__ - k + k * + ab_dim1], abs(r__1)) * xk; +/* L50: */ + } + work[k] += xk; +/* L60: */ + } + } + } else { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (r__1 = x[k + j * x_dim1], abs(r__1)); +/* Computing MIN */ + i__5 = *n, i__3 = k + *kd; + i__4 = f2cmin(i__5,i__3); + for (i__ = k; i__ <= i__4; ++i__) { + work[i__] += (r__1 = ab[i__ + 1 - k + k * ab_dim1] + , abs(r__1)) * xk; +/* L70: */ + } +/* L80: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (r__1 = x[k + j * x_dim1], abs(r__1)); +/* Computing MIN */ + i__5 = *n, i__3 = k + *kd; + i__4 = f2cmin(i__5,i__3); + for (i__ = k + 1; i__ <= i__4; ++i__) { + work[i__] += (r__1 = ab[i__ + 1 - k + k * ab_dim1] + , abs(r__1)) * xk; +/* L90: */ + } + work[k] += xk; +/* L100: */ + } + } + } + } else { + +/* Compute abs(A**T)*abs(X) + abs(B). */ + + if (upper) { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; +/* Computing MAX */ + i__4 = 1, i__5 = k - *kd; + i__3 = k; + for (i__ = f2cmax(i__4,i__5); i__ <= i__3; ++i__) { + s += (r__1 = ab[*kd + 1 + i__ - k + k * ab_dim1], + abs(r__1)) * (r__2 = x[i__ + j * x_dim1], + abs(r__2)); +/* L110: */ + } + work[k] += s; +/* L120: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = (r__1 = x[k + j * x_dim1], abs(r__1)); +/* Computing MAX */ + i__3 = 1, i__4 = k - *kd; + i__5 = k - 1; + for (i__ = f2cmax(i__3,i__4); i__ <= i__5; ++i__) { + s += (r__1 = ab[*kd + 1 + i__ - k + k * ab_dim1], + abs(r__1)) * (r__2 = x[i__ + j * x_dim1], + abs(r__2)); +/* L130: */ + } + work[k] += s; +/* L140: */ + } + } + } else { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; +/* Computing MIN */ + i__3 = *n, i__4 = k + *kd; + i__5 = f2cmin(i__3,i__4); + for (i__ = k; i__ <= i__5; ++i__) { + s += (r__1 = ab[i__ + 1 - k + k * ab_dim1], abs( + r__1)) * (r__2 = x[i__ + j * x_dim1], abs( + r__2)); +/* L150: */ + } + work[k] += s; +/* L160: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = (r__1 = x[k + j * x_dim1], abs(r__1)); +/* Computing MIN */ + i__3 = *n, i__4 = k + *kd; + i__5 = f2cmin(i__3,i__4); + for (i__ = k + 1; i__ <= i__5; ++i__) { + s += (r__1 = ab[i__ + 1 - k + k * ab_dim1], abs( + r__1)) * (r__2 = x[i__ + j * x_dim1], abs( + r__2)); +/* L170: */ + } + work[k] += s; +/* L180: */ + } + } + } + } + s = 0.f; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + r__2 = s, r__3 = (r__1 = work[*n + i__], abs(r__1)) / work[ + i__]; + s = f2cmax(r__2,r__3); + } else { +/* Computing MAX */ + r__2 = s, r__3 = ((r__1 = work[*n + i__], abs(r__1)) + safe1) + / (work[i__] + safe1); + s = f2cmax(r__2,r__3); + } +/* L190: */ + } + berr[j] = s; + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(op(A)))* */ +/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(op(A)) is the inverse of op(A) */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ + +/* Use SLACN2 to estimate the infinity-norm of the matrix */ +/* inv(op(A)) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { + work[i__] = (r__1 = work[*n + i__], abs(r__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (r__1 = work[*n + i__], abs(r__1)) + nz * eps * + work[i__] + safe1; + } +/* L200: */ + } + + kase = 0; +L210: + slacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & + kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(op(A)**T). */ + + stbsv_(uplo, transt, diag, n, kd, &ab[ab_offset], ldab, &work[ + *n + 1], &c__1); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L220: */ + } + } else { + +/* Multiply by inv(op(A))*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L230: */ + } + stbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[* + n + 1], &c__1); + } + goto L210; + } + +/* Normalize error. */ + + lstres = 0.f; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], abs(r__1)); + lstres = f2cmax(r__2,r__3); +/* L240: */ + } + if (lstres != 0.f) { + ferr[j] /= lstres; + } + +/* L250: */ + } + + return 0; + +/* End of STBRFS */ + +} /* stbrfs_ */ + diff --git a/lapack-netlib/SRC/stbtrs.c b/lapack-netlib/SRC/stbtrs.c new file mode 100644 index 000000000..dab88d673 --- /dev/null +++ b/lapack-netlib/SRC/stbtrs.c @@ -0,0 +1,643 @@ +/* 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 STBTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STBTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, */ +/* LDB, INFO ) */ + +/* CHARACTER DIAG, TRANS, UPLO */ +/* INTEGER INFO, KD, LDAB, LDB, N, NRHS */ +/* REAL AB( LDAB, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STBTRS solves a triangular system of the form */ +/* > */ +/* > A * X = B or A**T * X = B, */ +/* > */ +/* > where A is a triangular band matrix of order N, and B is an */ +/* > N-by NRHS matrix. A check is made to verify that A is nonsingular. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of superdiagonals or subdiagonals of the */ +/* > triangular band matrix A. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is REAL array, dimension (LDAB,N) */ +/* > The upper or lower triangular band matrix A, stored in the */ +/* > first kd+1 rows of AB. The j-th column of A is stored */ +/* > in the j-th column of the array AB as follows: */ +/* > if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > If DIAG = 'U', the diagonal elements of A are not referenced */ +/* > and are assumed to be 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, if INFO = 0, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the i-th diagonal element of A is zero, */ +/* > indicating that the matrix is singular and the */ +/* > solutions X have not been computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int stbtrs_(char *uplo, char *trans, char *diag, integer *n, + integer *kd, integer *nrhs, real *ab, integer *ldab, real *b, integer + *ldb, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + integer j; + extern logical lsame_(char *, char *); + logical upper; + extern /* Subroutine */ int stbsv_(char *, char *, char *, integer *, + integer *, real *, integer *, real *, integer *), xerbla_(char *, integer *, ftnlen); + logical nounit; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + nounit = lsame_(diag, "N"); + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*kd < 0) { + *info = -5; + } else if (*nrhs < 0) { + *info = -6; + } else if (*ldab < *kd + 1) { + *info = -8; + } else if (*ldb < f2cmax(1,*n)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STBTRS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check for singularity. */ + + if (nounit) { + if (upper) { + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (ab[*kd + 1 + *info * ab_dim1] == 0.f) { + return 0; + } +/* L10: */ + } + } else { + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (ab[*info * ab_dim1 + 1] == 0.f) { + return 0; + } +/* L20: */ + } + } + } + *info = 0; + +/* Solve A * X = B or A**T * X = B. */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + stbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &b[j * b_dim1 + + 1], &c__1); +/* L30: */ + } + + return 0; + +/* End of STBTRS */ + +} /* stbtrs_ */ + diff --git a/lapack-netlib/SRC/stfsm.c b/lapack-netlib/SRC/stfsm.c new file mode 100644 index 000000000..0bf8cbbb8 --- /dev/null +++ b/lapack-netlib/SRC/stfsm.c @@ -0,0 +1,1409 @@ +/* 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 STFSM solves a matrix equation (one operand is a triangular matrix in RFP format). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STFSM + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, */ +/* B, LDB ) */ + +/* CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO */ +/* INTEGER LDB, M, N */ +/* REAL ALPHA */ +/* REAL A( 0: * ), B( 0: LDB-1, 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Level 3 BLAS like routine for A in RFP Format. */ +/* > */ +/* > STFSM solves the matrix equation */ +/* > */ +/* > op( A )*X = alpha*B or X*op( A ) = alpha*B */ +/* > */ +/* > where alpha is a scalar, X and B are m by n matrices, A is a unit, or */ +/* > non-unit, upper or lower triangular matrix and op( A ) is one of */ +/* > */ +/* > op( A ) = A or op( A ) = A**T. */ +/* > */ +/* > A is in Rectangular Full Packed (RFP) Format. */ +/* > */ +/* > The matrix X is overwritten on B. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER*1 */ +/* > = 'N': The Normal Form of RFP A is stored; */ +/* > = 'T': The Transpose Form of RFP A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > On entry, SIDE specifies whether op( A ) appears on the left */ +/* > or right of X as follows: */ +/* > */ +/* > SIDE = 'L' or 'l' op( A )*X = alpha*B. */ +/* > */ +/* > SIDE = 'R' or 'r' X*op( A ) = alpha*B. */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > 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 */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > On entry, TRANS specifies the form of op( A ) to be used */ +/* > in the matrix multiplication as follows: */ +/* > */ +/* > TRANS = 'N' or 'n' op( A ) = A. */ +/* > */ +/* > TRANS = 'T' or 't' op( A ) = A'. */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > On entry, DIAG specifies whether or not RFP A is unit */ +/* > triangular as follows: */ +/* > */ +/* > DIAG = 'U' or 'u' A is assumed to be unit triangular. */ +/* > */ +/* > DIAG = 'N' or 'n' A is not assumed to be unit */ +/* > triangular. */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > On entry, M specifies the number of rows of B. M must be at */ +/* > least zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > On entry, N specifies the number of columns of B. N must be */ +/* > at least zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is REAL */ +/* > On entry, ALPHA specifies the scalar alpha. When alpha is */ +/* > zero then A is not referenced and B need not be set before */ +/* > entry. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (NT) */ +/* > NT = 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 = 'T' then RFP is the 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 NT */ +/* > elements of upper packed A either in normal or */ +/* > transpose Format. If UPLO = 'L' the RFP A contains */ +/* > the NT elements of lower packed A either in normal or */ +/* > transpose Format. The LDA of RFP A is (N+1)/2 when */ +/* > TRANSR = 'T'. 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[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,N) */ +/* > Before entry, the leading m by n part of the array B must */ +/* > contain the right-hand side matrix B, and on exit is */ +/* > overwritten by the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > On entry, LDB specifies the first dimension of B as declared */ +/* > in the calling (sub) program. LDB must be at least */ +/* > f2cmax( 1, m ). */ +/* > Unchanged on exit. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > We first consider Rectangular Full Packed (RFP) 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 */ +/* > the 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 */ +/* > the transpose of the last three columns of AP lower. */ +/* > 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 = 'T'. RFP A in both UPLO cases is just the */ +/* > 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 then consider Rectangular Full Packed (RFP) 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 */ +/* > the 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 */ +/* > the transpose of the last two columns of AP lower. */ +/* > 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 = 'T'. RFP A in both UPLO cases is just the */ +/* > 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 */ + +/* ===================================================================== */ +/* Subroutine */ int stfsm_(char *transr, char *side, char *uplo, char *trans, + char *diag, integer *m, integer *n, real *alpha, real *a, real *b, + integer *ldb) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2; + + /* Local variables */ + integer info, i__, j, k; + logical normaltransr, lside; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *); + logical lower; + integer m1, m2, n1, n2; + extern /* Subroutine */ int strsm_(char *, char *, char *, char *, + integer *, integer *, real *, real *, integer *, real *, integer * + ), xerbla_(char *, integer *, ftnlen); + logical misodd, nisodd, notrans; + + +/* -- 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 - 1 - 0 + 1; + b_offset = 0 + b_dim1 * 0; + b -= b_offset; + + /* Function Body */ + info = 0; + normaltransr = lsame_(transr, "N"); + lside = lsame_(side, "L"); + lower = lsame_(uplo, "L"); + notrans = lsame_(trans, "N"); + if (! normaltransr && ! lsame_(transr, "T")) { + info = -1; + } else if (! lside && ! lsame_(side, "R")) { + info = -2; + } else if (! lower && ! lsame_(uplo, "U")) { + info = -3; + } else if (! notrans && ! lsame_(trans, "T")) { + info = -4; + } else if (! lsame_(diag, "N") && ! lsame_(diag, + "U")) { + info = -5; + } else if (*m < 0) { + info = -6; + } else if (*n < 0) { + info = -7; + } else if (*ldb < f2cmax(1,*m)) { + info = -11; + } + if (info != 0) { + i__1 = -info; + xerbla_("STFSM ", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return when ( (N.EQ.0).OR.(M.EQ.0) ) */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Quick return when ALPHA.EQ.(0D+0) */ + + if (*alpha == 0.f) { + i__1 = *n - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = *m - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.f; +/* L10: */ + } +/* L20: */ + } + return 0; + } + + if (lside) { + +/* SIDE = 'L' */ + +/* A is M-by-M. */ +/* If M is odd, set NISODD = .TRUE., and M1 and M2. */ +/* If M is even, NISODD = .FALSE., and M. */ + + if (*m % 2 == 0) { + misodd = FALSE_; + k = *m / 2; + } else { + misodd = TRUE_; + if (lower) { + m2 = *m / 2; + m1 = *m - m2; + } else { + m1 = *m / 2; + m2 = *m - m1; + } + } + + if (misodd) { + +/* SIDE = 'L' and N is odd */ + + if (normaltransr) { + +/* SIDE = 'L', N is odd, and TRANSR = 'N' */ + + if (lower) { + +/* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and */ +/* TRANS = 'N' */ + + if (*m == 1) { + strsm_("L", "L", "N", diag, &m1, n, alpha, a, m, & + b[b_offset], ldb); + } else { + strsm_("L", "L", "N", diag, &m1, n, alpha, a, m, & + b[b_offset], ldb); + sgemm_("N", "N", &m2, n, &m1, &c_b23, &a[m1], m, & + b[b_offset], ldb, alpha, &b[m1], ldb); + strsm_("L", "U", "T", diag, &m2, n, &c_b27, &a[*m] + , m, &b[m1], ldb); + } + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and */ +/* TRANS = 'T' */ + + if (*m == 1) { + strsm_("L", "L", "T", diag, &m1, n, alpha, a, m, & + b[b_offset], ldb); + } else { + strsm_("L", "U", "N", diag, &m2, n, alpha, &a[*m], + m, &b[m1], ldb); + sgemm_("T", "N", &m1, n, &m2, &c_b23, &a[m1], m, & + b[m1], ldb, alpha, &b[b_offset], ldb); + strsm_("L", "L", "T", diag, &m1, n, &c_b27, a, m, + &b[b_offset], ldb); + } + + } + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'U' */ + + if (! notrans) { + +/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and */ +/* TRANS = 'N' */ + + strsm_("L", "L", "N", diag, &m1, n, alpha, &a[m2], m, + &b[b_offset], ldb); + sgemm_("T", "N", &m2, n, &m1, &c_b23, a, m, &b[ + b_offset], ldb, alpha, &b[m1], ldb); + strsm_("L", "U", "T", diag, &m2, n, &c_b27, &a[m1], m, + &b[m1], ldb); + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and */ +/* TRANS = 'T' */ + + strsm_("L", "U", "N", diag, &m2, n, alpha, &a[m1], m, + &b[m1], ldb); + sgemm_("N", "N", &m1, n, &m2, &c_b23, a, m, &b[m1], + ldb, alpha, &b[b_offset], ldb); + strsm_("L", "L", "T", diag, &m1, n, &c_b27, &a[m2], m, + &b[b_offset], ldb); + + } + + } + + } else { + +/* SIDE = 'L', N is odd, and TRANSR = 'T' */ + + if (lower) { + +/* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and */ +/* TRANS = 'N' */ + + if (*m == 1) { + strsm_("L", "U", "T", diag, &m1, n, alpha, a, &m1, + &b[b_offset], ldb); + } else { + strsm_("L", "U", "T", diag, &m1, n, alpha, a, &m1, + &b[b_offset], ldb); + sgemm_("T", "N", &m2, n, &m1, &c_b23, &a[m1 * m1], + &m1, &b[b_offset], ldb, alpha, &b[m1], + ldb); + strsm_("L", "L", "N", diag, &m2, n, &c_b27, &a[1], + &m1, &b[m1], ldb); + } + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and */ +/* TRANS = 'T' */ + + if (*m == 1) { + strsm_("L", "U", "N", diag, &m1, n, alpha, a, &m1, + &b[b_offset], ldb); + } else { + strsm_("L", "L", "T", diag, &m2, n, alpha, &a[1], + &m1, &b[m1], ldb); + sgemm_("N", "N", &m1, n, &m2, &c_b23, &a[m1 * m1], + &m1, &b[m1], ldb, alpha, &b[b_offset], + ldb); + strsm_("L", "U", "N", diag, &m1, n, &c_b27, a, & + m1, &b[b_offset], ldb); + } + + } + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'U' */ + + if (! notrans) { + +/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and */ +/* TRANS = 'N' */ + + strsm_("L", "U", "T", diag, &m1, n, alpha, &a[m2 * m2] + , &m2, &b[b_offset], ldb); + sgemm_("N", "N", &m2, n, &m1, &c_b23, a, &m2, &b[ + b_offset], ldb, alpha, &b[m1], ldb); + strsm_("L", "L", "N", diag, &m2, n, &c_b27, &a[m1 * + m2], &m2, &b[m1], ldb); + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and */ +/* TRANS = 'T' */ + + strsm_("L", "L", "T", diag, &m2, n, alpha, &a[m1 * m2] + , &m2, &b[m1], ldb); + sgemm_("T", "N", &m1, n, &m2, &c_b23, a, &m2, &b[m1], + ldb, alpha, &b[b_offset], ldb); + strsm_("L", "U", "N", diag, &m1, n, &c_b27, &a[m2 * + m2], &m2, &b[b_offset], ldb); + + } + + } + + } + + } else { + +/* SIDE = 'L' and N is even */ + + if (normaltransr) { + +/* SIDE = 'L', N is even, and TRANSR = 'N' */ + + if (lower) { + +/* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', */ +/* and TRANS = 'N' */ + + i__1 = *m + 1; + strsm_("L", "L", "N", diag, &k, n, alpha, &a[1], & + i__1, &b[b_offset], ldb); + i__1 = *m + 1; + sgemm_("N", "N", &k, n, &k, &c_b23, &a[k + 1], &i__1, + &b[b_offset], ldb, alpha, &b[k], ldb); + i__1 = *m + 1; + strsm_("L", "U", "T", diag, &k, n, &c_b27, a, &i__1, & + b[k], ldb); + + } else { + +/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', */ +/* and TRANS = 'T' */ + + i__1 = *m + 1; + strsm_("L", "U", "N", diag, &k, n, alpha, a, &i__1, & + b[k], ldb); + i__1 = *m + 1; + sgemm_("T", "N", &k, n, &k, &c_b23, &a[k + 1], &i__1, + &b[k], ldb, alpha, &b[b_offset], ldb); + i__1 = *m + 1; + strsm_("L", "L", "T", diag, &k, n, &c_b27, &a[1], & + i__1, &b[b_offset], ldb); + + } + + } else { + +/* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'U' */ + + if (! notrans) { + +/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', */ +/* and TRANS = 'N' */ + + i__1 = *m + 1; + strsm_("L", "L", "N", diag, &k, n, alpha, &a[k + 1], & + i__1, &b[b_offset], ldb); + i__1 = *m + 1; + sgemm_("T", "N", &k, n, &k, &c_b23, a, &i__1, &b[ + b_offset], ldb, alpha, &b[k], ldb); + i__1 = *m + 1; + strsm_("L", "U", "T", diag, &k, n, &c_b27, &a[k], & + i__1, &b[k], ldb); + + } else { + +/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', */ +/* and TRANS = 'T' */ + i__1 = *m + 1; + strsm_("L", "U", "N", diag, &k, n, alpha, &a[k], & + i__1, &b[k], ldb); + i__1 = *m + 1; + sgemm_("N", "N", &k, n, &k, &c_b23, a, &i__1, &b[k], + ldb, alpha, &b[b_offset], ldb); + i__1 = *m + 1; + strsm_("L", "L", "T", diag, &k, n, &c_b27, &a[k + 1], + &i__1, &b[b_offset], ldb); + + } + + } + + } else { + +/* SIDE = 'L', N is even, and TRANSR = 'T' */ + + if (lower) { + +/* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', */ +/* and TRANS = 'N' */ + + strsm_("L", "U", "T", diag, &k, n, alpha, &a[k], &k, & + b[b_offset], ldb); + sgemm_("T", "N", &k, n, &k, &c_b23, &a[k * (k + 1)], & + k, &b[b_offset], ldb, alpha, &b[k], ldb); + strsm_("L", "L", "N", diag, &k, n, &c_b27, a, &k, &b[ + k], ldb); + + } else { + +/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', */ +/* and TRANS = 'T' */ + + strsm_("L", "L", "T", diag, &k, n, alpha, a, &k, &b[k] + , ldb); + sgemm_("N", "N", &k, n, &k, &c_b23, &a[k * (k + 1)], & + k, &b[k], ldb, alpha, &b[b_offset], ldb); + strsm_("L", "U", "N", diag, &k, n, &c_b27, &a[k], &k, + &b[b_offset], ldb); + + } + + } else { + +/* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'U' */ + + if (! notrans) { + +/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', */ +/* and TRANS = 'N' */ + + strsm_("L", "U", "T", diag, &k, n, alpha, &a[k * (k + + 1)], &k, &b[b_offset], ldb); + sgemm_("N", "N", &k, n, &k, &c_b23, a, &k, &b[ + b_offset], ldb, alpha, &b[k], ldb); + strsm_("L", "L", "N", diag, &k, n, &c_b27, &a[k * k], + &k, &b[k], ldb); + + } else { + +/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', */ +/* and TRANS = 'T' */ + + strsm_("L", "L", "T", diag, &k, n, alpha, &a[k * k], & + k, &b[k], ldb); + sgemm_("T", "N", &k, n, &k, &c_b23, a, &k, &b[k], ldb, + alpha, &b[b_offset], ldb); + strsm_("L", "U", "N", diag, &k, n, &c_b27, &a[k * (k + + 1)], &k, &b[b_offset], ldb); + + } + + } + + } + + } + + } else { + +/* SIDE = 'R' */ + +/* A is N-by-N. */ +/* If N is odd, set NISODD = .TRUE., and N1 and N2. */ +/* If N is even, NISODD = .FALSE., and K. */ + + if (*n % 2 == 0) { + nisodd = FALSE_; + k = *n / 2; + } else { + nisodd = TRUE_; + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + } + + if (nisodd) { + +/* SIDE = 'R' and N is odd */ + + if (normaltransr) { + +/* SIDE = 'R', N is odd, and TRANSR = 'N' */ + + if (lower) { + +/* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and */ +/* TRANS = 'N' */ + + strsm_("R", "U", "T", diag, m, &n2, alpha, &a[*n], n, + &b[n1 * b_dim1], ldb); + sgemm_("N", "N", m, &n1, &n2, &c_b23, &b[n1 * b_dim1], + ldb, &a[n1], n, alpha, b, ldb); + strsm_("R", "L", "N", diag, m, &n1, &c_b27, a, n, b, + ldb); + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and */ +/* TRANS = 'T' */ + + strsm_("R", "L", "T", diag, m, &n1, alpha, a, n, b, + ldb); + sgemm_("N", "T", m, &n2, &n1, &c_b23, b, ldb, &a[n1], + n, alpha, &b[n1 * b_dim1], ldb); + strsm_("R", "U", "N", diag, m, &n2, &c_b27, &a[*n], n, + &b[n1 * b_dim1], ldb); + + } + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'U' */ + + if (notrans) { + +/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and */ +/* TRANS = 'N' */ + + strsm_("R", "L", "T", diag, m, &n1, alpha, &a[n2], n, + b, ldb); + sgemm_("N", "N", m, &n2, &n1, &c_b23, b, ldb, a, n, + alpha, &b[n1 * b_dim1], ldb); + strsm_("R", "U", "N", diag, m, &n2, &c_b27, &a[n1], n, + &b[n1 * b_dim1], ldb); + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and */ +/* TRANS = 'T' */ + + strsm_("R", "U", "T", diag, m, &n2, alpha, &a[n1], n, + &b[n1 * b_dim1], ldb); + sgemm_("N", "T", m, &n1, &n2, &c_b23, &b[n1 * b_dim1], + ldb, a, n, alpha, b, ldb); + strsm_("R", "L", "N", diag, m, &n1, &c_b27, &a[n2], n, + b, ldb); + + } + + } + + } else { + +/* SIDE = 'R', N is odd, and TRANSR = 'T' */ + + if (lower) { + +/* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and */ +/* TRANS = 'N' */ + + strsm_("R", "L", "N", diag, m, &n2, alpha, &a[1], &n1, + &b[n1 * b_dim1], ldb); + sgemm_("N", "T", m, &n1, &n2, &c_b23, &b[n1 * b_dim1], + ldb, &a[n1 * n1], &n1, alpha, b, ldb); + strsm_("R", "U", "T", diag, m, &n1, &c_b27, a, &n1, b, + ldb); + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and */ +/* TRANS = 'T' */ + + strsm_("R", "U", "N", diag, m, &n1, alpha, a, &n1, b, + ldb); + sgemm_("N", "N", m, &n2, &n1, &c_b23, b, ldb, &a[n1 * + n1], &n1, alpha, &b[n1 * b_dim1], ldb); + strsm_("R", "L", "T", diag, m, &n2, &c_b27, &a[1], & + n1, &b[n1 * b_dim1], ldb); + + } + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'U' */ + + if (notrans) { + +/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and */ +/* TRANS = 'N' */ + + strsm_("R", "U", "N", diag, m, &n1, alpha, &a[n2 * n2] + , &n2, b, ldb); + sgemm_("N", "T", m, &n2, &n1, &c_b23, b, ldb, a, &n2, + alpha, &b[n1 * b_dim1], ldb); + strsm_("R", "L", "T", diag, m, &n2, &c_b27, &a[n1 * + n2], &n2, &b[n1 * b_dim1], ldb); + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and */ +/* TRANS = 'T' */ + + strsm_("R", "L", "N", diag, m, &n2, alpha, &a[n1 * n2] + , &n2, &b[n1 * b_dim1], ldb); + sgemm_("N", "N", m, &n1, &n2, &c_b23, &b[n1 * b_dim1], + ldb, a, &n2, alpha, b, ldb); + strsm_("R", "U", "T", diag, m, &n1, &c_b27, &a[n2 * + n2], &n2, b, ldb); + + } + + } + + } + + } else { + +/* SIDE = 'R' and N is even */ + + if (normaltransr) { + +/* SIDE = 'R', N is even, and TRANSR = 'N' */ + + if (lower) { + +/* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', */ +/* and TRANS = 'N' */ + + i__1 = *n + 1; + strsm_("R", "U", "T", diag, m, &k, alpha, a, &i__1, & + b[k * b_dim1], ldb); + i__1 = *n + 1; + sgemm_("N", "N", m, &k, &k, &c_b23, &b[k * b_dim1], + ldb, &a[k + 1], &i__1, alpha, b, ldb); + i__1 = *n + 1; + strsm_("R", "L", "N", diag, m, &k, &c_b27, &a[1], & + i__1, b, ldb); + + } else { + +/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', */ +/* and TRANS = 'T' */ + + i__1 = *n + 1; + strsm_("R", "L", "T", diag, m, &k, alpha, &a[1], & + i__1, b, ldb); + i__1 = *n + 1; + sgemm_("N", "T", m, &k, &k, &c_b23, b, ldb, &a[k + 1], + &i__1, alpha, &b[k * b_dim1], ldb); + i__1 = *n + 1; + strsm_("R", "U", "N", diag, m, &k, &c_b27, a, &i__1, & + b[k * b_dim1], ldb); + + } + + } else { + +/* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'U' */ + + if (notrans) { + +/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', */ +/* and TRANS = 'N' */ + + i__1 = *n + 1; + strsm_("R", "L", "T", diag, m, &k, alpha, &a[k + 1], & + i__1, b, ldb); + i__1 = *n + 1; + sgemm_("N", "N", m, &k, &k, &c_b23, b, ldb, a, &i__1, + alpha, &b[k * b_dim1], ldb); + i__1 = *n + 1; + strsm_("R", "U", "N", diag, m, &k, &c_b27, &a[k], & + i__1, &b[k * b_dim1], ldb); + + } else { + +/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', */ +/* and TRANS = 'T' */ + + i__1 = *n + 1; + strsm_("R", "U", "T", diag, m, &k, alpha, &a[k], & + i__1, &b[k * b_dim1], ldb); + i__1 = *n + 1; + sgemm_("N", "T", m, &k, &k, &c_b23, &b[k * b_dim1], + ldb, a, &i__1, alpha, b, ldb); + i__1 = *n + 1; + strsm_("R", "L", "N", diag, m, &k, &c_b27, &a[k + 1], + &i__1, b, ldb); + + } + + } + + } else { + +/* SIDE = 'R', N is even, and TRANSR = 'T' */ + + if (lower) { + +/* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', */ +/* and TRANS = 'N' */ + + strsm_("R", "L", "N", diag, m, &k, alpha, a, &k, &b[k + * b_dim1], ldb); + sgemm_("N", "T", m, &k, &k, &c_b23, &b[k * b_dim1], + ldb, &a[(k + 1) * k], &k, alpha, b, ldb); + strsm_("R", "U", "T", diag, m, &k, &c_b27, &a[k], &k, + b, ldb); + + } else { + +/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', */ +/* and TRANS = 'T' */ + + strsm_("R", "U", "N", diag, m, &k, alpha, &a[k], &k, + b, ldb); + sgemm_("N", "N", m, &k, &k, &c_b23, b, ldb, &a[(k + 1) + * k], &k, alpha, &b[k * b_dim1], ldb); + strsm_("R", "L", "T", diag, m, &k, &c_b27, a, &k, &b[ + k * b_dim1], ldb); + + } + + } else { + +/* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'U' */ + + if (notrans) { + +/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', */ +/* and TRANS = 'N' */ + + strsm_("R", "U", "N", diag, m, &k, alpha, &a[(k + 1) * + k], &k, b, ldb); + sgemm_("N", "T", m, &k, &k, &c_b23, b, ldb, a, &k, + alpha, &b[k * b_dim1], ldb); + strsm_("R", "L", "T", diag, m, &k, &c_b27, &a[k * k], + &k, &b[k * b_dim1], ldb); + + } else { + +/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', */ +/* and TRANS = 'T' */ + + strsm_("R", "L", "N", diag, m, &k, alpha, &a[k * k], & + k, &b[k * b_dim1], ldb); + sgemm_("N", "N", m, &k, &k, &c_b23, &b[k * b_dim1], + ldb, a, &k, alpha, b, ldb); + strsm_("R", "U", "T", diag, m, &k, &c_b27, &a[(k + 1) + * k], &k, b, ldb); + + } + + } + + } + + } + } + + return 0; + +/* End of STFSM */ + +} /* stfsm_ */ + diff --git a/lapack-netlib/SRC/stftri.c b/lapack-netlib/SRC/stftri.c new file mode 100644 index 000000000..0fe3bcb3c --- /dev/null +++ b/lapack-netlib/SRC/stftri.c @@ -0,0 +1,897 @@ +/* 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 STFTRI */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STFTRI + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STFTRI( TRANSR, UPLO, DIAG, N, A, INFO ) */ + +/* CHARACTER TRANSR, UPLO, DIAG */ +/* INTEGER INFO, N */ +/* REAL A( 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STFTRI computes the inverse of a triangular matrix A stored in RFP */ +/* > format. */ +/* > */ +/* > This is a Level 3 BLAS version of the algorithm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER*1 */ +/* > = 'N': The Normal TRANSR of RFP A is stored; */ +/* > = 'T': The Transpose TRANSR of RFP A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (NT); */ +/* > NT=N*(N+1)/2. On entry, the triangular factor of a Hermitian */ +/* > Positive Definite 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 = 'T' then RFP is */ +/* > the 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 nt elements of */ +/* > upper packed A; If UPLO = 'L' the RFP A contains the nt */ +/* > elements of lower packed A. The LDA of RFP A is (N+1)/2 when */ +/* > TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is */ +/* > even and N is odd. See the Note below for more details. */ +/* > */ +/* > On exit, the (triangular) inverse of the original matrix, in */ +/* > the same storage format. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, A(i,i) is exactly zero. The triangular */ +/* > matrix is singular and its inverse can not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > We first consider Rectangular Full Packed (RFP) 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 */ +/* > the 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 */ +/* > the transpose of the last three columns of AP lower. */ +/* > 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 = 'T'. RFP A in both UPLO cases is just the */ +/* > 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 then consider Rectangular Full Packed (RFP) 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 */ +/* > the 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 */ +/* > the transpose of the last two columns of AP lower. */ +/* > 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 = 'T'. RFP A in both UPLO cases is just the */ +/* > 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 */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int stftri_(char *transr, char *uplo, char *diag, integer *n, + real *a, integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer k; + logical normaltransr; + extern logical lsame_(char *, char *); + logical lower; + integer n1, n2; + extern /* Subroutine */ int strmm_(char *, char *, char *, char *, + integer *, integer *, real *, real *, integer *, real *, integer * + ), xerbla_(char *, integer *, ftnlen); + logical nisodd; + extern /* Subroutine */ int strtri_(char *, char *, integer *, real *, + integer *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + *info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + if (! normaltransr && ! lsame_(transr, "T")) { + *info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + *info = -2; + } else if (! lsame_(diag, "N") && ! lsame_(diag, + "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STFTRI", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* If N is odd, set NISODD = .TRUE. */ +/* If N is even, set K = N/2 and NISODD = .FALSE. */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = FALSE_; + } else { + nisodd = TRUE_; + } + +/* Set N1 and N2 depending on LOWER */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + + +/* start execution: there are eight cases */ + + if (nisodd) { + +/* N is odd */ + + if (normaltransr) { + +/* N is odd and TRANSR = 'N' */ + + if (lower) { + +/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */ +/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */ +/* T1 -> a(0), T2 -> a(n), S -> a(n1) */ + + strtri_("L", diag, &n1, a, n, info); + if (*info > 0) { + return 0; + } + strmm_("R", "L", "N", diag, &n2, &n1, &c_b13, a, n, &a[n1], n); + strtri_("U", diag, &n2, &a[*n], n, info) + ; + if (*info > 0) { + *info += n1; + } + if (*info > 0) { + return 0; + } + strmm_("L", "U", "T", diag, &n2, &n1, &c_b18, &a[*n], n, &a[ + n1], n); + + } else { + +/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */ +/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */ +/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */ + + strtri_("L", diag, &n1, &a[n2], n, info) + ; + if (*info > 0) { + return 0; + } + strmm_("L", "L", "T", diag, &n1, &n2, &c_b13, &a[n2], n, a, n); + strtri_("U", diag, &n2, &a[n1], n, info) + ; + if (*info > 0) { + *info += n1; + } + if (*info > 0) { + return 0; + } + strmm_("R", "U", "N", diag, &n1, &n2, &c_b18, &a[n1], n, a, n); + + } + + } else { + +/* N is odd and TRANSR = 'T' */ + + if (lower) { + +/* SRPA for LOWER, TRANSPOSE and N is odd */ +/* T1 -> a(0), T2 -> a(1), S -> a(0+n1*n1) */ + + strtri_("U", diag, &n1, a, &n1, info); + if (*info > 0) { + return 0; + } + strmm_("L", "U", "N", diag, &n1, &n2, &c_b13, a, &n1, &a[n1 * + n1], &n1); + strtri_("L", diag, &n2, &a[1], &n1, info); + if (*info > 0) { + *info += n1; + } + if (*info > 0) { + return 0; + } + strmm_("R", "L", "T", diag, &n1, &n2, &c_b18, &a[1], &n1, &a[ + n1 * n1], &n1); + + } else { + +/* SRPA for UPPER, TRANSPOSE and N is odd */ +/* T1 -> a(0+n2*n2), T2 -> a(0+n1*n2), S -> a(0) */ + + strtri_("U", diag, &n1, &a[n2 * n2], &n2, info); + if (*info > 0) { + return 0; + } + strmm_("R", "U", "T", diag, &n2, &n1, &c_b13, &a[n2 * n2], & + n2, a, &n2); + strtri_("L", diag, &n2, &a[n1 * n2], &n2, info); + if (*info > 0) { + *info += n1; + } + if (*info > 0) { + return 0; + } + strmm_("L", "L", "N", diag, &n2, &n1, &c_b18, &a[n1 * n2], & + n2, a, &n2); + } + + } + + } else { + +/* N is even */ + + if (normaltransr) { + +/* N is even and TRANSR = 'N' */ + + if (lower) { + +/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ +/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */ +/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */ + + i__1 = *n + 1; + strtri_("L", diag, &k, &a[1], &i__1, info); + if (*info > 0) { + return 0; + } + i__1 = *n + 1; + i__2 = *n + 1; + strmm_("R", "L", "N", diag, &k, &k, &c_b13, &a[1], &i__1, &a[ + k + 1], &i__2); + i__1 = *n + 1; + strtri_("U", diag, &k, a, &i__1, info); + if (*info > 0) { + *info += k; + } + if (*info > 0) { + return 0; + } + i__1 = *n + 1; + i__2 = *n + 1; + strmm_("L", "U", "T", diag, &k, &k, &c_b18, a, &i__1, &a[k + + 1], &i__2) + ; + + } else { + +/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ +/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */ +/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */ + + i__1 = *n + 1; + strtri_("L", diag, &k, &a[k + 1], &i__1, info); + if (*info > 0) { + return 0; + } + i__1 = *n + 1; + i__2 = *n + 1; + strmm_("L", "L", "T", diag, &k, &k, &c_b13, &a[k + 1], &i__1, + a, &i__2); + i__1 = *n + 1; + strtri_("U", diag, &k, &a[k], &i__1, info); + if (*info > 0) { + *info += k; + } + if (*info > 0) { + return 0; + } + i__1 = *n + 1; + i__2 = *n + 1; + strmm_("R", "U", "N", diag, &k, &k, &c_b18, &a[k], &i__1, a, & + i__2); + } + } else { + +/* N is even and TRANSR = 'T' */ + + if (lower) { + +/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */ +/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */ +/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */ + + strtri_("U", diag, &k, &a[k], &k, info); + if (*info > 0) { + return 0; + } + strmm_("L", "U", "N", diag, &k, &k, &c_b13, &a[k], &k, &a[k * + (k + 1)], &k); + strtri_("L", diag, &k, a, &k, info); + if (*info > 0) { + *info += k; + } + if (*info > 0) { + return 0; + } + strmm_("R", "L", "T", diag, &k, &k, &c_b18, a, &k, &a[k * (k + + 1)], &k) + ; + } else { + +/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */ +/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */ +/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */ + + strtri_("U", diag, &k, &a[k * (k + 1)], &k, info); + if (*info > 0) { + return 0; + } + strmm_("R", "U", "T", diag, &k, &k, &c_b13, &a[k * (k + 1)], & + k, a, &k); + strtri_("L", diag, &k, &a[k * k], &k, info); + if (*info > 0) { + *info += k; + } + if (*info > 0) { + return 0; + } + strmm_("L", "L", "N", diag, &k, &k, &c_b18, &a[k * k], &k, a, + &k); + } + } + } + + return 0; + +/* End of STFTRI */ + +} /* stftri_ */ + diff --git a/lapack-netlib/SRC/stfttp.c b/lapack-netlib/SRC/stfttp.c new file mode 100644 index 000000000..8a247b4bc --- /dev/null +++ b/lapack-netlib/SRC/stfttp.c @@ -0,0 +1,941 @@ +/* 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 STFTTP copies a triangular matrix from the rectangular full packed format (TF) to the standard +packed format (TP). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STFTTP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STFTTP( TRANSR, UPLO, N, ARF, AP, INFO ) */ + +/* CHARACTER TRANSR, UPLO */ +/* INTEGER INFO, N */ +/* REAL AP( 0: * ), ARF( 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STFTTP copies a triangular matrix A from rectangular full packed */ +/* > format (TF) to standard packed format (TP). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER*1 */ +/* > = 'N': ARF is in Normal format; */ +/* > = 'T': ARF is in Transpose format; */ +/* > \endverbatim */ +/* > */ +/* > \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 order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ARF */ +/* > \verbatim */ +/* > ARF is REAL array, dimension ( N*(N+1)/2 ), */ +/* > On entry, the upper or lower triangular matrix A stored in */ +/* > RFP format. For a further discussion see Notes below. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] AP */ +/* > \verbatim */ +/* > AP is REAL array, dimension ( N*(N+1)/2 ), */ +/* > On exit, 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. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > We first consider Rectangular Full Packed (RFP) 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 */ +/* > the 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 */ +/* > the transpose of the last three columns of AP lower. */ +/* > 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 = 'T'. RFP A in both UPLO cases is just the */ +/* > 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 then consider Rectangular Full Packed (RFP) 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 */ +/* > the 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 */ +/* > the transpose of the last two columns of AP lower. */ +/* > 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 = 'T'. RFP A in both UPLO cases is just the */ +/* > 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 */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int stfttp_(char *transr, char *uplo, integer *n, real *arf, + real *ap, integer *info) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, k; + logical normaltransr; + extern logical lsame_(char *, char *); + logical lower; + integer n1, n2, ij, jp, js, nt; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical nisodd; + integer lda, ijp; + + +/* -- 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. */ + + *info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + if (! normaltransr && ! lsame_(transr, "T")) { + *info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STFTTP", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (normaltransr) { + ap[0] = arf[0]; + } else { + ap[0] = arf[0]; + } + return 0; + } + +/* Size of array ARF(0:NT-1) */ + + nt = *n * (*n + 1) / 2; + +/* Set N1 and N2 depending on LOWER */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + +/* If N is odd, set NISODD = .TRUE. */ +/* If N is even, set K = N/2 and NISODD = .FALSE. */ + +/* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) */ +/* where noe = 0 if n is even, noe = 1 if n is odd */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = FALSE_; + lda = *n + 1; + } else { + nisodd = TRUE_; + lda = *n; + } + +/* ARF^C has lda rows and n+1-noe cols */ + + if (! normaltransr) { + lda = (*n + 1) / 2; + } + +/* start execution: there are eight cases */ + + if (nisodd) { + +/* N is odd */ + + if (normaltransr) { + +/* N is odd and TRANSR = 'N' */ + + if (lower) { + +/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */ +/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */ +/* T1 -> a(0), T2 -> a(n), S -> a(n1); lda = n */ + + ijp = 0; + jp = 0; + i__1 = n2; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + ij = i__ + jp; + ap[ijp] = arf[ij]; + ++ijp; + } + jp += lda; + } + i__1 = n2 - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = n2; + for (j = i__ + 1; j <= i__2; ++j) { + ij = i__ + j * lda; + ap[ijp] = arf[ij]; + ++ijp; + } + } + + } else { + +/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */ +/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */ +/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */ + + ijp = 0; + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + ij = n2 + j; + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + ap[ijp] = arf[ij]; + ++ijp; + ij += lda; + } + } + js = 0; + i__1 = *n - 1; + for (j = n1; j <= i__1; ++j) { + ij = js; + i__2 = js + j; + for (ij = js; ij <= i__2; ++ij) { + ap[ijp] = arf[ij]; + ++ijp; + } + js += lda; + } + + } + + } else { + +/* N is odd and TRANSR = 'T' */ + + if (lower) { + +/* SRPA for LOWER, TRANSPOSE and N is odd */ +/* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */ +/* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 */ + + ijp = 0; + i__1 = n2; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = *n * lda - 1; + i__3 = lda; + for (ij = i__ * (lda + 1); i__3 < 0 ? ij >= i__2 : ij <= + i__2; ij += i__3) { + ap[ijp] = arf[ij]; + ++ijp; + } + } + js = 1; + i__1 = n2 - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + n2 - j - 1; + for (ij = js; ij <= i__3; ++ij) { + ap[ijp] = arf[ij]; + ++ijp; + } + js = js + lda + 1; + } + + } else { + +/* SRPA for UPPER, TRANSPOSE and N is odd */ +/* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */ +/* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 */ + + ijp = 0; + js = n2 * lda; + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + j; + for (ij = js; ij <= i__3; ++ij) { + ap[ijp] = arf[ij]; + ++ijp; + } + js += lda; + } + i__1 = n1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__3 = i__ + (n1 + i__) * lda; + i__2 = lda; + for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij += + i__2) { + ap[ijp] = arf[ij]; + ++ijp; + } + } + + } + + } + + } else { + +/* N is even */ + + if (normaltransr) { + +/* N is even and TRANSR = 'N' */ + + if (lower) { + +/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ +/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */ +/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */ + + ijp = 0; + jp = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + ij = i__ + 1 + jp; + ap[ijp] = arf[ij]; + ++ijp; + } + jp += lda; + } + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = k - 1; + for (j = i__; j <= i__2; ++j) { + ij = i__ + j * lda; + ap[ijp] = arf[ij]; + ++ijp; + } + } + + } else { + +/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ +/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */ +/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */ + + ijp = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + ij = k + 1 + j; + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + ap[ijp] = arf[ij]; + ++ijp; + ij += lda; + } + } + js = 0; + i__1 = *n - 1; + for (j = k; j <= i__1; ++j) { + ij = js; + i__2 = js + j; + for (ij = js; ij <= i__2; ++ij) { + ap[ijp] = arf[ij]; + ++ijp; + } + js += lda; + } + + } + + } else { + +/* N is even and TRANSR = 'T' */ + + if (lower) { + +/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */ +/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */ +/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */ + + ijp = 0; + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = (*n + 1) * lda - 1; + i__3 = lda; + for (ij = i__ + (i__ + 1) * lda; i__3 < 0 ? ij >= i__2 : + ij <= i__2; ij += i__3) { + ap[ijp] = arf[ij]; + ++ijp; + } + } + js = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + k - j - 1; + for (ij = js; ij <= i__3; ++ij) { + ap[ijp] = arf[ij]; + ++ijp; + } + js = js + lda + 1; + } + + } else { + +/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */ +/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */ +/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */ + + ijp = 0; + js = (k + 1) * lda; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + j; + for (ij = js; ij <= i__3; ++ij) { + ap[ijp] = arf[ij]; + ++ijp; + } + js += lda; + } + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__3 = i__ + (k + i__) * lda; + i__2 = lda; + for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij += + i__2) { + ap[ijp] = arf[ij]; + ++ijp; + } + } + + } + + } + + } + + return 0; + +/* End of STFTTP */ + +} /* stfttp_ */ + diff --git a/lapack-netlib/SRC/stfttr.c b/lapack-netlib/SRC/stfttr.c new file mode 100644 index 000000000..297fec618 --- /dev/null +++ b/lapack-netlib/SRC/stfttr.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 STFTTR copies a triangular matrix from the rectangular full packed format (TF) to the standard +full format (TR). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STFTTR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO ) */ + +/* CHARACTER TRANSR, UPLO */ +/* INTEGER INFO, N, LDA */ +/* REAL A( 0: LDA-1, 0: * ), ARF( 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STFTTR copies a triangular matrix A from rectangular full packed */ +/* > format (TF) to standard full format (TR). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER*1 */ +/* > = 'N': ARF is in Normal format; */ +/* > = 'T': ARF is in Transpose format. */ +/* > \endverbatim */ +/* > */ +/* > \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 order of the matrices ARF and A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ARF */ +/* > \verbatim */ +/* > ARF is REAL array, dimension (N*(N+1)/2). */ +/* > On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L') */ +/* > matrix A in RFP format. See the "Notes" below for more */ +/* > details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On exit, the triangular matrix A. If UPLO = 'U', the */ +/* > leading N-by-N upper triangular part of the array A contains */ +/* > the upper triangular matrix, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of the array A contains */ +/* > the lower triangular matrix, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > We first consider Rectangular Full Packed (RFP) 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 */ +/* > the 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 */ +/* > the transpose of the last three columns of AP lower. */ +/* > 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 = 'T'. RFP A in both UPLO cases is just the */ +/* > 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 then consider Rectangular Full Packed (RFP) 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 */ +/* > the 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 */ +/* > the transpose of the last two columns of AP lower. */ +/* > 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 = 'T'. RFP A in both UPLO cases is just the */ +/* > 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 */ + +/* ===================================================================== */ +/* Subroutine */ int stfttr_(char *transr, char *uplo, integer *n, real *arf, + real *a, integer *lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer np1x2, i__, j, k, l; + logical normaltransr; + extern logical lsame_(char *, char *); + logical lower; + integer n1, n2, ij, nt; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical nisodd; + integer nx2; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda - 1 - 0 + 1; + a_offset = 0 + a_dim1 * 0; + a -= a_offset; + + /* Function Body */ + *info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + if (! normaltransr && ! lsame_(transr, "T")) { + *info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STFTTR", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 1) { + if (*n == 1) { + a[0] = arf[0]; + } + return 0; + } + +/* Size of array ARF(0:nt-1) */ + + nt = *n * (*n + 1) / 2; + +/* set N1 and N2 depending on LOWER: for N even N1=N2=K */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + +/* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. */ +/* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is */ +/* N--by--(N+1)/2. */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = FALSE_; + if (! lower) { + np1x2 = *n + *n + 2; + } + } else { + nisodd = TRUE_; + if (! lower) { + nx2 = *n + *n; + } + } + + if (nisodd) { + +/* N is odd */ + + if (normaltransr) { + +/* N is odd and TRANSR = 'N' */ + + if (lower) { + +/* N is odd, TRANSR = 'N', and UPLO = 'L' */ + + ij = 0; + i__1 = n2; + for (j = 0; j <= i__1; ++j) { + i__2 = n2 + j; + for (i__ = n1; i__ <= i__2; ++i__) { + a[n2 + j + i__ * a_dim1] = arf[ij]; + ++ij; + } + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + } + + } else { + +/* N is odd, TRANSR = 'N', and UPLO = 'U' */ + + ij = nt - *n; + i__1 = n1; + for (j = *n - 1; j >= i__1; --j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + i__2 = n1 - 1; + for (l = j - n1; l <= i__2; ++l) { + a[j - n1 + l * a_dim1] = arf[ij]; + ++ij; + } + ij -= nx2; + } + + } + + } else { + +/* N is odd and TRANSR = 'T' */ + + if (lower) { + +/* N is odd, TRANSR = 'T', and UPLO = 'L' */ + + ij = 0; + i__1 = n2 - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + a[j + i__ * a_dim1] = arf[ij]; + ++ij; + } + i__2 = *n - 1; + for (i__ = n1 + j; i__ <= i__2; ++i__) { + a[i__ + (n1 + j) * a_dim1] = arf[ij]; + ++ij; + } + } + i__1 = *n - 1; + for (j = n2; j <= i__1; ++j) { + i__2 = n1 - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + a[j + i__ * a_dim1] = arf[ij]; + ++ij; + } + } + + } else { + +/* N is odd, TRANSR = 'T', and UPLO = 'U' */ + + ij = 0; + i__1 = n1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = n1; i__ <= i__2; ++i__) { + a[j + i__ * a_dim1] = arf[ij]; + ++ij; + } + } + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + i__2 = *n - 1; + for (l = n2 + j; l <= i__2; ++l) { + a[n2 + j + l * a_dim1] = arf[ij]; + ++ij; + } + } + + } + + } + + } else { + +/* N is even */ + + if (normaltransr) { + +/* N is even and TRANSR = 'N' */ + + if (lower) { + +/* N is even, TRANSR = 'N', and UPLO = 'L' */ + + ij = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = k + j; + for (i__ = k; i__ <= i__2; ++i__) { + a[k + j + i__ * a_dim1] = arf[ij]; + ++ij; + } + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + } + + } else { + +/* N is even, TRANSR = 'N', and UPLO = 'U' */ + + ij = nt - *n - 1; + i__1 = k; + for (j = *n - 1; j >= i__1; --j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + i__2 = k - 1; + for (l = j - k; l <= i__2; ++l) { + a[j - k + l * a_dim1] = arf[ij]; + ++ij; + } + ij -= np1x2; + } + + } + + } else { + +/* N is even and TRANSR = 'T' */ + + if (lower) { + +/* N is even, TRANSR = 'T', and UPLO = 'L' */ + + ij = 0; + j = k; + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + a[j + i__ * a_dim1] = arf[ij]; + ++ij; + } + i__2 = *n - 1; + for (i__ = k + 1 + j; i__ <= i__2; ++i__) { + a[i__ + (k + 1 + j) * a_dim1] = arf[ij]; + ++ij; + } + } + i__1 = *n - 1; + for (j = k - 1; j <= i__1; ++j) { + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + a[j + i__ * a_dim1] = arf[ij]; + ++ij; + } + } + + } else { + +/* N is even, TRANSR = 'T', and UPLO = 'U' */ + + ij = 0; + i__1 = k; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = k; i__ <= i__2; ++i__) { + a[j + i__ * a_dim1] = arf[ij]; + ++ij; + } + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + i__2 = *n - 1; + for (l = k + 1 + j; l <= i__2; ++l) { + a[k + 1 + j + l * a_dim1] = arf[ij]; + ++ij; + } + } +/* Note that here, on exit of the loop, J = K-1 */ + i__1 = j; + for (i__ = 0; i__ <= i__1; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + + } + + } + + } + + return 0; + +/* End of STFTTR */ + +} /* stfttr_ */ + diff --git a/lapack-netlib/SRC/stgevc.c b/lapack-netlib/SRC/stgevc.c new file mode 100644 index 000000000..cdb75b148 --- /dev/null +++ b/lapack-netlib/SRC/stgevc.c @@ -0,0 +1,1841 @@ +/* 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 STGEVC */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STGEVC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, */ +/* LDVL, VR, LDVR, MM, M, WORK, INFO ) */ + +/* CHARACTER HOWMNY, SIDE */ +/* INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N */ +/* LOGICAL SELECT( * ) */ +/* REAL P( LDP, * ), S( LDS, * ), VL( LDVL, * ), */ +/* $ VR( LDVR, * ), WORK( * ) */ + + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STGEVC computes some or all of the right and/or left eigenvectors of */ +/* > a pair of real matrices (S,P), where S is a quasi-triangular matrix */ +/* > and P is upper triangular. Matrix pairs of this type are produced by */ +/* > the generalized Schur factorization of a matrix pair (A,B): */ +/* > */ +/* > A = Q*S*Z**T, B = Q*P*Z**T */ +/* > */ +/* > as computed by SGGHRD + SHGEQZ. */ +/* > */ +/* > The right eigenvector x and the left eigenvector y of (S,P) */ +/* > corresponding to an eigenvalue w are defined by: */ +/* > */ +/* > S*x = w*P*x, (y**H)*S = w*(y**H)*P, */ +/* > */ +/* > where y**H denotes the conjugate tranpose of y. */ +/* > The eigenvalues are not input to this routine, but are computed */ +/* > directly from the diagonal blocks of S and P. */ +/* > */ +/* > This routine returns the matrices X and/or Y of right and left */ +/* > eigenvectors of (S,P), or the products Z*X and/or Q*Y, */ +/* > where Z and Q are input matrices. */ +/* > If Q and Z are the orthogonal factors from the generalized Schur */ +/* > factorization of a matrix pair (A,B), then Z*X and Q*Y */ +/* > are the matrices of right and left eigenvectors of (A,B). */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'R': compute right eigenvectors only; */ +/* > = 'L': compute left eigenvectors only; */ +/* > = 'B': compute both right and left eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] HOWMNY */ +/* > \verbatim */ +/* > HOWMNY is CHARACTER*1 */ +/* > = 'A': compute all right and/or left eigenvectors; */ +/* > = 'B': compute all right and/or left eigenvectors, */ +/* > backtransformed by the matrices in VR and/or VL; */ +/* > = 'S': compute selected right and/or left eigenvectors, */ +/* > specified by the logical array SELECT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > If HOWMNY='S', SELECT specifies the eigenvectors to be */ +/* > computed. If w(j) is a real eigenvalue, the corresponding */ +/* > real eigenvector is computed if SELECT(j) is .TRUE.. */ +/* > If w(j) and w(j+1) are the real and imaginary parts of a */ +/* > complex eigenvalue, the corresponding complex eigenvector */ +/* > is computed if either SELECT(j) or SELECT(j+1) is .TRUE., */ +/* > and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is */ +/* > set to .FALSE.. */ +/* > Not referenced if HOWMNY = 'A' or 'B'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices S and P. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (LDS,N) */ +/* > The upper quasi-triangular matrix S from a generalized Schur */ +/* > factorization, as computed by SHGEQZ. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDS */ +/* > \verbatim */ +/* > LDS is INTEGER */ +/* > The leading dimension of array S. LDS >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is REAL array, dimension (LDP,N) */ +/* > The upper triangular matrix P from a generalized Schur */ +/* > factorization, as computed by SHGEQZ. */ +/* > 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks */ +/* > of S must be in positive diagonal form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDP */ +/* > \verbatim */ +/* > LDP is INTEGER */ +/* > The leading dimension of array P. LDP >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VL */ +/* > \verbatim */ +/* > VL is REAL array, dimension (LDVL,MM) */ +/* > On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */ +/* > contain an N-by-N matrix Q (usually the orthogonal matrix Q */ +/* > of left Schur vectors returned by SHGEQZ). */ +/* > On exit, if SIDE = 'L' or 'B', VL contains: */ +/* > if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); */ +/* > if HOWMNY = 'B', the matrix Q*Y; */ +/* > if HOWMNY = 'S', the left eigenvectors of (S,P) specified by */ +/* > SELECT, stored consecutively in the columns of */ +/* > VL, in the same order as their eigenvalues. */ +/* > */ +/* > A complex eigenvector corresponding to a complex eigenvalue */ +/* > is stored in two consecutive columns, the first holding the */ +/* > real part, and the second the imaginary part. */ +/* > */ +/* > Not referenced if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of array VL. LDVL >= 1, and if */ +/* > SIDE = 'L' or 'B', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VR */ +/* > \verbatim */ +/* > VR is REAL array, dimension (LDVR,MM) */ +/* > On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */ +/* > contain an N-by-N matrix Z (usually the orthogonal matrix Z */ +/* > of right Schur vectors returned by SHGEQZ). */ +/* > */ +/* > On exit, if SIDE = 'R' or 'B', VR contains: */ +/* > if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); */ +/* > if HOWMNY = 'B' or 'b', the matrix Z*X; */ +/* > if HOWMNY = 'S' or 's', the right eigenvectors of (S,P) */ +/* > specified by SELECT, stored consecutively in the */ +/* > columns of VR, in the same order as their */ +/* > eigenvalues. */ +/* > */ +/* > A complex eigenvector corresponding to a complex eigenvalue */ +/* > is stored in two consecutive columns, the first holding the */ +/* > real part and the second the imaginary part. */ +/* > */ +/* > Not referenced if SIDE = 'L'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the array VR. LDVR >= 1, and if */ +/* > SIDE = 'R' or 'B', LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MM */ +/* > \verbatim */ +/* > MM is INTEGER */ +/* > The number of columns in the arrays VL and/or VR. MM >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of columns in the arrays VL and/or VR actually */ +/* > used to store the eigenvectors. If HOWMNY = 'A' or 'B', M */ +/* > is set to N. Each selected real eigenvector occupies one */ +/* > column and each selected complex eigenvector occupies two */ +/* > columns. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (6*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 2-by-2 block (INFO:INFO+1) does not have a complex */ +/* > eigenvalue. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realGEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Allocation of workspace: */ +/* > ---------- -- --------- */ +/* > */ +/* > WORK( j ) = 1-norm of j-th column of A, above the diagonal */ +/* > WORK( N+j ) = 1-norm of j-th column of B, above the diagonal */ +/* > WORK( 2*N+1:3*N ) = real part of eigenvector */ +/* > WORK( 3*N+1:4*N ) = imaginary part of eigenvector */ +/* > WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector */ +/* > WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector */ +/* > */ +/* > Rowwise vs. columnwise solution methods: */ +/* > ------- -- ---------- -------- ------- */ +/* > */ +/* > Finding a generalized eigenvector consists basically of solving the */ +/* > singular triangular system */ +/* > */ +/* > (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left) */ +/* > */ +/* > Consider finding the i-th right eigenvector (assume all eigenvalues */ +/* > are real). The equation to be solved is: */ +/* > n i */ +/* > 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1 */ +/* > k=j k=j */ +/* > */ +/* > where C = (A - w B) (The components v(i+1:n) are 0.) */ +/* > */ +/* > The "rowwise" method is: */ +/* > */ +/* > (1) v(i) := 1 */ +/* > for j = i-1,. . .,1: */ +/* > i */ +/* > (2) compute s = - sum C(j,k) v(k) and */ +/* > k=j+1 */ +/* > */ +/* > (3) v(j) := s / C(j,j) */ +/* > */ +/* > Step 2 is sometimes called the "dot product" step, since it is an */ +/* > inner product between the j-th row and the portion of the eigenvector */ +/* > that has been computed so far. */ +/* > */ +/* > The "columnwise" method consists basically in doing the sums */ +/* > for all the rows in parallel. As each v(j) is computed, the */ +/* > contribution of v(j) times the j-th column of C is added to the */ +/* > partial sums. Since FORTRAN arrays are stored columnwise, this has */ +/* > the advantage that at each step, the elements of C that are accessed */ +/* > are adjacent to one another, whereas with the rowwise method, the */ +/* > elements accessed at a step are spaced LDS (and LDP) words apart. */ +/* > */ +/* > When finding left eigenvectors, the matrix in question is the */ +/* > transpose of the one in storage, so the rowwise method then */ +/* > actually accesses columns of A and B at each step, and so is the */ +/* > preferred method. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int stgevc_(char *side, char *howmny, logical *select, + integer *n, real *s, integer *lds, real *p, integer *ldp, real *vl, + integer *ldvl, real *vr, integer *ldvr, integer *mm, integer *m, real + *work, integer *info) +{ + /* System generated locals */ + integer p_dim1, p_offset, s_dim1, s_offset, vl_dim1, vl_offset, vr_dim1, + vr_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2, r__3, r__4, r__5, r__6; + + /* Local variables */ + integer ibeg, ieig, iend; + real dmin__, temp, xmax, sump[4] /* was [2][2] */, sums[4] /* + was [2][2] */, cim2a, cim2b, cre2a, cre2b; + extern /* Subroutine */ int slag2_(real *, integer *, real *, integer *, + real *, real *, real *, real *, real *, real *); + real temp2, bdiag[2]; + integer i__, j; + real acoef, scale; + logical ilall; + integer iside; + real sbeta; + extern logical lsame_(char *, char *); + logical il2by2; + integer iinfo; + real small; + logical compl; + real anorm, bnorm; + logical compr; + extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *), slaln2_(logical *, integer *, integer *, real *, real *, + real *, integer *, real *, real *, real *, integer *, real *, + real *, real *, integer *, real *, real *, integer *); + real temp2i, temp2r; + integer ja; + logical ilabad, ilbbad; + integer jc, je, na; + real acoefa, bcoefa, cimaga, cimagb; + logical ilback; + integer im; + real bcoefi, ascale, bscale, creala; + integer jr; + real crealb; + extern /* Subroutine */ int slabad_(real *, real *); + real bcoefr; + integer jw, nw; + extern real slamch_(char *); + real salfar, safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real xscale, bignum; + logical ilcomp, ilcplx; + extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, + integer *, real *, integer *); + integer ihwmny; + real big; + logical lsa, lsb; + real ulp, sum[4] /* was [2][2] */; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + + +/* ===================================================================== */ + + +/* Decode and Test the input parameters */ + + /* Parameter adjustments */ + --select; + s_dim1 = *lds; + s_offset = 1 + s_dim1 * 1; + s -= s_offset; + p_dim1 = *ldp; + p_offset = 1 + p_dim1 * 1; + p -= p_offset; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --work; + + /* Function Body */ + if (lsame_(howmny, "A")) { + ihwmny = 1; + ilall = TRUE_; + ilback = FALSE_; + } else if (lsame_(howmny, "S")) { + ihwmny = 2; + ilall = FALSE_; + ilback = FALSE_; + } else if (lsame_(howmny, "B")) { + ihwmny = 3; + ilall = TRUE_; + ilback = TRUE_; + } else { + ihwmny = -1; + ilall = TRUE_; + } + + if (lsame_(side, "R")) { + iside = 1; + compl = FALSE_; + compr = TRUE_; + } else if (lsame_(side, "L")) { + iside = 2; + compl = TRUE_; + compr = FALSE_; + } else if (lsame_(side, "B")) { + iside = 3; + compl = TRUE_; + compr = TRUE_; + } else { + iside = -1; + } + + *info = 0; + if (iside < 0) { + *info = -1; + } else if (ihwmny < 0) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*lds < f2cmax(1,*n)) { + *info = -6; + } else if (*ldp < f2cmax(1,*n)) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STGEVC", &i__1, (ftnlen)6); + return 0; + } + +/* Count the number of eigenvectors to be computed */ + + if (! ilall) { + im = 0; + ilcplx = FALSE_; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (ilcplx) { + ilcplx = FALSE_; + goto L10; + } + if (j < *n) { + if (s[j + 1 + j * s_dim1] != 0.f) { + ilcplx = TRUE_; + } + } + if (ilcplx) { + if (select[j] || select[j + 1]) { + im += 2; + } + } else { + if (select[j]) { + ++im; + } + } +L10: + ; + } + } else { + im = *n; + } + +/* Check 2-by-2 diagonal blocks of A, B */ + + ilabad = FALSE_; + ilbbad = FALSE_; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + if (s[j + 1 + j * s_dim1] != 0.f) { + if (p[j + j * p_dim1] == 0.f || p[j + 1 + (j + 1) * p_dim1] == + 0.f || p[j + (j + 1) * p_dim1] != 0.f) { + ilbbad = TRUE_; + } + if (j < *n - 1) { + if (s[j + 2 + (j + 1) * s_dim1] != 0.f) { + ilabad = TRUE_; + } + } + } +/* L20: */ + } + + if (ilabad) { + *info = -5; + } else if (ilbbad) { + *info = -7; + } else if (compl && *ldvl < *n || *ldvl < 1) { + *info = -10; + } else if (compr && *ldvr < *n || *ldvr < 1) { + *info = -12; + } else if (*mm < im) { + *info = -13; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STGEVC", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + *m = im; + if (*n == 0) { + return 0; + } + +/* Machine Constants */ + + safmin = slamch_("Safe minimum"); + big = 1.f / safmin; + slabad_(&safmin, &big); + ulp = slamch_("Epsilon") * slamch_("Base"); + small = safmin * *n / ulp; + big = 1.f / small; + bignum = 1.f / (safmin * *n); + +/* Compute the 1-norm of each column of the strictly upper triangular */ +/* part (i.e., excluding all elements belonging to the diagonal */ +/* blocks) of A and B to check for possible overflow in the */ +/* triangular solver. */ + + anorm = (r__1 = s[s_dim1 + 1], abs(r__1)); + if (*n > 1) { + anorm += (r__1 = s[s_dim1 + 2], abs(r__1)); + } + bnorm = (r__1 = p[p_dim1 + 1], abs(r__1)); + work[1] = 0.f; + work[*n + 1] = 0.f; + + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + temp = 0.f; + temp2 = 0.f; + if (s[j + (j - 1) * s_dim1] == 0.f) { + iend = j - 1; + } else { + iend = j - 2; + } + i__2 = iend; + for (i__ = 1; i__ <= i__2; ++i__) { + temp += (r__1 = s[i__ + j * s_dim1], abs(r__1)); + temp2 += (r__1 = p[i__ + j * p_dim1], abs(r__1)); +/* L30: */ + } + work[j] = temp; + work[*n + j] = temp2; +/* Computing MIN */ + i__3 = j + 1; + i__2 = f2cmin(i__3,*n); + for (i__ = iend + 1; i__ <= i__2; ++i__) { + temp += (r__1 = s[i__ + j * s_dim1], abs(r__1)); + temp2 += (r__1 = p[i__ + j * p_dim1], abs(r__1)); +/* L40: */ + } + anorm = f2cmax(anorm,temp); + bnorm = f2cmax(bnorm,temp2); +/* L50: */ + } + + ascale = 1.f / f2cmax(anorm,safmin); + bscale = 1.f / f2cmax(bnorm,safmin); + +/* Left eigenvectors */ + + if (compl) { + ieig = 0; + +/* Main loop over eigenvalues */ + + ilcplx = FALSE_; + i__1 = *n; + for (je = 1; je <= i__1; ++je) { + +/* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or */ +/* (b) this would be the second of a complex pair. */ +/* Check for complex eigenvalue, so as to be sure of which */ +/* entry(-ies) of SELECT to look at. */ + + if (ilcplx) { + ilcplx = FALSE_; + goto L220; + } + nw = 1; + if (je < *n) { + if (s[je + 1 + je * s_dim1] != 0.f) { + ilcplx = TRUE_; + nw = 2; + } + } + if (ilall) { + ilcomp = TRUE_; + } else if (ilcplx) { + ilcomp = select[je] || select[je + 1]; + } else { + ilcomp = select[je]; + } + if (! ilcomp) { + goto L220; + } + +/* Decide if (a) singular pencil, (b) real eigenvalue, or */ +/* (c) complex eigenvalue. */ + + if (! ilcplx) { + if ((r__1 = s[je + je * s_dim1], abs(r__1)) <= safmin && ( + r__2 = p[je + je * p_dim1], abs(r__2)) <= safmin) { + +/* Singular matrix pencil -- return unit eigenvector */ + + ++ieig; + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vl[jr + ieig * vl_dim1] = 0.f; +/* L60: */ + } + vl[ieig + ieig * vl_dim1] = 1.f; + goto L220; + } + } + +/* Clear vector */ + + i__2 = nw * *n; + for (jr = 1; jr <= i__2; ++jr) { + work[(*n << 1) + jr] = 0.f; +/* L70: */ + } +/* T */ +/* Compute coefficients in ( a A - b B ) y = 0 */ +/* a is ACOEF */ +/* b is BCOEFR + i*BCOEFI */ + + if (! ilcplx) { + +/* Real eigenvalue */ + +/* Computing MAX */ + r__3 = (r__1 = s[je + je * s_dim1], abs(r__1)) * ascale, r__4 + = (r__2 = p[je + je * p_dim1], abs(r__2)) * bscale, + r__3 = f2cmax(r__3,r__4); + temp = 1.f / f2cmax(r__3,safmin); + salfar = temp * s[je + je * s_dim1] * ascale; + sbeta = temp * p[je + je * p_dim1] * bscale; + acoef = sbeta * ascale; + bcoefr = salfar * bscale; + bcoefi = 0.f; + +/* Scale to avoid underflow */ + + scale = 1.f; + lsa = abs(sbeta) >= safmin && abs(acoef) < small; + lsb = abs(salfar) >= safmin && abs(bcoefr) < small; + if (lsa) { + scale = small / abs(sbeta) * f2cmin(anorm,big); + } + if (lsb) { +/* Computing MAX */ + r__1 = scale, r__2 = small / abs(salfar) * f2cmin(bnorm,big); + scale = f2cmax(r__1,r__2); + } + if (lsa || lsb) { +/* Computing MIN */ +/* Computing MAX */ + r__3 = 1.f, r__4 = abs(acoef), r__3 = f2cmax(r__3,r__4), + r__4 = abs(bcoefr); + r__1 = scale, r__2 = 1.f / (safmin * f2cmax(r__3,r__4)); + scale = f2cmin(r__1,r__2); + if (lsa) { + acoef = ascale * (scale * sbeta); + } else { + acoef = scale * acoef; + } + if (lsb) { + bcoefr = bscale * (scale * salfar); + } else { + bcoefr = scale * bcoefr; + } + } + acoefa = abs(acoef); + bcoefa = abs(bcoefr); + +/* First component is 1 */ + + work[(*n << 1) + je] = 1.f; + xmax = 1.f; + } else { + +/* Complex eigenvalue */ + + r__1 = safmin * 100.f; + slag2_(&s[je + je * s_dim1], lds, &p[je + je * p_dim1], ldp, & + r__1, &acoef, &temp, &bcoefr, &temp2, &bcoefi); + bcoefi = -bcoefi; + if (bcoefi == 0.f) { + *info = je; + return 0; + } + +/* Scale to avoid over/underflow */ + + acoefa = abs(acoef); + bcoefa = abs(bcoefr) + abs(bcoefi); + scale = 1.f; + if (acoefa * ulp < safmin && acoefa >= safmin) { + scale = safmin / ulp / acoefa; + } + if (bcoefa * ulp < safmin && bcoefa >= safmin) { +/* Computing MAX */ + r__1 = scale, r__2 = safmin / ulp / bcoefa; + scale = f2cmax(r__1,r__2); + } + if (safmin * acoefa > ascale) { + scale = ascale / (safmin * acoefa); + } + if (safmin * bcoefa > bscale) { +/* Computing MIN */ + r__1 = scale, r__2 = bscale / (safmin * bcoefa); + scale = f2cmin(r__1,r__2); + } + if (scale != 1.f) { + acoef = scale * acoef; + acoefa = abs(acoef); + bcoefr = scale * bcoefr; + bcoefi = scale * bcoefi; + bcoefa = abs(bcoefr) + abs(bcoefi); + } + +/* Compute first two components of eigenvector */ + + temp = acoef * s[je + 1 + je * s_dim1]; + temp2r = acoef * s[je + je * s_dim1] - bcoefr * p[je + je * + p_dim1]; + temp2i = -bcoefi * p[je + je * p_dim1]; + if (abs(temp) > abs(temp2r) + abs(temp2i)) { + work[(*n << 1) + je] = 1.f; + work[*n * 3 + je] = 0.f; + work[(*n << 1) + je + 1] = -temp2r / temp; + work[*n * 3 + je + 1] = -temp2i / temp; + } else { + work[(*n << 1) + je + 1] = 1.f; + work[*n * 3 + je + 1] = 0.f; + temp = acoef * s[je + (je + 1) * s_dim1]; + work[(*n << 1) + je] = (bcoefr * p[je + 1 + (je + 1) * + p_dim1] - acoef * s[je + 1 + (je + 1) * s_dim1]) / + temp; + work[*n * 3 + je] = bcoefi * p[je + 1 + (je + 1) * p_dim1] + / temp; + } +/* Computing MAX */ + r__5 = (r__1 = work[(*n << 1) + je], abs(r__1)) + (r__2 = + work[*n * 3 + je], abs(r__2)), r__6 = (r__3 = work[(* + n << 1) + je + 1], abs(r__3)) + (r__4 = work[*n * 3 + + je + 1], abs(r__4)); + xmax = f2cmax(r__5,r__6); + } + +/* Computing MAX */ + r__1 = ulp * acoefa * anorm, r__2 = ulp * bcoefa * bnorm, r__1 = + f2cmax(r__1,r__2); + dmin__ = f2cmax(r__1,safmin); + +/* T */ +/* Triangular solve of (a A - b B) y = 0 */ + +/* T */ +/* (rowwise in (a A - b B) , or columnwise in (a A - b B) ) */ + + il2by2 = FALSE_; + + i__2 = *n; + for (j = je + nw; j <= i__2; ++j) { + if (il2by2) { + il2by2 = FALSE_; + goto L160; + } + + na = 1; + bdiag[0] = p[j + j * p_dim1]; + if (j < *n) { + if (s[j + 1 + j * s_dim1] != 0.f) { + il2by2 = TRUE_; + bdiag[1] = p[j + 1 + (j + 1) * p_dim1]; + na = 2; + } + } + +/* Check whether scaling is necessary for dot products */ + + xscale = 1.f / f2cmax(1.f,xmax); +/* Computing MAX */ + r__1 = work[j], r__2 = work[*n + j], r__1 = f2cmax(r__1,r__2), + r__2 = acoefa * work[j] + bcoefa * work[*n + j]; + temp = f2cmax(r__1,r__2); + if (il2by2) { +/* Computing MAX */ + r__1 = temp, r__2 = work[j + 1], r__1 = f2cmax(r__1,r__2), + r__2 = work[*n + j + 1], r__1 = f2cmax(r__1,r__2), + r__2 = acoefa * work[j + 1] + bcoefa * work[*n + + j + 1]; + temp = f2cmax(r__1,r__2); + } + if (temp > bignum * xscale) { + i__3 = nw - 1; + for (jw = 0; jw <= i__3; ++jw) { + i__4 = j - 1; + for (jr = je; jr <= i__4; ++jr) { + work[(jw + 2) * *n + jr] = xscale * work[(jw + 2) + * *n + jr]; +/* L80: */ + } +/* L90: */ + } + xmax *= xscale; + } + +/* Compute dot products */ + +/* j-1 */ +/* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) */ +/* k=je */ + +/* To reduce the op count, this is done as */ + +/* _ j-1 _ j-1 */ +/* a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) ) */ +/* k=je k=je */ + +/* which may cause underflow problems if A or B are close */ +/* to underflow. (E.g., less than SMALL.) */ + + + i__3 = nw; + for (jw = 1; jw <= i__3; ++jw) { + i__4 = na; + for (ja = 1; ja <= i__4; ++ja) { + sums[ja + (jw << 1) - 3] = 0.f; + sump[ja + (jw << 1) - 3] = 0.f; + + i__5 = j - 1; + for (jr = je; jr <= i__5; ++jr) { + sums[ja + (jw << 1) - 3] += s[jr + (j + ja - 1) * + s_dim1] * work[(jw + 1) * *n + jr]; + sump[ja + (jw << 1) - 3] += p[jr + (j + ja - 1) * + p_dim1] * work[(jw + 1) * *n + jr]; +/* L100: */ + } +/* L110: */ + } +/* L120: */ + } + + i__3 = na; + for (ja = 1; ja <= i__3; ++ja) { + if (ilcplx) { + sum[ja - 1] = -acoef * sums[ja - 1] + bcoefr * sump[ + ja - 1] - bcoefi * sump[ja + 1]; + sum[ja + 1] = -acoef * sums[ja + 1] + bcoefr * sump[ + ja + 1] + bcoefi * sump[ja - 1]; + } else { + sum[ja - 1] = -acoef * sums[ja - 1] + bcoefr * sump[ + ja - 1]; + } +/* L130: */ + } + +/* T */ +/* Solve ( a A - b B ) y = SUM(,) */ +/* with scaling and perturbation of the denominator */ + + slaln2_(&c_true, &na, &nw, &dmin__, &acoef, &s[j + j * s_dim1] + , lds, bdiag, &bdiag[1], sum, &c__2, &bcoefr, &bcoefi, + &work[(*n << 1) + j], n, &scale, &temp, &iinfo); + if (scale < 1.f) { + i__3 = nw - 1; + for (jw = 0; jw <= i__3; ++jw) { + i__4 = j - 1; + for (jr = je; jr <= i__4; ++jr) { + work[(jw + 2) * *n + jr] = scale * work[(jw + 2) * + *n + jr]; +/* L140: */ + } +/* L150: */ + } + xmax = scale * xmax; + } + xmax = f2cmax(xmax,temp); +L160: + ; + } + +/* Copy eigenvector to VL, back transforming if */ +/* HOWMNY='B'. */ + + ++ieig; + if (ilback) { + i__2 = nw - 1; + for (jw = 0; jw <= i__2; ++jw) { + i__3 = *n + 1 - je; + sgemv_("N", n, &i__3, &c_b34, &vl[je * vl_dim1 + 1], ldvl, + &work[(jw + 2) * *n + je], &c__1, &c_b36, &work[( + jw + 4) * *n + 1], &c__1); +/* L170: */ + } + slacpy_(" ", n, &nw, &work[(*n << 2) + 1], n, &vl[je * + vl_dim1 + 1], ldvl); + ibeg = 1; + } else { + slacpy_(" ", n, &nw, &work[(*n << 1) + 1], n, &vl[ieig * + vl_dim1 + 1], ldvl); + ibeg = je; + } + +/* Scale eigenvector */ + + xmax = 0.f; + if (ilcplx) { + i__2 = *n; + for (j = ibeg; j <= i__2; ++j) { +/* Computing MAX */ + r__3 = xmax, r__4 = (r__1 = vl[j + ieig * vl_dim1], abs( + r__1)) + (r__2 = vl[j + (ieig + 1) * vl_dim1], + abs(r__2)); + xmax = f2cmax(r__3,r__4); +/* L180: */ + } + } else { + i__2 = *n; + for (j = ibeg; j <= i__2; ++j) { +/* Computing MAX */ + r__2 = xmax, r__3 = (r__1 = vl[j + ieig * vl_dim1], abs( + r__1)); + xmax = f2cmax(r__2,r__3); +/* L190: */ + } + } + + if (xmax > safmin) { + xscale = 1.f / xmax; + + i__2 = nw - 1; + for (jw = 0; jw <= i__2; ++jw) { + i__3 = *n; + for (jr = ibeg; jr <= i__3; ++jr) { + vl[jr + (ieig + jw) * vl_dim1] = xscale * vl[jr + ( + ieig + jw) * vl_dim1]; +/* L200: */ + } +/* L210: */ + } + } + ieig = ieig + nw - 1; + +L220: + ; + } + } + +/* Right eigenvectors */ + + if (compr) { + ieig = im + 1; + +/* Main loop over eigenvalues */ + + ilcplx = FALSE_; + for (je = *n; je >= 1; --je) { + +/* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or */ +/* (b) this would be the second of a complex pair. */ +/* Check for complex eigenvalue, so as to be sure of which */ +/* entry(-ies) of SELECT to look at -- if complex, SELECT(JE) */ +/* or SELECT(JE-1). */ +/* If this is a complex pair, the 2-by-2 diagonal block */ +/* corresponding to the eigenvalue is in rows/columns JE-1:JE */ + + if (ilcplx) { + ilcplx = FALSE_; + goto L500; + } + nw = 1; + if (je > 1) { + if (s[je + (je - 1) * s_dim1] != 0.f) { + ilcplx = TRUE_; + nw = 2; + } + } + if (ilall) { + ilcomp = TRUE_; + } else if (ilcplx) { + ilcomp = select[je] || select[je - 1]; + } else { + ilcomp = select[je]; + } + if (! ilcomp) { + goto L500; + } + +/* Decide if (a) singular pencil, (b) real eigenvalue, or */ +/* (c) complex eigenvalue. */ + + if (! ilcplx) { + if ((r__1 = s[je + je * s_dim1], abs(r__1)) <= safmin && ( + r__2 = p[je + je * p_dim1], abs(r__2)) <= safmin) { + +/* Singular matrix pencil -- unit eigenvector */ + + --ieig; + i__1 = *n; + for (jr = 1; jr <= i__1; ++jr) { + vr[jr + ieig * vr_dim1] = 0.f; +/* L230: */ + } + vr[ieig + ieig * vr_dim1] = 1.f; + goto L500; + } + } + +/* Clear vector */ + + i__1 = nw - 1; + for (jw = 0; jw <= i__1; ++jw) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + work[(jw + 2) * *n + jr] = 0.f; +/* L240: */ + } +/* L250: */ + } + +/* Compute coefficients in ( a A - b B ) x = 0 */ +/* a is ACOEF */ +/* b is BCOEFR + i*BCOEFI */ + + if (! ilcplx) { + +/* Real eigenvalue */ + +/* Computing MAX */ + r__3 = (r__1 = s[je + je * s_dim1], abs(r__1)) * ascale, r__4 + = (r__2 = p[je + je * p_dim1], abs(r__2)) * bscale, + r__3 = f2cmax(r__3,r__4); + temp = 1.f / f2cmax(r__3,safmin); + salfar = temp * s[je + je * s_dim1] * ascale; + sbeta = temp * p[je + je * p_dim1] * bscale; + acoef = sbeta * ascale; + bcoefr = salfar * bscale; + bcoefi = 0.f; + +/* Scale to avoid underflow */ + + scale = 1.f; + lsa = abs(sbeta) >= safmin && abs(acoef) < small; + lsb = abs(salfar) >= safmin && abs(bcoefr) < small; + if (lsa) { + scale = small / abs(sbeta) * f2cmin(anorm,big); + } + if (lsb) { +/* Computing MAX */ + r__1 = scale, r__2 = small / abs(salfar) * f2cmin(bnorm,big); + scale = f2cmax(r__1,r__2); + } + if (lsa || lsb) { +/* Computing MIN */ +/* Computing MAX */ + r__3 = 1.f, r__4 = abs(acoef), r__3 = f2cmax(r__3,r__4), + r__4 = abs(bcoefr); + r__1 = scale, r__2 = 1.f / (safmin * f2cmax(r__3,r__4)); + scale = f2cmin(r__1,r__2); + if (lsa) { + acoef = ascale * (scale * sbeta); + } else { + acoef = scale * acoef; + } + if (lsb) { + bcoefr = bscale * (scale * salfar); + } else { + bcoefr = scale * bcoefr; + } + } + acoefa = abs(acoef); + bcoefa = abs(bcoefr); + +/* First component is 1 */ + + work[(*n << 1) + je] = 1.f; + xmax = 1.f; + +/* Compute contribution from column JE of A and B to sum */ +/* (See "Further Details", above.) */ + + i__1 = je - 1; + for (jr = 1; jr <= i__1; ++jr) { + work[(*n << 1) + jr] = bcoefr * p[jr + je * p_dim1] - + acoef * s[jr + je * s_dim1]; +/* L260: */ + } + } else { + +/* Complex eigenvalue */ + + r__1 = safmin * 100.f; + slag2_(&s[je - 1 + (je - 1) * s_dim1], lds, &p[je - 1 + (je - + 1) * p_dim1], ldp, &r__1, &acoef, &temp, &bcoefr, & + temp2, &bcoefi); + if (bcoefi == 0.f) { + *info = je - 1; + return 0; + } + +/* Scale to avoid over/underflow */ + + acoefa = abs(acoef); + bcoefa = abs(bcoefr) + abs(bcoefi); + scale = 1.f; + if (acoefa * ulp < safmin && acoefa >= safmin) { + scale = safmin / ulp / acoefa; + } + if (bcoefa * ulp < safmin && bcoefa >= safmin) { +/* Computing MAX */ + r__1 = scale, r__2 = safmin / ulp / bcoefa; + scale = f2cmax(r__1,r__2); + } + if (safmin * acoefa > ascale) { + scale = ascale / (safmin * acoefa); + } + if (safmin * bcoefa > bscale) { +/* Computing MIN */ + r__1 = scale, r__2 = bscale / (safmin * bcoefa); + scale = f2cmin(r__1,r__2); + } + if (scale != 1.f) { + acoef = scale * acoef; + acoefa = abs(acoef); + bcoefr = scale * bcoefr; + bcoefi = scale * bcoefi; + bcoefa = abs(bcoefr) + abs(bcoefi); + } + +/* Compute first two components of eigenvector */ +/* and contribution to sums */ + + temp = acoef * s[je + (je - 1) * s_dim1]; + temp2r = acoef * s[je + je * s_dim1] - bcoefr * p[je + je * + p_dim1]; + temp2i = -bcoefi * p[je + je * p_dim1]; + if (abs(temp) >= abs(temp2r) + abs(temp2i)) { + work[(*n << 1) + je] = 1.f; + work[*n * 3 + je] = 0.f; + work[(*n << 1) + je - 1] = -temp2r / temp; + work[*n * 3 + je - 1] = -temp2i / temp; + } else { + work[(*n << 1) + je - 1] = 1.f; + work[*n * 3 + je - 1] = 0.f; + temp = acoef * s[je - 1 + je * s_dim1]; + work[(*n << 1) + je] = (bcoefr * p[je - 1 + (je - 1) * + p_dim1] - acoef * s[je - 1 + (je - 1) * s_dim1]) / + temp; + work[*n * 3 + je] = bcoefi * p[je - 1 + (je - 1) * p_dim1] + / temp; + } + +/* Computing MAX */ + r__5 = (r__1 = work[(*n << 1) + je], abs(r__1)) + (r__2 = + work[*n * 3 + je], abs(r__2)), r__6 = (r__3 = work[(* + n << 1) + je - 1], abs(r__3)) + (r__4 = work[*n * 3 + + je - 1], abs(r__4)); + xmax = f2cmax(r__5,r__6); + +/* Compute contribution from columns JE and JE-1 */ +/* of A and B to the sums. */ + + creala = acoef * work[(*n << 1) + je - 1]; + cimaga = acoef * work[*n * 3 + je - 1]; + crealb = bcoefr * work[(*n << 1) + je - 1] - bcoefi * work[*n + * 3 + je - 1]; + cimagb = bcoefi * work[(*n << 1) + je - 1] + bcoefr * work[*n + * 3 + je - 1]; + cre2a = acoef * work[(*n << 1) + je]; + cim2a = acoef * work[*n * 3 + je]; + cre2b = bcoefr * work[(*n << 1) + je] - bcoefi * work[*n * 3 + + je]; + cim2b = bcoefi * work[(*n << 1) + je] + bcoefr * work[*n * 3 + + je]; + i__1 = je - 2; + for (jr = 1; jr <= i__1; ++jr) { + work[(*n << 1) + jr] = -creala * s[jr + (je - 1) * s_dim1] + + crealb * p[jr + (je - 1) * p_dim1] - cre2a * s[ + jr + je * s_dim1] + cre2b * p[jr + je * p_dim1]; + work[*n * 3 + jr] = -cimaga * s[jr + (je - 1) * s_dim1] + + cimagb * p[jr + (je - 1) * p_dim1] - cim2a * s[jr + + je * s_dim1] + cim2b * p[jr + je * p_dim1]; +/* L270: */ + } + } + +/* Computing MAX */ + r__1 = ulp * acoefa * anorm, r__2 = ulp * bcoefa * bnorm, r__1 = + f2cmax(r__1,r__2); + dmin__ = f2cmax(r__1,safmin); + +/* Columnwise triangular solve of (a A - b B) x = 0 */ + + il2by2 = FALSE_; + for (j = je - nw; j >= 1; --j) { + +/* If a 2-by-2 block, is in position j-1:j, wait until */ +/* next iteration to process it (when it will be j:j+1) */ + + if (! il2by2 && j > 1) { + if (s[j + (j - 1) * s_dim1] != 0.f) { + il2by2 = TRUE_; + goto L370; + } + } + bdiag[0] = p[j + j * p_dim1]; + if (il2by2) { + na = 2; + bdiag[1] = p[j + 1 + (j + 1) * p_dim1]; + } else { + na = 1; + } + +/* Compute x(j) (and x(j+1), if 2-by-2 block) */ + + slaln2_(&c_false, &na, &nw, &dmin__, &acoef, &s[j + j * + s_dim1], lds, bdiag, &bdiag[1], &work[(*n << 1) + j], + n, &bcoefr, &bcoefi, sum, &c__2, &scale, &temp, & + iinfo); + if (scale < 1.f) { + + i__1 = nw - 1; + for (jw = 0; jw <= i__1; ++jw) { + i__2 = je; + for (jr = 1; jr <= i__2; ++jr) { + work[(jw + 2) * *n + jr] = scale * work[(jw + 2) * + *n + jr]; +/* L280: */ + } +/* L290: */ + } + } +/* Computing MAX */ + r__1 = scale * xmax; + xmax = f2cmax(r__1,temp); + + i__1 = nw; + for (jw = 1; jw <= i__1; ++jw) { + i__2 = na; + for (ja = 1; ja <= i__2; ++ja) { + work[(jw + 1) * *n + j + ja - 1] = sum[ja + (jw << 1) + - 3]; +/* L300: */ + } +/* L310: */ + } + +/* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling */ + + if (j > 1) { + +/* Check whether scaling is necessary for sum. */ + + xscale = 1.f / f2cmax(1.f,xmax); + temp = acoefa * work[j] + bcoefa * work[*n + j]; + if (il2by2) { +/* Computing MAX */ + r__1 = temp, r__2 = acoefa * work[j + 1] + bcoefa * + work[*n + j + 1]; + temp = f2cmax(r__1,r__2); + } +/* Computing MAX */ + r__1 = f2cmax(temp,acoefa); + temp = f2cmax(r__1,bcoefa); + if (temp > bignum * xscale) { + + i__1 = nw - 1; + for (jw = 0; jw <= i__1; ++jw) { + i__2 = je; + for (jr = 1; jr <= i__2; ++jr) { + work[(jw + 2) * *n + jr] = xscale * work[(jw + + 2) * *n + jr]; +/* L320: */ + } +/* L330: */ + } + xmax *= xscale; + } + +/* Compute the contributions of the off-diagonals of */ +/* column j (and j+1, if 2-by-2 block) of A and B to the */ +/* sums. */ + + + i__1 = na; + for (ja = 1; ja <= i__1; ++ja) { + if (ilcplx) { + creala = acoef * work[(*n << 1) + j + ja - 1]; + cimaga = acoef * work[*n * 3 + j + ja - 1]; + crealb = bcoefr * work[(*n << 1) + j + ja - 1] - + bcoefi * work[*n * 3 + j + ja - 1]; + cimagb = bcoefi * work[(*n << 1) + j + ja - 1] + + bcoefr * work[*n * 3 + j + ja - 1]; + i__2 = j - 1; + for (jr = 1; jr <= i__2; ++jr) { + work[(*n << 1) + jr] = work[(*n << 1) + jr] - + creala * s[jr + (j + ja - 1) * s_dim1] + + crealb * p[jr + (j + ja - 1) * + p_dim1]; + work[*n * 3 + jr] = work[*n * 3 + jr] - + cimaga * s[jr + (j + ja - 1) * s_dim1] + + cimagb * p[jr + (j + ja - 1) * + p_dim1]; +/* L340: */ + } + } else { + creala = acoef * work[(*n << 1) + j + ja - 1]; + crealb = bcoefr * work[(*n << 1) + j + ja - 1]; + i__2 = j - 1; + for (jr = 1; jr <= i__2; ++jr) { + work[(*n << 1) + jr] = work[(*n << 1) + jr] - + creala * s[jr + (j + ja - 1) * s_dim1] + + crealb * p[jr + (j + ja - 1) * + p_dim1]; +/* L350: */ + } + } +/* L360: */ + } + } + + il2by2 = FALSE_; +L370: + ; + } + +/* Copy eigenvector to VR, back transforming if */ +/* HOWMNY='B'. */ + + ieig -= nw; + if (ilback) { + + i__1 = nw - 1; + for (jw = 0; jw <= i__1; ++jw) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + work[(jw + 4) * *n + jr] = work[(jw + 2) * *n + 1] * + vr[jr + vr_dim1]; +/* L380: */ + } + +/* A series of compiler directives to defeat */ +/* vectorization for the next loop */ + + + i__2 = je; + for (jc = 2; jc <= i__2; ++jc) { + i__3 = *n; + for (jr = 1; jr <= i__3; ++jr) { + work[(jw + 4) * *n + jr] += work[(jw + 2) * *n + + jc] * vr[jr + jc * vr_dim1]; +/* L390: */ + } +/* L400: */ + } +/* L410: */ + } + + i__1 = nw - 1; + for (jw = 0; jw <= i__1; ++jw) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + (ieig + jw) * vr_dim1] = work[(jw + 4) * *n + + jr]; +/* L420: */ + } +/* L430: */ + } + + iend = *n; + } else { + i__1 = nw - 1; + for (jw = 0; jw <= i__1; ++jw) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + (ieig + jw) * vr_dim1] = work[(jw + 2) * *n + + jr]; +/* L440: */ + } +/* L450: */ + } + + iend = je; + } + +/* Scale eigenvector */ + + xmax = 0.f; + if (ilcplx) { + i__1 = iend; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + r__3 = xmax, r__4 = (r__1 = vr[j + ieig * vr_dim1], abs( + r__1)) + (r__2 = vr[j + (ieig + 1) * vr_dim1], + abs(r__2)); + xmax = f2cmax(r__3,r__4); +/* L460: */ + } + } else { + i__1 = iend; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + r__2 = xmax, r__3 = (r__1 = vr[j + ieig * vr_dim1], abs( + r__1)); + xmax = f2cmax(r__2,r__3); +/* L470: */ + } + } + + if (xmax > safmin) { + xscale = 1.f / xmax; + i__1 = nw - 1; + for (jw = 0; jw <= i__1; ++jw) { + i__2 = iend; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + (ieig + jw) * vr_dim1] = xscale * vr[jr + ( + ieig + jw) * vr_dim1]; +/* L480: */ + } +/* L490: */ + } + } +L500: + ; + } + } + + return 0; + +/* End of STGEVC */ + +} /* stgevc_ */ + diff --git a/lapack-netlib/SRC/stgex2.c b/lapack-netlib/SRC/stgex2.c new file mode 100644 index 000000000..7a3969bb9 --- /dev/null +++ b/lapack-netlib/SRC/stgex2.c @@ -0,0 +1,1181 @@ +/* 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 STGEX2 swaps adjacent diagonal blocks in an upper (quasi) triangular matrix pair by an orthogon +al equivalence transformation. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STGEX2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, */ +/* LDZ, J1, N1, N2, WORK, LWORK, INFO ) */ + +/* LOGICAL WANTQ, WANTZ */ +/* INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, LWORK, N, N1, N2 */ +/* REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ), */ +/* $ WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22) */ +/* > of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair */ +/* > (A, B) by an orthogonal equivalence transformation. */ +/* > */ +/* > (A, B) must be in generalized real Schur canonical form (as returned */ +/* > by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 */ +/* > diagonal blocks. B is upper triangular. */ +/* > */ +/* > Optionally, the matrices Q and Z of generalized Schur vectors are */ +/* > updated. */ +/* > */ +/* > Q(in) * A(in) * Z(in)**T = Q(out) * A(out) * Z(out)**T */ +/* > Q(in) * B(in) * Z(in)**T = Q(out) * B(out) * Z(out)**T */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] WANTQ */ +/* > \verbatim */ +/* > WANTQ is LOGICAL */ +/* > .TRUE. : update the left transformation matrix Q; */ +/* > .FALSE.: do not update Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTZ */ +/* > \verbatim */ +/* > WANTZ is LOGICAL */ +/* > .TRUE. : update the right transformation matrix Z; */ +/* > .FALSE.: do not update Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the matrix A in the pair (A, B). */ +/* > On exit, the updated matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,N) */ +/* > On entry, the matrix B in the pair (A, B). */ +/* > On exit, the updated matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is REAL array, dimension (LDQ,N) */ +/* > On entry, if WANTQ = .TRUE., the orthogonal matrix Q. */ +/* > On exit, the updated matrix Q. */ +/* > Not referenced if WANTQ = .FALSE.. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= 1. */ +/* > If WANTQ = .TRUE., LDQ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension (LDZ,N) */ +/* > On entry, if WANTZ =.TRUE., the orthogonal matrix Z. */ +/* > On exit, the updated matrix Z. */ +/* > Not referenced if WANTZ = .FALSE.. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1. */ +/* > If WANTZ = .TRUE., LDZ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] J1 */ +/* > \verbatim */ +/* > J1 is INTEGER */ +/* > The index to the first block (A11, B11). 1 <= J1 <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N1 */ +/* > \verbatim */ +/* > N1 is INTEGER */ +/* > The order of the first block (A11, B11). N1 = 0, 1 or 2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N2 */ +/* > \verbatim */ +/* > N2 is INTEGER */ +/* > The order of the second block (A22, B22). N2 = 0, 1 or 2. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MAX(1,LWORK)). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > LWORK >= MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 ) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > =0: Successful exit */ +/* > >0: If INFO = 1, the transformed matrix (A, B) would be */ +/* > too far from generalized Schur form; the blocks are */ +/* > not swapped and (A, B) and (Q, Z) are unchanged. */ +/* > The problem of swapping is too ill-conditioned. */ +/* > <0: If INFO = -16: LWORK is too small. Appropriate value */ +/* > for LWORK is returned in WORK(1). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup realGEauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > In the current code both weak and strong stability tests are */ +/* > performed. The user can omit the strong stability test by changing */ +/* > the internal logical parameter WANDS to .FALSE.. See ref. [2] for */ +/* > details. */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* > Umea University, S-901 87 Umea, Sweden. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > \verbatim */ +/* > */ +/* > [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */ +/* > Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */ +/* > M.S. Moonen et al (eds), Linear Algebra for Large Scale and */ +/* > Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */ +/* > */ +/* > [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */ +/* > Eigenvalues of a Regular Matrix Pair (A, B) and Condition */ +/* > Estimation: Theory, Algorithms and Software, */ +/* > Report UMINF - 94.04, Department of Computing Science, Umea */ +/* > University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */ +/* > Note 87. To appear in Numerical Algorithms, 1996. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int stgex2_(logical *wantq, logical *wantz, integer *n, real + *a, integer *lda, real *b, integer *ldb, real *q, integer *ldq, real * + z__, integer *ldz, integer *j1, integer *n1, integer *n2, real *work, + integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, + z_offset, i__1, i__2; + real r__1; + + /* Local variables */ + logical weak; + real ddum; + integer idum; + real taul[4], dsum, taur[4], scpy[16] /* was [4][4] */, tcpy[16] + /* was [4][4] */; + extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, + integer *, real *, real *); + real f, g; + integer i__, m; + real s[16] /* was [4][4] */, t[16] /* was [4][4] */, scale, bqra21, + brqa21; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + real licop[16] /* was [4][4] */; + integer linfo; + extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *); + real ircop[16] /* was [4][4] */, dnorm; + integer iwork[4]; + extern /* Subroutine */ int slagv2_(real *, integer *, real *, integer *, + real *, real *, real *, real *, real *, real *, real *), sgeqr2_( + integer *, integer *, real *, integer *, real *, real *, integer * + ), sgerq2_(integer *, integer *, real *, integer *, real *, real * + , integer *); + real be[2], ai[2]; + extern /* Subroutine */ int sorg2r_(integer *, integer *, integer *, real + *, integer *, real *, real *, integer *), sorgr2_(integer *, + integer *, integer *, real *, integer *, real *, real *, integer * + ); + real ar[2], sa, sb, li[16] /* was [4][4] */; + extern /* Subroutine */ int sorm2r_(char *, char *, integer *, integer *, + integer *, real *, integer *, real *, real *, integer *, real *, + integer *), sormr2_(char *, char *, integer *, + integer *, integer *, real *, integer *, real *, real *, integer * + , real *, integer *); + real dscale, ir[16] /* was [4][4] */; + extern /* Subroutine */ int stgsy2_(char *, integer *, integer *, integer + *, real *, integer *, real *, integer *, real *, integer *, real * + , integer *, real *, integer *, real *, integer *, real *, real *, + real *, integer *, integer *, integer *); + real ss; + extern real slamch_(char *); + real ws; + extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, + integer *, real *, integer *), slartg_(real *, real *, + real *, real *, real *); + real thresh; + extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *, + real *, real *, integer *), slassq_(integer *, real *, + integer *, real *, real *); + real smlnum; + logical strong; + real eps; + + +/* -- 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 */ + + +/* ===================================================================== */ +/* Replaced various illegal calls to SCOPY by calls to SLASET, or by DO */ +/* loops. Sven Hammarling, 1/5/02. */ + + + /* 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; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n <= 1 || *n1 <= 0 || *n2 <= 0) { + return 0; + } + if (*n1 > *n || *j1 + *n1 > *n) { + return 0; + } + m = *n1 + *n2; +/* Computing MAX */ + i__1 = *n * m, i__2 = m * m << 1; + if (*lwork < f2cmax(i__1,i__2)) { + *info = -16; +/* Computing MAX */ + i__1 = *n * m, i__2 = m * m << 1; + work[1] = (real) f2cmax(i__1,i__2); + return 0; + } + + weak = FALSE_; + strong = FALSE_; + +/* Make a local copy of selected block */ + + slaset_("Full", &c__4, &c__4, &c_b5, &c_b5, li, &c__4); + slaset_("Full", &c__4, &c__4, &c_b5, &c_b5, ir, &c__4); + slacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, s, &c__4); + slacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, t, &c__4); + +/* Compute threshold for testing acceptance of swapping. */ + + eps = slamch_("P"); + smlnum = slamch_("S") / eps; + dscale = 0.f; + dsum = 1.f; + slacpy_("Full", &m, &m, s, &c__4, &work[1], &m); + i__1 = m * m; + slassq_(&i__1, &work[1], &c__1, &dscale, &dsum); + slacpy_("Full", &m, &m, t, &c__4, &work[1], &m); + i__1 = m * m; + slassq_(&i__1, &work[1], &c__1, &dscale, &dsum); + dnorm = dscale * sqrt(dsum); + +/* THRES has been changed from */ +/* THRESH = MAX( TEN*EPS*SA, SMLNUM ) */ +/* to */ +/* THRESH = MAX( TWENTY*EPS*SA, SMLNUM ) */ +/* on 04/01/10. */ +/* "Bug" reported by Ondra Kamenik, confirmed by Julie Langou, fixed by */ +/* Jim Demmel and Guillaume Revy. See forum post 1783. */ + +/* Computing MAX */ + r__1 = eps * 20.f * dnorm; + thresh = f2cmax(r__1,smlnum); + + if (m == 2) { + +/* CASE 1: Swap 1-by-1 and 1-by-1 blocks. */ + +/* Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks */ +/* using Givens rotations and perform the swap tentatively. */ + + f = s[5] * t[0] - t[5] * s[0]; + g = s[5] * t[4] - t[5] * s[4]; + sb = abs(t[5]); + sa = abs(s[5]); + slartg_(&f, &g, &ir[4], ir, &ddum); + ir[1] = -ir[4]; + ir[5] = ir[0]; + srot_(&c__2, s, &c__1, &s[4], &c__1, ir, &ir[1]); + srot_(&c__2, t, &c__1, &t[4], &c__1, ir, &ir[1]); + if (sa >= sb) { + slartg_(s, &s[1], li, &li[1], &ddum); + } else { + slartg_(t, &t[1], li, &li[1], &ddum); + } + srot_(&c__2, s, &c__4, &s[1], &c__4, li, &li[1]); + srot_(&c__2, t, &c__4, &t[1], &c__4, li, &li[1]); + li[5] = li[0]; + li[4] = -li[1]; + +/* Weak stability test: */ +/* |S21| + |T21| <= O(EPS * F-norm((S, T))) */ + + ws = abs(s[1]) + abs(t[1]); + weak = ws <= thresh; + if (! weak) { + goto L70; + } + + if (TRUE_) { + +/* Strong stability test: */ +/* F-norm((A-QL**T*S*QR, B-QL**T*T*QR)) <= O(EPS*F-norm((A, B))) */ + + slacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, &work[m * m + + 1], &m); + sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, & + work[1], &m); + sgemm_("N", "T", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, & + c_b42, &work[m * m + 1], &m); + dscale = 0.f; + dsum = 1.f; + i__1 = m * m; + slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); + + slacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, &work[m * m + + 1], &m); + sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, & + work[1], &m); + sgemm_("N", "T", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, & + c_b42, &work[m * m + 1], &m); + i__1 = m * m; + slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); + ss = dscale * sqrt(dsum); + strong = ss <= thresh; + if (! strong) { + goto L70; + } + } + +/* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and */ +/* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */ + + i__1 = *j1 + 1; + srot_(&i__1, &a[*j1 * a_dim1 + 1], &c__1, &a[(*j1 + 1) * a_dim1 + 1], + &c__1, ir, &ir[1]); + i__1 = *j1 + 1; + srot_(&i__1, &b[*j1 * b_dim1 + 1], &c__1, &b[(*j1 + 1) * b_dim1 + 1], + &c__1, ir, &ir[1]); + i__1 = *n - *j1 + 1; + srot_(&i__1, &a[*j1 + *j1 * a_dim1], lda, &a[*j1 + 1 + *j1 * a_dim1], + lda, li, &li[1]); + i__1 = *n - *j1 + 1; + srot_(&i__1, &b[*j1 + *j1 * b_dim1], ldb, &b[*j1 + 1 + *j1 * b_dim1], + ldb, li, &li[1]); + +/* Set N1-by-N2 (2,1) - blocks to ZERO. */ + + a[*j1 + 1 + *j1 * a_dim1] = 0.f; + b[*j1 + 1 + *j1 * b_dim1] = 0.f; + +/* Accumulate transformations into Q and Z if requested. */ + + if (*wantz) { + srot_(n, &z__[*j1 * z_dim1 + 1], &c__1, &z__[(*j1 + 1) * z_dim1 + + 1], &c__1, ir, &ir[1]); + } + if (*wantq) { + srot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[(*j1 + 1) * q_dim1 + 1], + &c__1, li, &li[1]); + } + +/* Exit with INFO = 0 if swap was successfully performed. */ + + return 0; + + } else { + +/* CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2 */ +/* and 2-by-2 blocks. */ + +/* Solve the generalized Sylvester equation */ +/* S11 * R - L * S22 = SCALE * S12 */ +/* T11 * R - L * T22 = SCALE * T12 */ +/* for R and L. Solutions in LI and IR. */ + + slacpy_("Full", n1, n2, &t[(*n1 + 1 << 2) - 4], &c__4, li, &c__4); + slacpy_("Full", n1, n2, &s[(*n1 + 1 << 2) - 4], &c__4, &ir[*n2 + 1 + ( + *n1 + 1 << 2) - 5], &c__4); + stgsy2_("N", &c__0, n1, n2, s, &c__4, &s[*n1 + 1 + (*n1 + 1 << 2) - 5] + , &c__4, &ir[*n2 + 1 + (*n1 + 1 << 2) - 5], &c__4, t, &c__4, & + t[*n1 + 1 + (*n1 + 1 << 2) - 5], &c__4, li, &c__4, &scale, & + dsum, &dscale, iwork, &idum, &linfo); + +/* Compute orthogonal matrix QL: */ + +/* QL**T * LI = [ TL ] */ +/* [ 0 ] */ +/* where */ +/* LI = [ -L ] */ +/* [ SCALE * identity(N2) ] */ + + i__1 = *n2; + for (i__ = 1; i__ <= i__1; ++i__) { + sscal_(n1, &c_b48, &li[(i__ << 2) - 4], &c__1); + li[*n1 + i__ + (i__ << 2) - 5] = scale; +/* L10: */ + } + sgeqr2_(&m, n2, li, &c__4, taul, &work[1], &linfo); + if (linfo != 0) { + goto L70; + } + sorg2r_(&m, &m, n2, li, &c__4, taul, &work[1], &linfo); + if (linfo != 0) { + goto L70; + } + +/* Compute orthogonal matrix RQ: */ + +/* IR * RQ**T = [ 0 TR], */ + +/* where IR = [ SCALE * identity(N1), R ] */ + + i__1 = *n1; + for (i__ = 1; i__ <= i__1; ++i__) { + ir[*n2 + i__ + (i__ << 2) - 5] = scale; +/* L20: */ + } + sgerq2_(n1, &m, &ir[*n2], &c__4, taur, &work[1], &linfo); + if (linfo != 0) { + goto L70; + } + sorgr2_(&m, &m, n1, ir, &c__4, taur, &work[1], &linfo); + if (linfo != 0) { + goto L70; + } + +/* Perform the swapping tentatively: */ + + sgemm_("T", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, & + work[1], &m); + sgemm_("N", "T", &m, &m, &m, &c_b42, &work[1], &m, ir, &c__4, &c_b5, + s, &c__4); + sgemm_("T", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, & + work[1], &m); + sgemm_("N", "T", &m, &m, &m, &c_b42, &work[1], &m, ir, &c__4, &c_b5, + t, &c__4); + slacpy_("F", &m, &m, s, &c__4, scpy, &c__4); + slacpy_("F", &m, &m, t, &c__4, tcpy, &c__4); + slacpy_("F", &m, &m, ir, &c__4, ircop, &c__4); + slacpy_("F", &m, &m, li, &c__4, licop, &c__4); + +/* Triangularize the B-part by an RQ factorization. */ +/* Apply transformation (from left) to A-part, giving S. */ + + sgerq2_(&m, &m, t, &c__4, taur, &work[1], &linfo); + if (linfo != 0) { + goto L70; + } + sormr2_("R", "T", &m, &m, &m, t, &c__4, taur, s, &c__4, &work[1], & + linfo); + if (linfo != 0) { + goto L70; + } + sormr2_("L", "N", &m, &m, &m, t, &c__4, taur, ir, &c__4, &work[1], & + linfo); + if (linfo != 0) { + goto L70; + } + +/* Compute F-norm(S21) in BRQA21. (T21 is 0.) */ + + dscale = 0.f; + dsum = 1.f; + i__1 = *n2; + for (i__ = 1; i__ <= i__1; ++i__) { + slassq_(n1, &s[*n2 + 1 + (i__ << 2) - 5], &c__1, &dscale, &dsum); +/* L30: */ + } + brqa21 = dscale * sqrt(dsum); + +/* Triangularize the B-part by a QR factorization. */ +/* Apply transformation (from right) to A-part, giving S. */ + + sgeqr2_(&m, &m, tcpy, &c__4, taul, &work[1], &linfo); + if (linfo != 0) { + goto L70; + } + sorm2r_("L", "T", &m, &m, &m, tcpy, &c__4, taul, scpy, &c__4, &work[1] + , info); + sorm2r_("R", "N", &m, &m, &m, tcpy, &c__4, taul, licop, &c__4, &work[ + 1], info); + if (linfo != 0) { + goto L70; + } + +/* Compute F-norm(S21) in BQRA21. (T21 is 0.) */ + + dscale = 0.f; + dsum = 1.f; + i__1 = *n2; + for (i__ = 1; i__ <= i__1; ++i__) { + slassq_(n1, &scpy[*n2 + 1 + (i__ << 2) - 5], &c__1, &dscale, & + dsum); +/* L40: */ + } + bqra21 = dscale * sqrt(dsum); + +/* Decide which method to use. */ +/* Weak stability test: */ +/* F-norm(S21) <= O(EPS * F-norm((S, T))) */ + + if (bqra21 <= brqa21 && bqra21 <= thresh) { + slacpy_("F", &m, &m, scpy, &c__4, s, &c__4); + slacpy_("F", &m, &m, tcpy, &c__4, t, &c__4); + slacpy_("F", &m, &m, ircop, &c__4, ir, &c__4); + slacpy_("F", &m, &m, licop, &c__4, li, &c__4); + } else if (brqa21 >= thresh) { + goto L70; + } + +/* Set lower triangle of B-part to zero */ + + i__1 = m - 1; + i__2 = m - 1; + slaset_("Lower", &i__1, &i__2, &c_b5, &c_b5, &t[1], &c__4); + + if (TRUE_) { + +/* Strong stability test: */ +/* F-norm((A-QL*S*QR**T, B-QL*T*QR**T)) <= O(EPS*F-norm((A,B))) */ + + slacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, &work[m * m + + 1], &m); + sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, & + work[1], &m); + sgemm_("N", "N", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, & + c_b42, &work[m * m + 1], &m); + dscale = 0.f; + dsum = 1.f; + i__1 = m * m; + slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); + + slacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, &work[m * m + + 1], &m); + sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, & + work[1], &m); + sgemm_("N", "N", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, & + c_b42, &work[m * m + 1], &m); + i__1 = m * m; + slassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); + ss = dscale * sqrt(dsum); + strong = ss <= thresh; + if (! strong) { + goto L70; + } + + } + +/* If the swap is accepted ("weakly" and "strongly"), apply the */ +/* transformations and set N1-by-N2 (2,1)-block to zero. */ + + slaset_("Full", n1, n2, &c_b5, &c_b5, &s[*n2], &c__4); + +/* copy back M-by-M diagonal block starting at index J1 of (A, B) */ + + slacpy_("F", &m, &m, s, &c__4, &a[*j1 + *j1 * a_dim1], lda) + ; + slacpy_("F", &m, &m, t, &c__4, &b[*j1 + *j1 * b_dim1], ldb) + ; + slaset_("Full", &c__4, &c__4, &c_b5, &c_b5, t, &c__4); + +/* Standardize existing 2-by-2 blocks. */ + + slaset_("Full", &m, &m, &c_b5, &c_b5, &work[1], &m); + work[1] = 1.f; + t[0] = 1.f; + idum = *lwork - m * m - 2; + if (*n2 > 1) { + slagv2_(&a[*j1 + *j1 * a_dim1], lda, &b[*j1 + *j1 * b_dim1], ldb, + ar, ai, be, &work[1], &work[2], t, &t[1]); + work[m + 1] = -work[2]; + work[m + 2] = work[1]; + t[*n2 + (*n2 << 2) - 5] = t[0]; + t[4] = -t[1]; + } + work[m * m] = 1.f; + t[m + (m << 2) - 5] = 1.f; + + if (*n1 > 1) { + slagv2_(&a[*j1 + *n2 + (*j1 + *n2) * a_dim1], lda, &b[*j1 + *n2 + + (*j1 + *n2) * b_dim1], ldb, taur, taul, &work[m * m + 1], + &work[*n2 * m + *n2 + 1], &work[*n2 * m + *n2 + 2], &t[* + n2 + 1 + (*n2 + 1 << 2) - 5], &t[m + (m - 1 << 2) - 5]); + work[m * m] = work[*n2 * m + *n2 + 1]; + work[m * m - 1] = -work[*n2 * m + *n2 + 2]; + t[m + (m << 2) - 5] = t[*n2 + 1 + (*n2 + 1 << 2) - 5]; + t[m - 1 + (m << 2) - 5] = -t[m + (m - 1 << 2) - 5]; + } + sgemm_("T", "N", n2, n1, n2, &c_b42, &work[1], &m, &a[*j1 + (*j1 + * + n2) * a_dim1], lda, &c_b5, &work[m * m + 1], n2); + slacpy_("Full", n2, n1, &work[m * m + 1], n2, &a[*j1 + (*j1 + *n2) * + a_dim1], lda); + sgemm_("T", "N", n2, n1, n2, &c_b42, &work[1], &m, &b[*j1 + (*j1 + * + n2) * b_dim1], ldb, &c_b5, &work[m * m + 1], n2); + slacpy_("Full", n2, n1, &work[m * m + 1], n2, &b[*j1 + (*j1 + *n2) * + b_dim1], ldb); + sgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, &work[1], &m, &c_b5, & + work[m * m + 1], &m); + slacpy_("Full", &m, &m, &work[m * m + 1], &m, li, &c__4); + sgemm_("N", "N", n2, n1, n1, &c_b42, &a[*j1 + (*j1 + *n2) * a_dim1], + lda, &t[*n2 + 1 + (*n2 + 1 << 2) - 5], &c__4, &c_b5, &work[1], + n2); + slacpy_("Full", n2, n1, &work[1], n2, &a[*j1 + (*j1 + *n2) * a_dim1], + lda); + sgemm_("N", "N", n2, n1, n1, &c_b42, &b[*j1 + (*j1 + *n2) * b_dim1], + ldb, &t[*n2 + 1 + (*n2 + 1 << 2) - 5], &c__4, &c_b5, &work[1], + n2); + slacpy_("Full", n2, n1, &work[1], n2, &b[*j1 + (*j1 + *n2) * b_dim1], + ldb); + sgemm_("T", "N", &m, &m, &m, &c_b42, ir, &c__4, t, &c__4, &c_b5, & + work[1], &m); + slacpy_("Full", &m, &m, &work[1], &m, ir, &c__4); + +/* Accumulate transformations into Q and Z if requested. */ + + if (*wantq) { + sgemm_("N", "N", n, &m, &m, &c_b42, &q[*j1 * q_dim1 + 1], ldq, li, + &c__4, &c_b5, &work[1], n); + slacpy_("Full", n, &m, &work[1], n, &q[*j1 * q_dim1 + 1], ldq); + + } + + if (*wantz) { + sgemm_("N", "N", n, &m, &m, &c_b42, &z__[*j1 * z_dim1 + 1], ldz, + ir, &c__4, &c_b5, &work[1], n); + slacpy_("Full", n, &m, &work[1], n, &z__[*j1 * z_dim1 + 1], ldz); + + } + +/* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and */ +/* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */ + + i__ = *j1 + m; + if (i__ <= *n) { + i__1 = *n - i__ + 1; + sgemm_("T", "N", &m, &i__1, &m, &c_b42, li, &c__4, &a[*j1 + i__ * + a_dim1], lda, &c_b5, &work[1], &m); + i__1 = *n - i__ + 1; + slacpy_("Full", &m, &i__1, &work[1], &m, &a[*j1 + i__ * a_dim1], + lda); + i__1 = *n - i__ + 1; + sgemm_("T", "N", &m, &i__1, &m, &c_b42, li, &c__4, &b[*j1 + i__ * + b_dim1], ldb, &c_b5, &work[1], &m); + i__1 = *n - i__ + 1; + slacpy_("Full", &m, &i__1, &work[1], &m, &b[*j1 + i__ * b_dim1], + ldb); + } + i__ = *j1 - 1; + if (i__ > 0) { + sgemm_("N", "N", &i__, &m, &m, &c_b42, &a[*j1 * a_dim1 + 1], lda, + ir, &c__4, &c_b5, &work[1], &i__); + slacpy_("Full", &i__, &m, &work[1], &i__, &a[*j1 * a_dim1 + 1], + lda); + sgemm_("N", "N", &i__, &m, &m, &c_b42, &b[*j1 * b_dim1 + 1], ldb, + ir, &c__4, &c_b5, &work[1], &i__); + slacpy_("Full", &i__, &m, &work[1], &i__, &b[*j1 * b_dim1 + 1], + ldb); + } + +/* Exit with INFO = 0 if swap was successfully performed. */ + + return 0; + + } + +/* Exit with INFO = 1 if swap was rejected. */ + +L70: + + *info = 1; + return 0; + +/* End of STGEX2 */ + +} /* stgex2_ */ + diff --git a/lapack-netlib/SRC/stgexc.c b/lapack-netlib/SRC/stgexc.c new file mode 100644 index 000000000..0a37d455a --- /dev/null +++ b/lapack-netlib/SRC/stgexc.c @@ -0,0 +1,979 @@ +/* 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 STGEXC */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STGEXC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, */ +/* LDZ, IFST, ILST, WORK, LWORK, INFO ) */ + +/* LOGICAL WANTQ, WANTZ */ +/* INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, LWORK, N */ +/* REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ), */ +/* $ WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STGEXC reorders the generalized real Schur decomposition of a real */ +/* > matrix pair (A,B) using an orthogonal equivalence transformation */ +/* > */ +/* > (A, B) = Q * (A, B) * Z**T, */ +/* > */ +/* > so that the diagonal block of (A, B) with row index IFST is moved */ +/* > to row ILST. */ +/* > */ +/* > (A, B) must be in generalized real Schur canonical form (as returned */ +/* > by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 */ +/* > diagonal blocks. B is upper triangular. */ +/* > */ +/* > Optionally, the matrices Q and Z of generalized Schur vectors are */ +/* > updated. */ +/* > */ +/* > Q(in) * A(in) * Z(in)**T = Q(out) * A(out) * Z(out)**T */ +/* > Q(in) * B(in) * Z(in)**T = Q(out) * B(out) * Z(out)**T */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] WANTQ */ +/* > \verbatim */ +/* > WANTQ is LOGICAL */ +/* > .TRUE. : update the left transformation matrix Q; */ +/* > .FALSE.: do not update Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTZ */ +/* > \verbatim */ +/* > WANTZ is LOGICAL */ +/* > .TRUE. : update the right transformation matrix Z; */ +/* > .FALSE.: do not update Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the matrix A in generalized real Schur canonical */ +/* > form. */ +/* > On exit, the updated matrix A, again in generalized */ +/* > real Schur canonical form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,N) */ +/* > On entry, the matrix B in generalized real Schur canonical */ +/* > form (A,B). */ +/* > On exit, the updated matrix B, again in generalized */ +/* > real Schur canonical form (A,B). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is REAL array, dimension (LDQ,N) */ +/* > On entry, if WANTQ = .TRUE., the orthogonal matrix Q. */ +/* > On exit, the updated matrix Q. */ +/* > If WANTQ = .FALSE., Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= 1. */ +/* > If WANTQ = .TRUE., LDQ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension (LDZ,N) */ +/* > On entry, if WANTZ = .TRUE., the orthogonal matrix Z. */ +/* > On exit, the updated matrix Z. */ +/* > If WANTZ = .FALSE., Z is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1. */ +/* > If WANTZ = .TRUE., LDZ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] IFST */ +/* > \verbatim */ +/* > IFST is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ILST */ +/* > \verbatim */ +/* > ILST is INTEGER */ +/* > Specify the reordering of the diagonal blocks of (A, B). */ +/* > The block with row index IFST is moved to row ILST, by a */ +/* > sequence of swapping between adjacent blocks. */ +/* > On exit, if IFST pointed on entry to the second row of */ +/* > a 2-by-2 block, it is changed to point to the first row; */ +/* > ILST always points to the first row of the block in its */ +/* > final position (which may differ from its input value by */ +/* > +1 or -1). 1 <= IFST, ILST <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > LWORK >= 1 when N <= 1, otherwise LWORK >= 4*N + 16. */ +/* > */ +/* > 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. */ +/* > =1: The transformed matrix pair (A, B) would be too far */ +/* > from generalized Schur form; the problem is ill- */ +/* > conditioned. (A, B) may have been partially reordered, */ +/* > and ILST points to the first row of the current */ +/* > position of the block being moved. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup realGEcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* > Umea University, S-901 87 Umea, Sweden. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > \verbatim */ +/* > */ +/* > [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */ +/* > Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */ +/* > M.S. Moonen et al (eds), Linear Algebra for Large Scale and */ +/* > Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int stgexc_(logical *wantq, logical *wantz, integer *n, real + *a, integer *lda, real *b, integer *ldb, real *q, integer *ldq, real * + z__, integer *ldz, integer *ifst, integer *ilst, real *work, integer * + lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, + z_offset, i__1; + + /* Local variables */ + integer here, lwmin; + extern /* Subroutine */ int stgex2_(logical *, logical *, integer *, real + *, integer *, real *, integer *, real *, integer *, real *, + integer *, integer *, integer *, integer *, real *, integer *, + integer *), xerbla_(char *, integer *, ftnlen); + integer nbnext; + logical lquery; + integer nbf, nbl; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Decode and test input arguments. */ + + /* 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; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } else if (*ldq < 1 || *wantq && *ldq < f2cmax(1,*n)) { + *info = -9; + } else if (*ldz < 1 || *wantz && *ldz < f2cmax(1,*n)) { + *info = -11; + } else if (*ifst < 1 || *ifst > *n) { + *info = -12; + } else if (*ilst < 1 || *ilst > *n) { + *info = -13; + } + + if (*info == 0) { + if (*n <= 1) { + lwmin = 1; + } else { + lwmin = (*n << 2) + 16; + } + work[1] = (real) lwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -15; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("STGEXC", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n <= 1) { + return 0; + } + +/* Determine the first row of the specified block and find out */ +/* if it is 1-by-1 or 2-by-2. */ + + if (*ifst > 1) { + if (a[*ifst + (*ifst - 1) * a_dim1] != 0.f) { + --(*ifst); + } + } + nbf = 1; + if (*ifst < *n) { + if (a[*ifst + 1 + *ifst * a_dim1] != 0.f) { + nbf = 2; + } + } + +/* Determine the first row of the final block */ +/* and find out if it is 1-by-1 or 2-by-2. */ + + if (*ilst > 1) { + if (a[*ilst + (*ilst - 1) * a_dim1] != 0.f) { + --(*ilst); + } + } + nbl = 1; + if (*ilst < *n) { + if (a[*ilst + 1 + *ilst * a_dim1] != 0.f) { + nbl = 2; + } + } + if (*ifst == *ilst) { + return 0; + } + + if (*ifst < *ilst) { + +/* Update ILST. */ + + if (nbf == 2 && nbl == 1) { + --(*ilst); + } + if (nbf == 1 && nbl == 2) { + ++(*ilst); + } + + here = *ifst; + +L10: + +/* Swap with next one below. */ + + if (nbf == 1 || nbf == 2) { + +/* Current block either 1-by-1 or 2-by-2. */ + + nbnext = 1; + if (here + nbf + 1 <= *n) { + if (a[here + nbf + 1 + (here + nbf) * a_dim1] != 0.f) { + nbnext = 2; + } + } + stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[ + q_offset], ldq, &z__[z_offset], ldz, &here, &nbf, &nbnext, + &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + here += nbnext; + +/* Test if 2-by-2 block breaks into two 1-by-1 blocks. */ + + if (nbf == 2) { + if (a[here + 1 + here * a_dim1] == 0.f) { + nbf = 3; + } + } + + } else { + +/* Current block consists of two 1-by-1 blocks, each of which */ +/* must be swapped individually. */ + + nbnext = 1; + if (here + 3 <= *n) { + if (a[here + 3 + (here + 2) * a_dim1] != 0.f) { + nbnext = 2; + } + } + i__1 = here + 1; + stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[ + q_offset], ldq, &z__[z_offset], ldz, &i__1, &c__1, & + nbnext, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + if (nbnext == 1) { + +/* Swap two 1-by-1 blocks. */ + + stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, + &q[q_offset], ldq, &z__[z_offset], ldz, &here, &c__1, + &c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + ++here; + + } else { + +/* Recompute NBNEXT in case of 2-by-2 split. */ + + if (a[here + 2 + (here + 1) * a_dim1] == 0.f) { + nbnext = 1; + } + if (nbnext == 2) { + +/* 2-by-2 block did not split. */ + + stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], + ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & + here, &c__1, &nbnext, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + here += 2; + } else { + +/* 2-by-2 block did split. */ + + stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], + ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & + here, &c__1, &c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + ++here; + stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], + ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & + here, &c__1, &c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + ++here; + } + + } + } + if (here < *ilst) { + goto L10; + } + } else { + here = *ifst; + +L20: + +/* Swap with next one below. */ + + if (nbf == 1 || nbf == 2) { + +/* Current block either 1-by-1 or 2-by-2. */ + + nbnext = 1; + if (here >= 3) { + if (a[here - 1 + (here - 2) * a_dim1] != 0.f) { + nbnext = 2; + } + } + i__1 = here - nbnext; + stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[ + q_offset], ldq, &z__[z_offset], ldz, &i__1, &nbnext, &nbf, + &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + here -= nbnext; + +/* Test if 2-by-2 block breaks into two 1-by-1 blocks. */ + + if (nbf == 2) { + if (a[here + 1 + here * a_dim1] == 0.f) { + nbf = 3; + } + } + + } else { + +/* Current block consists of two 1-by-1 blocks, each of which */ +/* must be swapped individually. */ + + nbnext = 1; + if (here >= 3) { + if (a[here - 1 + (here - 2) * a_dim1] != 0.f) { + nbnext = 2; + } + } + i__1 = here - nbnext; + stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[ + q_offset], ldq, &z__[z_offset], ldz, &i__1, &nbnext, & + c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + if (nbnext == 1) { + +/* Swap two 1-by-1 blocks. */ + + stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, + &q[q_offset], ldq, &z__[z_offset], ldz, &here, & + nbnext, &c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + --here; + } else { + +/* Recompute NBNEXT in case of 2-by-2 split. */ + + if (a[here + (here - 1) * a_dim1] == 0.f) { + nbnext = 1; + } + if (nbnext == 2) { + +/* 2-by-2 block did not split. */ + + i__1 = here - 1; + stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], + ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & + i__1, &c__2, &c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + here += -2; + } else { + +/* 2-by-2 block did split. */ + + stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], + ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & + here, &c__1, &c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + --here; + stgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], + ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & + here, &c__1, &c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + --here; + } + } + } + if (here > *ilst) { + goto L20; + } + } + *ilst = here; + work[1] = (real) lwmin; + return 0; + +/* End of STGEXC */ + +} /* stgexc_ */ + diff --git a/lapack-netlib/SRC/stgsen.c b/lapack-netlib/SRC/stgsen.c new file mode 100644 index 000000000..c1d526b7b --- /dev/null +++ b/lapack-netlib/SRC/stgsen.c @@ -0,0 +1,1332 @@ +/* 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 STGSEN */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STGSEN + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, */ +/* ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, */ +/* PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO ) */ + +/* LOGICAL WANTQ, WANTZ */ +/* INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK, */ +/* $ M, N */ +/* REAL PL, PR */ +/* LOGICAL SELECT( * ) */ +/* INTEGER IWORK( * ) */ +/* REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ), */ +/* $ B( LDB, * ), BETA( * ), DIF( * ), Q( LDQ, * ), */ +/* $ WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STGSEN reorders the generalized real Schur decomposition of a real */ +/* > matrix pair (A, B) (in terms of an orthonormal equivalence trans- */ +/* > formation Q**T * (A, B) * Z), so that a selected cluster of eigenvalues */ +/* > appears in the leading diagonal blocks of the upper quasi-triangular */ +/* > matrix A and the upper triangular B. The leading columns of Q and */ +/* > Z form orthonormal bases of the corresponding left and right eigen- */ +/* > spaces (deflating subspaces). (A, B) must be in generalized real */ +/* > Schur canonical form (as returned by SGGES), i.e. A is block upper */ +/* > triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper */ +/* > triangular. */ +/* > */ +/* > STGSEN also computes the generalized eigenvalues */ +/* > */ +/* > w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j) */ +/* > */ +/* > of the reordered matrix pair (A, B). */ +/* > */ +/* > Optionally, STGSEN computes the estimates of reciprocal condition */ +/* > numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), */ +/* > (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) */ +/* > between the matrix pairs (A11, B11) and (A22,B22) that correspond to */ +/* > the selected cluster and the eigenvalues outside the cluster, resp., */ +/* > and norms of "projections" onto left and right eigenspaces w.r.t. */ +/* > the selected cluster in the (1,1)-block. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] IJOB */ +/* > \verbatim */ +/* > IJOB is INTEGER */ +/* > Specifies whether condition numbers are required for the */ +/* > cluster of eigenvalues (PL and PR) or the deflating subspaces */ +/* > (Difu and Difl): */ +/* > =0: Only reorder w.r.t. SELECT. No extras. */ +/* > =1: Reciprocal of norms of "projections" onto left and right */ +/* > eigenspaces w.r.t. the selected cluster (PL and PR). */ +/* > =2: Upper bounds on Difu and Difl. F-norm-based estimate */ +/* > (DIF(1:2)). */ +/* > =3: Estimate of Difu and Difl. 1-norm-based estimate */ +/* > (DIF(1:2)). */ +/* > About 5 times as expensive as IJOB = 2. */ +/* > =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic */ +/* > version to get it all. */ +/* > =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTQ */ +/* > \verbatim */ +/* > WANTQ is LOGICAL */ +/* > .TRUE. : update the left transformation matrix Q; */ +/* > .FALSE.: do not update Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTZ */ +/* > \verbatim */ +/* > WANTZ is LOGICAL */ +/* > .TRUE. : update the right transformation matrix Z; */ +/* > .FALSE.: do not update Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > SELECT specifies the eigenvalues in the selected cluster. */ +/* > To select a real eigenvalue w(j), SELECT(j) must be set to */ +/* > .TRUE.. To select a complex conjugate pair of eigenvalues */ +/* > w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, */ +/* > either SELECT(j) or SELECT(j+1) or both must be set to */ +/* > .TRUE.; a complex conjugate pair of eigenvalues must be */ +/* > either both included in the cluster or both excluded. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension(LDA,N) */ +/* > On entry, the upper quasi-triangular matrix A, with (A, B) in */ +/* > generalized real Schur canonical form. */ +/* > On exit, A is overwritten by the reordered matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension(LDB,N) */ +/* > On entry, the upper triangular matrix B, with (A, B) in */ +/* > generalized real Schur canonical form. */ +/* > On exit, B is overwritten by the reordered matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAR */ +/* > \verbatim */ +/* > ALPHAR is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAI */ +/* > \verbatim */ +/* > ALPHAI is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is REAL array, dimension (N) */ +/* > */ +/* > On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */ +/* > be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i */ +/* > and BETA(j),j=1,...,N are the diagonals of the complex Schur */ +/* > form (S,T) that would result if the 2-by-2 diagonal blocks of */ +/* > the real generalized Schur form of (A,B) were further reduced */ +/* > to triangular form using complex unitary transformations. */ +/* > If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */ +/* > positive, then the j-th and (j+1)-st eigenvalues are a */ +/* > complex conjugate pair, with ALPHAI(j+1) negative. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is REAL array, dimension (LDQ,N) */ +/* > On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. */ +/* > On exit, Q has been postmultiplied by the left orthogonal */ +/* > transformation matrix which reorder (A, B); The leading M */ +/* > columns of Q form orthonormal bases for the specified pair of */ +/* > left eigenspaces (deflating subspaces). */ +/* > If WANTQ = .FALSE., Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= 1; */ +/* > and if WANTQ = .TRUE., LDQ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension (LDZ,N) */ +/* > On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. */ +/* > On exit, Z has been postmultiplied by the left orthogonal */ +/* > transformation matrix which reorder (A, B); The leading M */ +/* > columns of Z form orthonormal bases for the specified pair of */ +/* > left eigenspaces (deflating subspaces). */ +/* > If WANTZ = .FALSE., Z is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1; */ +/* > If WANTZ = .TRUE., LDZ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The dimension of the specified pair of left and right eigen- */ +/* > spaces (deflating subspaces). 0 <= M <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PL */ +/* > \verbatim */ +/* > PL is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PR */ +/* > \verbatim */ +/* > PR is REAL */ +/* > */ +/* > If IJOB = 1, 4 or 5, PL, PR are lower bounds on the */ +/* > reciprocal of the norm of "projections" onto left and right */ +/* > eigenspaces with respect to the selected cluster. */ +/* > 0 < PL, PR <= 1. */ +/* > If M = 0 or M = N, PL = PR = 1. */ +/* > If IJOB = 0, 2 or 3, PL and PR are not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DIF */ +/* > \verbatim */ +/* > DIF is REAL array, dimension (2). */ +/* > If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. */ +/* > If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on */ +/* > Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based */ +/* > estimates of Difu and Difl. */ +/* > If M = 0 or N, DIF(1:2) = F-norm([A, B]). */ +/* > If IJOB = 0 or 1, DIF is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= 4*N+16. */ +/* > If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)). */ +/* > If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-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] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */ +/* > On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the array IWORK. LIWORK >= 1. */ +/* > If IJOB = 1, 2 or 4, LIWORK >= N+6. */ +/* > If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6). */ +/* > */ +/* > If LIWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal size of the IWORK array, */ +/* > returns this value as the first entry of the IWORK array, and */ +/* > no error message related to LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > =0: Successful exit. */ +/* > <0: If INFO = -i, the i-th argument had an illegal value. */ +/* > =1: Reordering of (A, B) failed because the transformed */ +/* > matrix pair (A, B) would be too far from generalized */ +/* > Schur form; the problem is very ill-conditioned. */ +/* > (A, B) may have been partially reordered. */ +/* > If requested, 0 is returned in DIF(*), PL and PR. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STGSEN first collects the selected eigenvalues by computing */ +/* > orthogonal U and W that move them to the top left corner of (A, B). */ +/* > In other words, the selected eigenvalues are the eigenvalues of */ +/* > (A11, B11) in: */ +/* > */ +/* > U**T*(A, B)*W = (A11 A12) (B11 B12) n1 */ +/* > ( 0 A22),( 0 B22) n2 */ +/* > n1 n2 n1 n2 */ +/* > */ +/* > where N = n1+n2 and U**T means the transpose of U. The first n1 columns */ +/* > of U and W span the specified pair of left and right eigenspaces */ +/* > (deflating subspaces) of (A, B). */ +/* > */ +/* > If (A, B) has been obtained from the generalized real Schur */ +/* > decomposition of a matrix pair (C, D) = Q*(A, B)*Z**T, then the */ +/* > reordered generalized real Schur form of (C, D) is given by */ +/* > */ +/* > (C, D) = (Q*U)*(U**T*(A, B)*W)*(Z*W)**T, */ +/* > */ +/* > and the first n1 columns of Q*U and Z*W span the corresponding */ +/* > deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). */ +/* > */ +/* > Note that if the selected eigenvalue is sufficiently ill-conditioned, */ +/* > then its value may differ significantly from its value before */ +/* > reordering. */ +/* > */ +/* > The reciprocal condition numbers of the left and right eigenspaces */ +/* > spanned by the first n1 columns of U and W (or Q*U and Z*W) may */ +/* > be returned in DIF(1:2), corresponding to Difu and Difl, resp. */ +/* > */ +/* > The Difu and Difl are defined as: */ +/* > */ +/* > Difu[(A11, B11), (A22, B22)] = sigma-f2cmin( Zu ) */ +/* > and */ +/* > Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], */ +/* > */ +/* > where sigma-f2cmin(Zu) is the smallest singular value of the */ +/* > (2*n1*n2)-by-(2*n1*n2) matrix */ +/* > */ +/* > Zu = [ kron(In2, A11) -kron(A22**T, In1) ] */ +/* > [ kron(In2, B11) -kron(B22**T, In1) ]. */ +/* > */ +/* > Here, Inx is the identity matrix of size nx and A22**T is the */ +/* > transpose of A22. kron(X, Y) is the Kronecker product between */ +/* > the matrices X and Y. */ +/* > */ +/* > When DIF(2) is small, small changes in (A, B) can cause large changes */ +/* > in the deflating subspace. An approximate (asymptotic) bound on the */ +/* > maximum angular error in the computed deflating subspaces is */ +/* > */ +/* > EPS * norm((A, B)) / DIF(2), */ +/* > */ +/* > where EPS is the machine precision. */ +/* > */ +/* > The reciprocal norm of the projectors on the left and right */ +/* > eigenspaces associated with (A11, B11) may be returned in PL and PR. */ +/* > They are computed as follows. First we compute L and R so that */ +/* > P*(A, B)*Q is block diagonal, where */ +/* > */ +/* > P = ( I -L ) n1 Q = ( I R ) n1 */ +/* > ( 0 I ) n2 and ( 0 I ) n2 */ +/* > n1 n2 n1 n2 */ +/* > */ +/* > and (L, R) is the solution to the generalized Sylvester equation */ +/* > */ +/* > A11*R - L*A22 = -A12 */ +/* > B11*R - L*B22 = -B12 */ +/* > */ +/* > Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). */ +/* > An approximate (asymptotic) bound on the average absolute error of */ +/* > the selected eigenvalues is */ +/* > */ +/* > EPS * norm((A, B)) / PL. */ +/* > */ +/* > There are also global error bounds which valid for perturbations up */ +/* > to a certain restriction: A lower bound (x) on the smallest */ +/* > F-norm(E,F) for which an eigenvalue of (A11, B11) may move and */ +/* > coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), */ +/* > (i.e. (A + E, B + F), is */ +/* > */ +/* > x = f2cmin(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*f2cmax(1/PL,1/PR)). */ +/* > */ +/* > An approximate bound on x can be computed from DIF(1:2), PL and PR. */ +/* > */ +/* > If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed */ +/* > (L', R') and unperturbed (L, R) left and right deflating subspaces */ +/* > associated with the selected cluster in the (1,1)-blocks can be */ +/* > bounded as */ +/* > */ +/* > f2cmax-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) */ +/* > f2cmax-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) */ +/* > */ +/* > See LAPACK User's Guide section 4.11 or the following references */ +/* > for more information. */ +/* > */ +/* > Note that if the default method for computing the Frobenius-norm- */ +/* > based estimate DIF is not wanted (see SLATDF), then the parameter */ +/* > IDIFJB (see below) should be changed from 3 to 4 (routine SLATDF */ +/* > (IJOB = 2 will be used)). See STGSYL for more details. */ +/* > \endverbatim */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* > Umea University, S-901 87 Umea, Sweden. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > \verbatim */ +/* > */ +/* > [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */ +/* > Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */ +/* > M.S. Moonen et al (eds), Linear Algebra for Large Scale and */ +/* > Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */ +/* > */ +/* > [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */ +/* > Eigenvalues of a Regular Matrix Pair (A, B) and Condition */ +/* > Estimation: Theory, Algorithms and Software, */ +/* > Report UMINF - 94.04, Department of Computing Science, Umea */ +/* > University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */ +/* > Note 87. To appear in Numerical Algorithms, 1996. */ +/* > */ +/* > [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */ +/* > for Solving the Generalized Sylvester Equation and Estimating the */ +/* > Separation between Regular Matrix Pairs, Report UMINF - 93.23, */ +/* > Department of Computing Science, Umea University, S-901 87 Umea, */ +/* > Sweden, December 1993, Revised April 1994, Also as LAPACK Working */ +/* > Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, */ +/* > 1996. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int stgsen_(integer *ijob, logical *wantq, logical *wantz, + logical *select, integer *n, real *a, integer *lda, real *b, integer * + ldb, real *alphar, real *alphai, real *beta, real *q, integer *ldq, + real *z__, integer *ldz, integer *m, real *pl, real *pr, real *dif, + real *work, integer *lwork, integer *iwork, integer *liwork, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, + z_offset, i__1, i__2; + real r__1; + + /* Local variables */ + integer kase; + logical pair; + integer ierr; + real dsum; + logical swap; + extern /* Subroutine */ int slag2_(real *, integer *, real *, integer *, + real *, real *, real *, real *, real *, real *); + integer i__, k, isave[3]; + logical wantd; + integer lwmin; + logical wantp; + integer n1, n2; + extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *, + real *, integer *, integer *); + logical wantd1, wantd2; + integer kk; + real dscale; + integer ks; + real rdscal; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slacpy_( + char *, integer *, integer *, real *, integer *, real *, integer * + ), stgexc_(logical *, logical *, integer *, real *, + integer *, real *, integer *, real *, integer *, real *, integer * + , integer *, integer *, real *, integer *, integer *); + integer liwmin; + extern /* Subroutine */ int slassq_(integer *, real *, integer *, real *, + real *); + real smlnum; + integer mn2; + logical lquery; + extern /* Subroutine */ int stgsyl_(char *, integer *, integer *, integer + *, real *, integer *, real *, integer *, real *, integer *, real * + , integer *, real *, integer *, real *, integer *, real *, real *, + real *, integer *, integer *, integer *); + integer ijb; + real eps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + --select; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alphar; + --alphai; + --beta; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --dif; + --work; + --iwork; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1 || *liwork == -1; + + if (*ijob < 0 || *ijob > 5) { + *info = -1; + } else if (*n < 0) { + *info = -5; + } else if (*lda < f2cmax(1,*n)) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } else if (*ldq < 1 || *wantq && *ldq < *n) { + *info = -14; + } else if (*ldz < 1 || *wantz && *ldz < *n) { + *info = -16; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("STGSEN", &i__1, (ftnlen)6); + return 0; + } + +/* Get machine constants */ + + eps = slamch_("P"); + smlnum = slamch_("S") / eps; + ierr = 0; + + wantp = *ijob == 1 || *ijob >= 4; + wantd1 = *ijob == 2 || *ijob == 4; + wantd2 = *ijob == 3 || *ijob == 5; + wantd = wantd1 || wantd2; + +/* Set M to the dimension of the specified pair of deflating */ +/* subspaces. */ + + *m = 0; + pair = FALSE_; + if (! lquery || *ijob != 0) { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = FALSE_; + } else { + if (k < *n) { + if (a[k + 1 + k * a_dim1] == 0.f) { + if (select[k]) { + ++(*m); + } + } else { + pair = TRUE_; + if (select[k] || select[k + 1]) { + *m += 2; + } + } + } else { + if (select[*n]) { + ++(*m); + } + } + } +/* L10: */ + } + } + + if (*ijob == 1 || *ijob == 2 || *ijob == 4) { +/* Computing MAX */ + i__1 = 1, i__2 = (*n << 2) + 16, i__1 = f2cmax(i__1,i__2), i__2 = (*m << + 1) * (*n - *m); + lwmin = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = 1, i__2 = *n + 6; + liwmin = f2cmax(i__1,i__2); + } else if (*ijob == 3 || *ijob == 5) { +/* Computing MAX */ + i__1 = 1, i__2 = (*n << 2) + 16, i__1 = f2cmax(i__1,i__2), i__2 = (*m << + 2) * (*n - *m); + lwmin = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = 1, i__2 = (*m << 1) * (*n - *m), i__1 = f2cmax(i__1,i__2), i__2 = + *n + 6; + liwmin = f2cmax(i__1,i__2); + } else { +/* Computing MAX */ + i__1 = 1, i__2 = (*n << 2) + 16; + lwmin = f2cmax(i__1,i__2); + liwmin = 1; + } + + work[1] = (real) lwmin; + iwork[1] = liwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -22; + } else if (*liwork < liwmin && ! lquery) { + *info = -24; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("STGSEN", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible. */ + + if (*m == *n || *m == 0) { + if (wantp) { + *pl = 1.f; + *pr = 1.f; + } + if (wantd) { + dscale = 0.f; + dsum = 1.f; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + slassq_(n, &a[i__ * a_dim1 + 1], &c__1, &dscale, &dsum); + slassq_(n, &b[i__ * b_dim1 + 1], &c__1, &dscale, &dsum); +/* L20: */ + } + dif[1] = dscale * sqrt(dsum); + dif[2] = dif[1]; + } + goto L60; + } + +/* Collect the selected blocks at the top-left corner of (A, B). */ + + ks = 0; + pair = FALSE_; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = FALSE_; + } else { + + swap = select[k]; + if (k < *n) { + if (a[k + 1 + k * a_dim1] != 0.f) { + pair = TRUE_; + swap = swap || select[k + 1]; + } + } + + if (swap) { + ++ks; + +/* Swap the K-th block to position KS. */ +/* Perform the reordering of diagonal blocks in (A, B) */ +/* by orthogonal transformation matrices and update */ +/* Q and Z accordingly (if requested): */ + + kk = k; + if (k != ks) { + stgexc_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], + ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &kk, + &ks, &work[1], lwork, &ierr); + } + + if (ierr > 0) { + +/* Swap is rejected: exit. */ + + *info = 1; + if (wantp) { + *pl = 0.f; + *pr = 0.f; + } + if (wantd) { + dif[1] = 0.f; + dif[2] = 0.f; + } + goto L60; + } + + if (pair) { + ++ks; + } + } + } +/* L30: */ + } + if (wantp) { + +/* Solve generalized Sylvester equation for R and L */ +/* and compute PL and PR. */ + + n1 = *m; + n2 = *n - *m; + i__ = n1 + 1; + ijb = 0; + slacpy_("Full", &n1, &n2, &a[i__ * a_dim1 + 1], lda, &work[1], &n1); + slacpy_("Full", &n1, &n2, &b[i__ * b_dim1 + 1], ldb, &work[n1 * n2 + + 1], &n1); + i__1 = *lwork - (n1 << 1) * n2; + stgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ * a_dim1] + , lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ + i__ * + b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &dif[1], & + work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr); + +/* Estimate the reciprocal of norms of "projections" onto left */ +/* and right eigenspaces. */ + + rdscal = 0.f; + dsum = 1.f; + i__1 = n1 * n2; + slassq_(&i__1, &work[1], &c__1, &rdscal, &dsum); + *pl = rdscal * sqrt(dsum); + if (*pl == 0.f) { + *pl = 1.f; + } else { + *pl = dscale / (sqrt(dscale * dscale / *pl + *pl) * sqrt(*pl)); + } + rdscal = 0.f; + dsum = 1.f; + i__1 = n1 * n2; + slassq_(&i__1, &work[n1 * n2 + 1], &c__1, &rdscal, &dsum); + *pr = rdscal * sqrt(dsum); + if (*pr == 0.f) { + *pr = 1.f; + } else { + *pr = dscale / (sqrt(dscale * dscale / *pr + *pr) * sqrt(*pr)); + } + } + + if (wantd) { + +/* Compute estimates of Difu and Difl. */ + + if (wantd1) { + n1 = *m; + n2 = *n - *m; + i__ = n1 + 1; + ijb = 3; + +/* Frobenius norm-based Difu-estimate. */ + + i__1 = *lwork - (n1 << 1) * n2; + stgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ * + a_dim1], lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ + + i__ * b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, & + dif[1], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], & + ierr); + +/* Frobenius norm-based Difl-estimate. */ + + i__1 = *lwork - (n1 << 1) * n2; + stgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, &a[ + a_offset], lda, &work[1], &n2, &b[i__ + i__ * b_dim1], + ldb, &b[b_offset], ldb, &work[n1 * n2 + 1], &n2, &dscale, + &dif[2], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], & + ierr); + } else { + + +/* Compute 1-norm-based estimates of Difu and Difl using */ +/* reversed communication with SLACN2. In each step a */ +/* generalized Sylvester equation or a transposed variant */ +/* is solved. */ + + kase = 0; + n1 = *m; + n2 = *n - *m; + i__ = n1 + 1; + ijb = 0; + mn2 = (n1 << 1) * n2; + +/* 1-norm-based estimate of Difu. */ + +L40: + slacn2_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[1], &kase, + isave); + if (kase != 0) { + if (kase == 1) { + +/* Solve generalized Sylvester equation. */ + + i__1 = *lwork - (n1 << 1) * n2; + stgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + + i__ * a_dim1], lda, &work[1], &n1, &b[b_offset], + ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 + + 1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 + + 1], &i__1, &iwork[1], &ierr); + } else { + +/* Solve the transposed variant. */ + + i__1 = *lwork - (n1 << 1) * n2; + stgsyl_("T", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + + i__ * a_dim1], lda, &work[1], &n1, &b[b_offset], + ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 + + 1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 + + 1], &i__1, &iwork[1], &ierr); + } + goto L40; + } + dif[1] = dscale / dif[1]; + +/* 1-norm-based estimate of Difl. */ + +L50: + slacn2_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[2], &kase, + isave); + if (kase != 0) { + if (kase == 1) { + +/* Solve generalized Sylvester equation. */ + + i__1 = *lwork - (n1 << 1) * n2; + stgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, + &a[a_offset], lda, &work[1], &n2, &b[i__ + i__ * + b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 + + 1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 + + 1], &i__1, &iwork[1], &ierr); + } else { + +/* Solve the transposed variant. */ + + i__1 = *lwork - (n1 << 1) * n2; + stgsyl_("T", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, + &a[a_offset], lda, &work[1], &n2, &b[i__ + i__ * + b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 + + 1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 + + 1], &i__1, &iwork[1], &ierr); + } + goto L50; + } + dif[2] = dscale / dif[2]; + + } + } + +L60: + +/* Compute generalized eigenvalues of reordered pair (A, B) and */ +/* normalize the generalized Schur form. */ + + pair = FALSE_; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = FALSE_; + } else { + + if (k < *n) { + if (a[k + 1 + k * a_dim1] != 0.f) { + pair = TRUE_; + } + } + + if (pair) { + +/* Compute the eigenvalue(s) at position K. */ + + work[1] = a[k + k * a_dim1]; + work[2] = a[k + 1 + k * a_dim1]; + work[3] = a[k + (k + 1) * a_dim1]; + work[4] = a[k + 1 + (k + 1) * a_dim1]; + work[5] = b[k + k * b_dim1]; + work[6] = b[k + 1 + k * b_dim1]; + work[7] = b[k + (k + 1) * b_dim1]; + work[8] = b[k + 1 + (k + 1) * b_dim1]; + r__1 = smlnum * eps; + slag2_(&work[1], &c__2, &work[5], &c__2, &r__1, &beta[k], & + beta[k + 1], &alphar[k], &alphar[k + 1], &alphai[k]); + alphai[k + 1] = -alphai[k]; + + } else { + + if (r_sign(&c_b28, &b[k + k * b_dim1]) < 0.f) { + +/* If B(K,K) is negative, make it positive */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + a[k + i__ * a_dim1] = -a[k + i__ * a_dim1]; + b[k + i__ * b_dim1] = -b[k + i__ * b_dim1]; + if (*wantq) { + q[i__ + k * q_dim1] = -q[i__ + k * q_dim1]; + } +/* L80: */ + } + } + + alphar[k] = a[k + k * a_dim1]; + alphai[k] = 0.f; + beta[k] = b[k + k * b_dim1]; + + } + } +/* L70: */ + } + + work[1] = (real) lwmin; + iwork[1] = liwmin; + + return 0; + +/* End of STGSEN */ + +} /* stgsen_ */ + diff --git a/lapack-netlib/SRC/stgsja.c b/lapack-netlib/SRC/stgsja.c new file mode 100644 index 000000000..479ecc7b7 --- /dev/null +++ b/lapack-netlib/SRC/stgsja.c @@ -0,0 +1,1122 @@ +/* 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 STGSJA */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STGSJA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, */ +/* LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, */ +/* Q, LDQ, WORK, NCALL MYCYCLE, INFO ) */ + +/* CHARACTER JOBQ, JOBU, JOBV */ +/* INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, */ +/* $ NCALL MYCYCLE, P */ +/* REAL TOLA, TOLB */ +/* REAL A( LDA, * ), ALPHA( * ), B( LDB, * ), */ +/* $ BETA( * ), Q( LDQ, * ), U( LDU, * ), */ +/* $ V( LDV, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STGSJA computes the generalized singular value decomposition (GSVD) */ +/* > of two real upper triangular (or trapezoidal) matrices A and B. */ +/* > */ +/* > On entry, it is assumed that matrices A and B have the following */ +/* > forms, which may be obtained by the preprocessing subroutine SGGSVP */ +/* > from a general M-by-N matrix A and P-by-N matrix B: */ +/* > */ +/* > N-K-L K L */ +/* > A = K ( 0 A12 A13 ) if M-K-L >= 0; */ +/* > L ( 0 0 A23 ) */ +/* > M-K-L ( 0 0 0 ) */ +/* > */ +/* > N-K-L K L */ +/* > A = K ( 0 A12 A13 ) if M-K-L < 0; */ +/* > M-K ( 0 0 A23 ) */ +/* > */ +/* > N-K-L K L */ +/* > B = L ( 0 0 B13 ) */ +/* > P-L ( 0 0 0 ) */ +/* > */ +/* > where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */ +/* > upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */ +/* > otherwise A23 is (M-K)-by-L upper trapezoidal. */ +/* > */ +/* > On exit, */ +/* > */ +/* > U**T *A*Q = D1*( 0 R ), V**T *B*Q = D2*( 0 R ), */ +/* > */ +/* > where U, V and Q are orthogonal matrices. */ +/* > R is a nonsingular upper triangular matrix, and D1 and D2 are */ +/* > ``diagonal'' matrices, which are of the following structures: */ +/* > */ +/* > If M-K-L >= 0, */ +/* > */ +/* > K L */ +/* > D1 = K ( I 0 ) */ +/* > L ( 0 C ) */ +/* > M-K-L ( 0 0 ) */ +/* > */ +/* > K L */ +/* > D2 = L ( 0 S ) */ +/* > P-L ( 0 0 ) */ +/* > */ +/* > N-K-L K L */ +/* > ( 0 R ) = K ( 0 R11 R12 ) K */ +/* > L ( 0 0 R22 ) L */ +/* > */ +/* > where */ +/* > */ +/* > C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */ +/* > S = diag( BETA(K+1), ... , BETA(K+L) ), */ +/* > C**2 + S**2 = I. */ +/* > */ +/* > R is stored in A(1:K+L,N-K-L+1:N) on exit. */ +/* > */ +/* > If M-K-L < 0, */ +/* > */ +/* > K M-K K+L-M */ +/* > D1 = K ( I 0 0 ) */ +/* > M-K ( 0 C 0 ) */ +/* > */ +/* > K M-K K+L-M */ +/* > D2 = M-K ( 0 S 0 ) */ +/* > K+L-M ( 0 0 I ) */ +/* > P-L ( 0 0 0 ) */ +/* > */ +/* > N-K-L K M-K K+L-M */ +/* > ( 0 R ) = K ( 0 R11 R12 R13 ) */ +/* > M-K ( 0 0 R22 R23 ) */ +/* > K+L-M ( 0 0 0 R33 ) */ +/* > */ +/* > where */ +/* > C = diag( ALPHA(K+1), ... , ALPHA(M) ), */ +/* > S = diag( BETA(K+1), ... , BETA(M) ), */ +/* > C**2 + S**2 = I. */ +/* > */ +/* > R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored */ +/* > ( 0 R22 R23 ) */ +/* > in B(M-K+1:L,N+M-K-L+1:N) on exit. */ +/* > */ +/* > The computation of the orthogonal transformation matrices U, V or Q */ +/* > is optional. These matrices may either be formed explicitly, or they */ +/* > may be postmultiplied into input matrices U1, V1, or Q1. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBU */ +/* > \verbatim */ +/* > JOBU is CHARACTER*1 */ +/* > = 'U': U must contain an orthogonal matrix U1 on entry, and */ +/* > the product U1*U is returned; */ +/* > = 'I': U is initialized to the unit matrix, and the */ +/* > orthogonal matrix U is returned; */ +/* > = 'N': U is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBV */ +/* > \verbatim */ +/* > JOBV is CHARACTER*1 */ +/* > = 'V': V must contain an orthogonal matrix V1 on entry, and */ +/* > the product V1*V is returned; */ +/* > = 'I': V is initialized to the unit matrix, and the */ +/* > orthogonal matrix V is returned; */ +/* > = 'N': V is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBQ */ +/* > \verbatim */ +/* > JOBQ is CHARACTER*1 */ +/* > = 'Q': Q must contain an orthogonal matrix Q1 on entry, and */ +/* > the product Q1*Q is returned; */ +/* > = 'I': Q is initialized to the unit matrix, and the */ +/* > orthogonal matrix Q is returned; */ +/* > = 'N': Q is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows of the matrix B. P >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > */ +/* > K and L specify the subblocks in the input matrices A and B: */ +/* > A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N) */ +/* > of A and B, whose GSVD is going to be computed by STGSJA. */ +/* > See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular */ +/* > matrix R or part of R. See Purpose for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,N) */ +/* > On entry, the P-by-N matrix B. */ +/* > On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains */ +/* > a part of R. See Purpose for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,P). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOLA */ +/* > \verbatim */ +/* > TOLA is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOLB */ +/* > \verbatim */ +/* > TOLB is REAL */ +/* > */ +/* > TOLA and TOLB are the convergence criteria for the Jacobi- */ +/* > Kogbetliantz iteration procedure. Generally, they are the */ +/* > same as used in the preprocessing step, say */ +/* > TOLA = f2cmax(M,N)*norm(A)*MACHEPS, */ +/* > TOLB = f2cmax(P,N)*norm(B)*MACHEPS. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHA */ +/* > \verbatim */ +/* > ALPHA is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is REAL array, dimension (N) */ +/* > */ +/* > On exit, ALPHA and BETA contain the generalized singular */ +/* > value pairs of A and B; */ +/* > ALPHA(1:K) = 1, */ +/* > BETA(1:K) = 0, */ +/* > and if M-K-L >= 0, */ +/* > ALPHA(K+1:K+L) = diag(C), */ +/* > BETA(K+1:K+L) = diag(S), */ +/* > or if M-K-L < 0, */ +/* > ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0 */ +/* > BETA(K+1:M) = S, BETA(M+1:K+L) = 1. */ +/* > Furthermore, if K+L < N, */ +/* > ALPHA(K+L+1:N) = 0 and */ +/* > BETA(K+L+1:N) = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] U */ +/* > \verbatim */ +/* > U is REAL array, dimension (LDU,M) */ +/* > On entry, if JOBU = 'U', U must contain a matrix U1 (usually */ +/* > the orthogonal matrix returned by SGGSVP). */ +/* > On exit, */ +/* > if JOBU = 'I', U contains the orthogonal matrix U; */ +/* > if JOBU = 'U', U contains the product U1*U. */ +/* > If JOBU = 'N', U is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > The leading dimension of the array U. LDU >= f2cmax(1,M) if */ +/* > JOBU = 'U'; LDU >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] V */ +/* > \verbatim */ +/* > V is REAL array, dimension (LDV,P) */ +/* > On entry, if JOBV = 'V', V must contain a matrix V1 (usually */ +/* > the orthogonal matrix returned by SGGSVP). */ +/* > On exit, */ +/* > if JOBV = 'I', V contains the orthogonal matrix V; */ +/* > if JOBV = 'V', V contains the product V1*V. */ +/* > If JOBV = 'N', V is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. LDV >= f2cmax(1,P) if */ +/* > JOBV = 'V'; LDV >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is REAL array, dimension (LDQ,N) */ +/* > On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually */ +/* > the orthogonal matrix returned by SGGSVP). */ +/* > On exit, */ +/* > if JOBQ = 'I', Q contains the orthogonal matrix Q; */ +/* > if JOBQ = 'Q', Q contains the product Q1*Q. */ +/* > If JOBQ = 'N', Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax(1,N) if */ +/* > JOBQ = 'Q'; LDQ >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] NCALL MYCYCLE */ +/* > \verbatim */ +/* > NCALL MYCYCLE is INTEGER */ +/* > The number of cycles required for convergence. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > = 1: the procedure does not converge after MAXIT cycles. */ +/* > \endverbatim */ +/* > */ +/* > \verbatim */ +/* > Internal Parameters */ +/* > =================== */ +/* > */ +/* > MAXIT INTEGER */ +/* > MAXIT specifies the total loops that the iterative procedure */ +/* > may take. If after MAXIT cycles, the routine fails to */ +/* > converge, we return INFO = 1. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STGSJA essentially uses a variant of Kogbetliantz algorithm to reduce */ +/* > f2cmin(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L */ +/* > matrix B13 to the form: */ +/* > */ +/* > U1**T *A13*Q1 = C1*R1; V1**T *B13*Q1 = S1*R1, */ +/* > */ +/* > where U1, V1 and Q1 are orthogonal matrix, and Z**T is the transpose */ +/* > of Z. C1 and S1 are diagonal matrices satisfying */ +/* > */ +/* > C1**2 + S1**2 = I, */ +/* > */ +/* > and R1 is an L-by-L nonsingular upper triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int stgsja_(char *jobu, char *jobv, char *jobq, integer *m, + integer *p, integer *n, integer *k, integer *l, real *a, integer *lda, + real *b, integer *ldb, real *tola, real *tolb, real *alpha, real * + beta, real *u, integer *ldu, real *v, integer *ldv, real *q, integer * + ldq, real *work, integer *ncallmycycle, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, + u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4; + real r__1; + + /* Local variables */ + extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, + integer *, real *, real *); + integer kcallmycycle, i__, j; + real gamma; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + real a1; + logical initq; + real a2, a3, b1; + logical initu, initv, wantq, upper; + real b2, b3; + logical wantu, wantv; + real error, ssmin; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *), slags2_(logical *, real *, real *, real *, real *, + real *, real *, real *, real *, real *, real *, real *, real *), + xerbla_(char *, integer *, ftnlen), slapll_(integer *, real *, + integer *, real *, integer *, real *), slartg_(real *, real *, + real *, real *, real *), slaset_(char *, integer *, integer *, + real *, real *, real *, integer *); +// extern integer myhuge_(real *); + real csq, csu, csv, snq, rwk, snu, snv; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alpha; + --beta; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --work; + + /* Function Body */ + initu = lsame_(jobu, "I"); + wantu = initu || lsame_(jobu, "U"); + + initv = lsame_(jobv, "I"); + wantv = initv || lsame_(jobv, "V"); + + initq = lsame_(jobq, "I"); + wantq = initq || lsame_(jobq, "Q"); + + *info = 0; + if (! (initu || wantu || lsame_(jobu, "N"))) { + *info = -1; + } else if (! (initv || wantv || lsame_(jobv, "N"))) + { + *info = -2; + } else if (! (initq || wantq || lsame_(jobq, "N"))) + { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*p < 0) { + *info = -5; + } else if (*n < 0) { + *info = -6; + } else if (*lda < f2cmax(1,*m)) { + *info = -10; + } else if (*ldb < f2cmax(1,*p)) { + *info = -12; + } else if (*ldu < 1 || wantu && *ldu < *m) { + *info = -18; + } else if (*ldv < 1 || wantv && *ldv < *p) { + *info = -20; + } else if (*ldq < 1 || wantq && *ldq < *n) { + *info = -22; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STGSJA", &i__1, (ftnlen)6); + return 0; + } + +/* Initialize U, V and Q, if necessary */ + + if (initu) { + slaset_("Full", m, m, &c_b1, &c_b15, &u[u_offset], ldu); + } + if (initv) { + slaset_("Full", p, p, &c_b1, &c_b15, &v[v_offset], ldv); + } + if (initq) { + slaset_("Full", n, n, &c_b1, &c_b15, &q[q_offset], ldq); + } + +/* Loop until convergence */ + + upper = FALSE_; + for (kcallmycycle = 1; kcallmycycle <= 40; ++kcallmycycle) { + + upper = ! upper; + + i__1 = *l - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *l; + for (j = i__ + 1; j <= i__2; ++j) { + + a1 = 0.f; + a2 = 0.f; + a3 = 0.f; + if (*k + i__ <= *m) { + a1 = a[*k + i__ + (*n - *l + i__) * a_dim1]; + } + if (*k + j <= *m) { + a3 = a[*k + j + (*n - *l + j) * a_dim1]; + } + + b1 = b[i__ + (*n - *l + i__) * b_dim1]; + b3 = b[j + (*n - *l + j) * b_dim1]; + + if (upper) { + if (*k + i__ <= *m) { + a2 = a[*k + i__ + (*n - *l + j) * a_dim1]; + } + b2 = b[i__ + (*n - *l + j) * b_dim1]; + } else { + if (*k + j <= *m) { + a2 = a[*k + j + (*n - *l + i__) * a_dim1]; + } + b2 = b[j + (*n - *l + i__) * b_dim1]; + } + + slags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, & + csv, &snv, &csq, &snq); + +/* Update (K+I)-th and (K+J)-th rows of matrix A: U**T *A */ + + if (*k + j <= *m) { + srot_(l, &a[*k + j + (*n - *l + 1) * a_dim1], lda, &a[*k + + i__ + (*n - *l + 1) * a_dim1], lda, &csu, &snu); + } + +/* Update I-th and J-th rows of matrix B: V**T *B */ + + srot_(l, &b[j + (*n - *l + 1) * b_dim1], ldb, &b[i__ + (*n - * + l + 1) * b_dim1], ldb, &csv, &snv); + +/* Update (N-L+I)-th and (N-L+J)-th columns of matrices */ +/* A and B: A*Q and B*Q */ + +/* Computing MIN */ + i__4 = *k + *l; + i__3 = f2cmin(i__4,*m); + srot_(&i__3, &a[(*n - *l + j) * a_dim1 + 1], &c__1, &a[(*n - * + l + i__) * a_dim1 + 1], &c__1, &csq, &snq); + + srot_(l, &b[(*n - *l + j) * b_dim1 + 1], &c__1, &b[(*n - *l + + i__) * b_dim1 + 1], &c__1, &csq, &snq); + + if (upper) { + if (*k + i__ <= *m) { + a[*k + i__ + (*n - *l + j) * a_dim1] = 0.f; + } + b[i__ + (*n - *l + j) * b_dim1] = 0.f; + } else { + if (*k + j <= *m) { + a[*k + j + (*n - *l + i__) * a_dim1] = 0.f; + } + b[j + (*n - *l + i__) * b_dim1] = 0.f; + } + +/* Update orthogonal matrices U, V, Q, if desired. */ + + if (wantu && *k + j <= *m) { + srot_(m, &u[(*k + j) * u_dim1 + 1], &c__1, &u[(*k + i__) * + u_dim1 + 1], &c__1, &csu, &snu); + } + + if (wantv) { + srot_(p, &v[j * v_dim1 + 1], &c__1, &v[i__ * v_dim1 + 1], + &c__1, &csv, &snv); + } + + if (wantq) { + srot_(n, &q[(*n - *l + j) * q_dim1 + 1], &c__1, &q[(*n - * + l + i__) * q_dim1 + 1], &c__1, &csq, &snq); + } + +/* L10: */ + } +/* L20: */ + } + + if (! upper) { + +/* The matrices A13 and B13 were lower triangular at the start */ +/* of the cycle, and are now upper triangular. */ + +/* Convergence test: test the parallelism of the corresponding */ +/* rows of A and B. */ + + error = 0.f; +/* Computing MIN */ + i__2 = *l, i__3 = *m - *k; + i__1 = f2cmin(i__2,i__3); + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *l - i__ + 1; + scopy_(&i__2, &a[*k + i__ + (*n - *l + i__) * a_dim1], lda, & + work[1], &c__1); + i__2 = *l - i__ + 1; + scopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &work[* + l + 1], &c__1); + i__2 = *l - i__ + 1; + slapll_(&i__2, &work[1], &c__1, &work[*l + 1], &c__1, &ssmin); + error = f2cmax(error,ssmin); +/* L30: */ + } + + if (abs(error) <= f2cmin(*tola,*tolb)) { + goto L50; + } + } + +/* End of cycle loop */ + +/* L40: */ + } + +/* The algorithm has not converged after MAXIT cycles. */ + + *info = 1; + goto L100; + +L50: + +/* If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged. */ +/* Compute the generalized singular value pairs (ALPHA, BETA), and */ +/* set the triangular matrix R to array A. */ + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + alpha[i__] = 1.f; + beta[i__] = 0.f; +/* L60: */ + } + +/* Computing MIN */ + i__2 = *l, i__3 = *m - *k; + i__1 = f2cmin(i__2,i__3); + for (i__ = 1; i__ <= i__1; ++i__) { + + a1 = a[*k + i__ + (*n - *l + i__) * a_dim1]; + b1 = b[i__ + (*n - *l + i__) * b_dim1]; + gamma = b1 / a1; + + if (gamma <= (real) myhuge_(&c_b1) && gamma >= -((real) myhuge_(&c_b1) + )) { + +/* change sign if necessary */ + + if (gamma < 0.f) { + i__2 = *l - i__ + 1; + sscal_(&i__2, &c_b44, &b[i__ + (*n - *l + i__) * b_dim1], ldb) + ; + if (wantv) { + sscal_(p, &c_b44, &v[i__ * v_dim1 + 1], &c__1); + } + } + + r__1 = abs(gamma); + slartg_(&r__1, &c_b15, &beta[*k + i__], &alpha[*k + i__], &rwk); + + if (alpha[*k + i__] >= beta[*k + i__]) { + i__2 = *l - i__ + 1; + r__1 = 1.f / alpha[*k + i__]; + sscal_(&i__2, &r__1, &a[*k + i__ + (*n - *l + i__) * a_dim1], + lda); + } else { + i__2 = *l - i__ + 1; + r__1 = 1.f / beta[*k + i__]; + sscal_(&i__2, &r__1, &b[i__ + (*n - *l + i__) * b_dim1], ldb); + i__2 = *l - i__ + 1; + scopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k + + i__ + (*n - *l + i__) * a_dim1], lda); + } + + } else { + + alpha[*k + i__] = 0.f; + beta[*k + i__] = 1.f; + i__2 = *l - i__ + 1; + scopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k + + i__ + (*n - *l + i__) * a_dim1], lda); + + } + +/* L70: */ + } + +/* Post-assignment */ + + i__1 = *k + *l; + for (i__ = *m + 1; i__ <= i__1; ++i__) { + alpha[i__] = 0.f; + beta[i__] = 1.f; +/* L80: */ + } + + if (*k + *l < *n) { + i__1 = *n; + for (i__ = *k + *l + 1; i__ <= i__1; ++i__) { + alpha[i__] = 0.f; + beta[i__] = 0.f; +/* L90: */ + } + } + +L100: + *ncallmycycle = kcallmycycle; + return 0; + +/* End of STGSJA */ + +} /* stgsja_ */ + diff --git a/lapack-netlib/SRC/stgsna.c b/lapack-netlib/SRC/stgsna.c new file mode 100644 index 000000000..39604033c --- /dev/null +++ b/lapack-netlib/SRC/stgsna.c @@ -0,0 +1,1170 @@ +/* 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 STGSNA */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STGSNA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, */ +/* LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, */ +/* IWORK, INFO ) */ + +/* CHARACTER HOWMNY, JOB */ +/* INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N */ +/* LOGICAL SELECT( * ) */ +/* INTEGER IWORK( * ) */ +/* REAL A( LDA, * ), B( LDB, * ), DIF( * ), S( * ), */ +/* $ VL( LDVL, * ), VR( LDVR, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STGSNA estimates reciprocal condition numbers for specified */ +/* > eigenvalues and/or eigenvectors of a matrix pair (A, B) in */ +/* > generalized real Schur canonical form (or of any matrix pair */ +/* > (Q*A*Z**T, Q*B*Z**T) with orthogonal matrices Q and Z, where */ +/* > Z**T denotes the transpose of Z. */ +/* > */ +/* > (A, B) must be in generalized real Schur form (as returned by SGGES), */ +/* > i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal */ +/* > blocks. B is upper triangular. */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOB */ +/* > \verbatim */ +/* > JOB is CHARACTER*1 */ +/* > Specifies whether condition numbers are required for */ +/* > eigenvalues (S) or eigenvectors (DIF): */ +/* > = 'E': for eigenvalues only (S); */ +/* > = 'V': for eigenvectors only (DIF); */ +/* > = 'B': for both eigenvalues and eigenvectors (S and DIF). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] HOWMNY */ +/* > \verbatim */ +/* > HOWMNY is CHARACTER*1 */ +/* > = 'A': compute condition numbers for all eigenpairs; */ +/* > = 'S': compute condition numbers for selected eigenpairs */ +/* > specified by the array SELECT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > If HOWMNY = 'S', SELECT specifies the eigenpairs for which */ +/* > condition numbers are required. To select condition numbers */ +/* > for the eigenpair corresponding to a real eigenvalue w(j), */ +/* > SELECT(j) must be set to .TRUE.. To select condition numbers */ +/* > corresponding to a complex conjugate pair of eigenvalues w(j) */ +/* > and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be */ +/* > set to .TRUE.. */ +/* > If HOWMNY = 'A', SELECT is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the square matrix pair (A, B). N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > The upper quasi-triangular matrix A in the pair (A,B). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,N) */ +/* > The upper triangular matrix B in the pair (A,B). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VL */ +/* > \verbatim */ +/* > VL is REAL array, dimension (LDVL,M) */ +/* > If JOB = 'E' or 'B', VL must contain left eigenvectors of */ +/* > (A, B), corresponding to the eigenpairs specified by HOWMNY */ +/* > and SELECT. The eigenvectors must be stored in consecutive */ +/* > columns of VL, as returned by STGEVC. */ +/* > If JOB = 'V', VL is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the array VL. LDVL >= 1. */ +/* > If JOB = 'E' or 'B', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VR */ +/* > \verbatim */ +/* > VR is REAL array, dimension (LDVR,M) */ +/* > If JOB = 'E' or 'B', VR must contain right eigenvectors of */ +/* > (A, B), corresponding to the eigenpairs specified by HOWMNY */ +/* > and SELECT. The eigenvectors must be stored in consecutive */ +/* > columns ov VR, as returned by STGEVC. */ +/* > If JOB = 'V', VR is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the array VR. LDVR >= 1. */ +/* > If JOB = 'E' or 'B', LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (MM) */ +/* > If JOB = 'E' or 'B', the reciprocal condition numbers of the */ +/* > selected eigenvalues, stored in consecutive elements of the */ +/* > array. For a complex conjugate pair of eigenvalues two */ +/* > consecutive elements of S are set to the same value. Thus */ +/* > S(j), DIF(j), and the j-th columns of VL and VR all */ +/* > correspond to the same eigenpair (but not in general the */ +/* > j-th eigenpair, unless all eigenpairs are selected). */ +/* > If JOB = 'V', S is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DIF */ +/* > \verbatim */ +/* > DIF is REAL array, dimension (MM) */ +/* > If JOB = 'V' or 'B', the estimated reciprocal condition */ +/* > numbers of the selected eigenvectors, stored in consecutive */ +/* > elements of the array. For a complex eigenvector two */ +/* > consecutive elements of DIF are set to the same value. If */ +/* > the eigenvalues cannot be reordered to compute DIF(j), DIF(j) */ +/* > is set to 0; this can only occur when the true value would be */ +/* > very small anyway. */ +/* > If JOB = 'E', DIF is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MM */ +/* > \verbatim */ +/* > MM is INTEGER */ +/* > The number of elements in the arrays S and DIF. MM >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of elements of the arrays S and DIF used to store */ +/* > the specified condition numbers; for each selected real */ +/* > eigenvalue one element is used, and for each selected complex */ +/* > conjugate pair of eigenvalues, two elements are used. */ +/* > If HOWMNY = 'A', M is set to N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,N). */ +/* > If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N + 6) */ +/* > If JOB = 'E', IWORK is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > =0: Successful exit */ +/* > <0: If INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The reciprocal of the condition number of a generalized eigenvalue */ +/* > w = (a, b) is defined as */ +/* > */ +/* > S(w) = (|u**TAv|**2 + |u**TBv|**2)**(1/2) / (norm(u)*norm(v)) */ +/* > */ +/* > where u and v are the left and right eigenvectors of (A, B) */ +/* > corresponding to w; |z| denotes the absolute value of the complex */ +/* > number, and norm(u) denotes the 2-norm of the vector u. */ +/* > The pair (a, b) corresponds to an eigenvalue w = a/b (= u**TAv/u**TBv) */ +/* > of the matrix pair (A, B). If both a and b equal zero, then (A B) is */ +/* > singular and S(I) = -1 is returned. */ +/* > */ +/* > An approximate error bound on the chordal distance between the i-th */ +/* > computed generalized eigenvalue w and the corresponding exact */ +/* > eigenvalue lambda is */ +/* > */ +/* > chord(w, lambda) <= EPS * norm(A, B) / S(I) */ +/* > */ +/* > where EPS is the machine precision. */ +/* > */ +/* > The reciprocal of the condition number DIF(i) of right eigenvector u */ +/* > and left eigenvector v corresponding to the generalized eigenvalue w */ +/* > is defined as follows: */ +/* > */ +/* > a) If the i-th eigenvalue w = (a,b) is real */ +/* > */ +/* > Suppose U and V are orthogonal transformations such that */ +/* > */ +/* > U**T*(A, B)*V = (S, T) = ( a * ) ( b * ) 1 */ +/* > ( 0 S22 ),( 0 T22 ) n-1 */ +/* > 1 n-1 1 n-1 */ +/* > */ +/* > Then the reciprocal condition number DIF(i) is */ +/* > */ +/* > Difl((a, b), (S22, T22)) = sigma-f2cmin( Zl ), */ +/* > */ +/* > where sigma-f2cmin(Zl) denotes the smallest singular value of the */ +/* > 2(n-1)-by-2(n-1) matrix */ +/* > */ +/* > Zl = [ kron(a, In-1) -kron(1, S22) ] */ +/* > [ kron(b, In-1) -kron(1, T22) ] . */ +/* > */ +/* > Here In-1 is the identity matrix of size n-1. kron(X, Y) is the */ +/* > Kronecker product between the matrices X and Y. */ +/* > */ +/* > Note that if the default method for computing DIF(i) is wanted */ +/* > (see SLATDF), then the parameter DIFDRI (see below) should be */ +/* > changed from 3 to 4 (routine SLATDF(IJOB = 2 will be used)). */ +/* > See STGSYL for more details. */ +/* > */ +/* > b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair, */ +/* > */ +/* > Suppose U and V are orthogonal transformations such that */ +/* > */ +/* > U**T*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2 */ +/* > ( 0 S22 ),( 0 T22) n-2 */ +/* > 2 n-2 2 n-2 */ +/* > */ +/* > and (S11, T11) corresponds to the complex conjugate eigenvalue */ +/* > pair (w, conjg(w)). There exist unitary matrices U1 and V1 such */ +/* > that */ +/* > */ +/* > U1**T*S11*V1 = ( s11 s12 ) and U1**T*T11*V1 = ( t11 t12 ) */ +/* > ( 0 s22 ) ( 0 t22 ) */ +/* > */ +/* > where the generalized eigenvalues w = s11/t11 and */ +/* > conjg(w) = s22/t22. */ +/* > */ +/* > Then the reciprocal condition number DIF(i) is bounded by */ +/* > */ +/* > f2cmin( d1, f2cmax( 1, |real(s11)/real(s22)| )*d2 ) */ +/* > */ +/* > where, d1 = Difl((s11, t11), (s22, t22)) = sigma-f2cmin(Z1), where */ +/* > Z1 is the complex 2-by-2 matrix */ +/* > */ +/* > Z1 = [ s11 -s22 ] */ +/* > [ t11 -t22 ], */ +/* > */ +/* > This is done by computing (using real arithmetic) the */ +/* > roots of the characteristical polynomial det(Z1**T * Z1 - lambda I), */ +/* > where Z1**T denotes the transpose of Z1 and det(X) denotes */ +/* > the determinant of X. */ +/* > */ +/* > and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an */ +/* > upper bound on sigma-f2cmin(Z2), where Z2 is (2n-2)-by-(2n-2) */ +/* > */ +/* > Z2 = [ kron(S11**T, In-2) -kron(I2, S22) ] */ +/* > [ kron(T11**T, In-2) -kron(I2, T22) ] */ +/* > */ +/* > Note that if the default method for computing DIF is wanted (see */ +/* > SLATDF), then the parameter DIFDRI (see below) should be changed */ +/* > from 3 to 4 (routine SLATDF(IJOB = 2 will be used)). See STGSYL */ +/* > for more details. */ +/* > */ +/* > For each eigenvalue/vector specified by SELECT, DIF stores a */ +/* > Frobenius norm-based estimate of Difl. */ +/* > */ +/* > An approximate error bound for the i-th computed eigenvector VL(i) or */ +/* > VR(i) is given by */ +/* > */ +/* > EPS * norm(A, B) / DIF(i). */ +/* > */ +/* > See ref. [2-3] for more details and further references. */ +/* > \endverbatim */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* > Umea University, S-901 87 Umea, Sweden. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > \verbatim */ +/* > */ +/* > [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */ +/* > Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */ +/* > M.S. Moonen et al (eds), Linear Algebra for Large Scale and */ +/* > Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */ +/* > */ +/* > [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */ +/* > Eigenvalues of a Regular Matrix Pair (A, B) and Condition */ +/* > Estimation: Theory, Algorithms and Software, */ +/* > Report UMINF - 94.04, Department of Computing Science, Umea */ +/* > University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */ +/* > Note 87. To appear in Numerical Algorithms, 1996. */ +/* > */ +/* > [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */ +/* > for Solving the Generalized Sylvester Equation and Estimating the */ +/* > Separation between Regular Matrix Pairs, Report UMINF - 93.23, */ +/* > Department of Computing Science, Umea University, S-901 87 Umea, */ +/* > Sweden, December 1993, Revised April 1994, Also as LAPACK Working */ +/* > Note 75. To appear in ACM Trans. on Math. Software, Vol 22, */ +/* > No 1, 1996. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int stgsna_(char *job, char *howmny, logical *select, + integer *n, real *a, integer *lda, real *b, integer *ldb, real *vl, + integer *ldvl, real *vr, integer *ldvr, real *s, real *dif, integer * + mm, integer *m, real *work, integer *lwork, integer *iwork, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, + vr_offset, i__1, i__2; + real r__1, r__2; + + /* Local variables */ + real beta, cond; + logical pair; + integer ierr; + real uhav, uhbv; + integer ifst; + real lnrm; + extern real sdot_(integer *, real *, integer *, real *, integer *); + integer ilst; + real rnrm; + extern /* Subroutine */ int slag2_(real *, integer *, real *, integer *, + real *, real *, real *, real *, real *, real *); + extern real snrm2_(integer *, real *, integer *); + real root1, root2; + integer i__, k; + real scale; + extern logical lsame_(char *, char *); + real uhavi, uhbvi; + extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *); + real tmpii, c1, c2; + integer lwmin; + logical wants; + real tmpir; + integer n1, n2; + real tmpri, dummy[1], tmprr; + extern real slapy2_(real *, real *); + real dummy1[1]; + integer ks; + real alphai; + integer iz; + real alphar; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical wantbh, wantdf; + extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, + integer *, real *, integer *), stgexc_(logical *, logical + *, integer *, real *, integer *, real *, integer *, real *, + integer *, real *, integer *, integer *, integer *, real *, + integer *, integer *); + logical somcon; + real alprqt, smlnum; + logical lquery; + extern /* Subroutine */ int stgsyl_(char *, integer *, integer *, integer + *, real *, integer *, real *, integer *, real *, integer *, real * + , integer *, real *, integer *, real *, integer *, real *, real *, + real *, integer *, integer *, integer *); + real eps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + --select; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --s; + --dif; + --work; + --iwork; + + /* Function Body */ + wantbh = lsame_(job, "B"); + wants = lsame_(job, "E") || wantbh; + wantdf = lsame_(job, "V") || wantbh; + + somcon = lsame_(howmny, "S"); + + *info = 0; + lquery = *lwork == -1; + + if (! wants && ! wantdf) { + *info = -1; + } else if (! lsame_(howmny, "A") && ! somcon) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else if (wants && *ldvl < *n) { + *info = -10; + } else if (wants && *ldvr < *n) { + *info = -12; + } else { + +/* Set M to the number of eigenpairs for which condition numbers */ +/* are required, and test MM. */ + + if (somcon) { + *m = 0; + pair = FALSE_; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = FALSE_; + } else { + if (k < *n) { + if (a[k + 1 + k * a_dim1] == 0.f) { + if (select[k]) { + ++(*m); + } + } else { + pair = TRUE_; + if (select[k] || select[k + 1]) { + *m += 2; + } + } + } else { + if (select[*n]) { + ++(*m); + } + } + } +/* L10: */ + } + } else { + *m = *n; + } + + if (*n == 0) { + lwmin = 1; + } else if (lsame_(job, "V") || lsame_(job, + "B")) { + lwmin = (*n << 1) * (*n + 2) + 16; + } else { + lwmin = *n; + } + work[1] = (real) lwmin; + + if (*mm < *m) { + *info = -15; + } else if (*lwork < lwmin && ! lquery) { + *info = -18; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("STGSNA", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = slamch_("P"); + smlnum = slamch_("S") / eps; + ks = 0; + pair = FALSE_; + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + +/* Determine whether A(k,k) begins a 1-by-1 or 2-by-2 block. */ + + if (pair) { + pair = FALSE_; + goto L20; + } else { + if (k < *n) { + pair = a[k + 1 + k * a_dim1] != 0.f; + } + } + +/* Determine whether condition numbers are required for the k-th */ +/* eigenpair. */ + + if (somcon) { + if (pair) { + if (! select[k] && ! select[k + 1]) { + goto L20; + } + } else { + if (! select[k]) { + goto L20; + } + } + } + + ++ks; + + if (wants) { + +/* Compute the reciprocal condition number of the k-th */ +/* eigenvalue. */ + + if (pair) { + +/* Complex eigenvalue pair. */ + + r__1 = snrm2_(n, &vr[ks * vr_dim1 + 1], &c__1); + r__2 = snrm2_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1); + rnrm = slapy2_(&r__1, &r__2); + r__1 = snrm2_(n, &vl[ks * vl_dim1 + 1], &c__1); + r__2 = snrm2_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1); + lnrm = slapy2_(&r__1, &r__2); + sgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[ks * vr_dim1 + + 1], &c__1, &c_b21, &work[1], &c__1); + tmprr = sdot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], & + c__1); + tmpri = sdot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1], + &c__1); + sgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[(ks + 1) * + vr_dim1 + 1], &c__1, &c_b21, &work[1], &c__1); + tmpii = sdot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1], + &c__1); + tmpir = sdot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], & + c__1); + uhav = tmprr + tmpii; + uhavi = tmpir - tmpri; + sgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[ks * vr_dim1 + + 1], &c__1, &c_b21, &work[1], &c__1); + tmprr = sdot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], & + c__1); + tmpri = sdot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1], + &c__1); + sgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[(ks + 1) * + vr_dim1 + 1], &c__1, &c_b21, &work[1], &c__1); + tmpii = sdot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1], + &c__1); + tmpir = sdot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], & + c__1); + uhbv = tmprr + tmpii; + uhbvi = tmpir - tmpri; + uhav = slapy2_(&uhav, &uhavi); + uhbv = slapy2_(&uhbv, &uhbvi); + cond = slapy2_(&uhav, &uhbv); + s[ks] = cond / (rnrm * lnrm); + s[ks + 1] = s[ks]; + + } else { + +/* Real eigenvalue. */ + + rnrm = snrm2_(n, &vr[ks * vr_dim1 + 1], &c__1); + lnrm = snrm2_(n, &vl[ks * vl_dim1 + 1], &c__1); + sgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[ks * vr_dim1 + + 1], &c__1, &c_b21, &work[1], &c__1); + uhav = sdot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1) + ; + sgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[ks * vr_dim1 + + 1], &c__1, &c_b21, &work[1], &c__1); + uhbv = sdot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1) + ; + cond = slapy2_(&uhav, &uhbv); + if (cond == 0.f) { + s[ks] = -1.f; + } else { + s[ks] = cond / (rnrm * lnrm); + } + } + } + + if (wantdf) { + if (*n == 1) { + dif[ks] = slapy2_(&a[a_dim1 + 1], &b[b_dim1 + 1]); + goto L20; + } + +/* Estimate the reciprocal condition number of the k-th */ +/* eigenvectors. */ + if (pair) { + +/* Copy the 2-by 2 pencil beginning at (A(k,k), B(k, k)). */ +/* Compute the eigenvalue(s) at position K. */ + + work[1] = a[k + k * a_dim1]; + work[2] = a[k + 1 + k * a_dim1]; + work[3] = a[k + (k + 1) * a_dim1]; + work[4] = a[k + 1 + (k + 1) * a_dim1]; + work[5] = b[k + k * b_dim1]; + work[6] = b[k + 1 + k * b_dim1]; + work[7] = b[k + (k + 1) * b_dim1]; + work[8] = b[k + 1 + (k + 1) * b_dim1]; + r__1 = smlnum * eps; + slag2_(&work[1], &c__2, &work[5], &c__2, &r__1, &beta, dummy1, + &alphar, dummy, &alphai); + alprqt = 1.f; + c1 = (alphar * alphar + alphai * alphai + beta * beta) * 2.f; + c2 = beta * 4.f * beta * alphai * alphai; + root1 = c1 + sqrt(c1 * c1 - c2 * 4.f); + root2 = c2 / root1; + root1 /= 2.f; +/* Computing MIN */ + r__1 = sqrt(root1), r__2 = sqrt(root2); + cond = f2cmin(r__1,r__2); + } + +/* Copy the matrix (A, B) to the array WORK and swap the */ +/* diagonal block beginning at A(k,k) to the (1,1) position. */ + + slacpy_("Full", n, n, &a[a_offset], lda, &work[1], n); + slacpy_("Full", n, n, &b[b_offset], ldb, &work[*n * *n + 1], n); + ifst = k; + ilst = 1; + + i__2 = *lwork - (*n << 1) * *n; + stgexc_(&c_false, &c_false, n, &work[1], n, &work[*n * *n + 1], n, + dummy, &c__1, dummy1, &c__1, &ifst, &ilst, &work[(*n * * + n << 1) + 1], &i__2, &ierr); + + if (ierr > 0) { + +/* Ill-conditioned problem - swap rejected. */ + + dif[ks] = 0.f; + } else { + +/* Reordering successful, solve generalized Sylvester */ +/* equation for R and L, */ +/* A22 * R - L * A11 = A12 */ +/* B22 * R - L * B11 = B12, */ +/* and compute estimate of Difl((A11,B11), (A22, B22)). */ + + n1 = 1; + if (work[2] != 0.f) { + n1 = 2; + } + n2 = *n - n1; + if (n2 == 0) { + dif[ks] = cond; + } else { + i__ = *n * *n + 1; + iz = (*n << 1) * *n + 1; + i__2 = *lwork - (*n << 1) * *n; + stgsyl_("N", &c__3, &n2, &n1, &work[*n * n1 + n1 + 1], n, + &work[1], n, &work[n1 + 1], n, &work[*n * n1 + n1 + + i__], n, &work[i__], n, &work[n1 + i__], n, & + scale, &dif[ks], &work[iz + 1], &i__2, &iwork[1], + &ierr); + + if (pair) { +/* Computing MIN */ + r__1 = f2cmax(1.f,alprqt) * dif[ks]; + dif[ks] = f2cmin(r__1,cond); + } + } + } + if (pair) { + dif[ks + 1] = dif[ks]; + } + } + if (pair) { + ++ks; + } + +L20: + ; + } + work[1] = (real) lwmin; + return 0; + +/* End of STGSNA */ + +} /* stgsna_ */ + diff --git a/lapack-netlib/SRC/stgsy2.c b/lapack-netlib/SRC/stgsy2.c new file mode 100644 index 000000000..0edc8603d --- /dev/null +++ b/lapack-netlib/SRC/stgsy2.c @@ -0,0 +1,1579 @@ +/* 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 STGSY2 solves the generalized Sylvester equation (unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STGSY2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, */ +/* LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, */ +/* IWORK, PQ, INFO ) */ + +/* CHARACTER TRANS */ +/* INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N, */ +/* $ PQ */ +/* REAL RDSCAL, RDSUM, SCALE */ +/* INTEGER IWORK( * ) */ +/* REAL A( LDA, * ), B( LDB, * ), C( LDC, * ), */ +/* $ D( LDD, * ), E( LDE, * ), F( LDF, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STGSY2 solves the generalized Sylvester equation: */ +/* > */ +/* > A * R - L * B = scale * C (1) */ +/* > D * R - L * E = scale * F, */ +/* > */ +/* > using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices, */ +/* > (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M, */ +/* > N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E) */ +/* > must be in generalized Schur canonical form, i.e. A, B are upper */ +/* > quasi triangular and D, E are upper triangular. The solution (R, L) */ +/* > overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor */ +/* > chosen to avoid overflow. */ +/* > */ +/* > In matrix notation solving equation (1) corresponds to solve */ +/* > Z*x = scale*b, where Z is defined as */ +/* > */ +/* > Z = [ kron(In, A) -kron(B**T, Im) ] (2) */ +/* > [ kron(In, D) -kron(E**T, Im) ], */ +/* > */ +/* > Ik is the identity matrix of size k and X**T is the transpose of X. */ +/* > kron(X, Y) is the Kronecker product between the matrices X and Y. */ +/* > In the process of solving (1), we solve a number of such systems */ +/* > where Dim(In), Dim(In) = 1 or 2. */ +/* > */ +/* > If TRANS = 'T', solve the transposed system Z**T*y = scale*b for y, */ +/* > which is equivalent to solve for R and L in */ +/* > */ +/* > A**T * R + D**T * L = scale * C (3) */ +/* > R * B**T + L * E**T = scale * -F */ +/* > */ +/* > This case is used to compute an estimate of Dif[(A, D), (B, E)] = */ +/* > sigma_min(Z) using reverse communication with SLACON. */ +/* > */ +/* > STGSY2 also (IJOB >= 1) contributes to the computation in STGSYL */ +/* > of an upper bound on the separation between to matrix pairs. Then */ +/* > the input (A, D), (B, E) are sub-pencils of the matrix pair in */ +/* > STGSYL. See STGSYL for details. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': solve the generalized Sylvester equation (1). */ +/* > = 'T': solve the 'transposed' system (3). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IJOB */ +/* > \verbatim */ +/* > IJOB is INTEGER */ +/* > Specifies what kind of functionality to be performed. */ +/* > = 0: solve (1) only. */ +/* > = 1: A contribution from this subsystem to a Frobenius */ +/* > norm-based estimate of the separation between two matrix */ +/* > pairs is computed. (look ahead strategy is used). */ +/* > = 2: A contribution from this subsystem to a Frobenius */ +/* > norm-based estimate of the separation between two matrix */ +/* > pairs is computed. (SGECON on sub-systems is used.) */ +/* > Not referenced if TRANS = 'T'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > On entry, M specifies the order of A and D, and the row */ +/* > dimension of C, F, R and L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > On entry, N specifies the order of B and E, and the column */ +/* > dimension of C, F, R and L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA, M) */ +/* > On entry, A contains an upper quasi triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the matrix A. LDA >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB, N) */ +/* > On entry, B contains an upper quasi triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the matrix B. LDB >= f2cmax(1, N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (LDC, N) */ +/* > On entry, C contains the right-hand-side of the first matrix */ +/* > equation in (1). */ +/* > On exit, if IJOB = 0, C has been overwritten by the */ +/* > solution R. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the matrix C. LDC >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (LDD, M) */ +/* > On entry, D contains an upper triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDD */ +/* > \verbatim */ +/* > LDD is INTEGER */ +/* > The leading dimension of the matrix D. LDD >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (LDE, N) */ +/* > On entry, E contains an upper triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDE */ +/* > \verbatim */ +/* > LDE is INTEGER */ +/* > The leading dimension of the matrix E. LDE >= f2cmax(1, N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] F */ +/* > \verbatim */ +/* > F is REAL array, dimension (LDF, N) */ +/* > On entry, F contains the right-hand-side of the second matrix */ +/* > equation in (1). */ +/* > On exit, if IJOB = 0, F has been overwritten by the */ +/* > solution L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDF */ +/* > \verbatim */ +/* > LDF is INTEGER */ +/* > The leading dimension of the matrix F. LDF >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE */ +/* > \verbatim */ +/* > SCALE is REAL */ +/* > On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions */ +/* > R and L (C and F on entry) will hold the solutions to a */ +/* > slightly perturbed system but the input matrices A, B, D and */ +/* > E have not been changed. If SCALE = 0, R and L will hold the */ +/* > solutions to the homogeneous system with C = F = 0. Normally, */ +/* > SCALE = 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] RDSUM */ +/* > \verbatim */ +/* > RDSUM is REAL */ +/* > On entry, the sum of squares of computed contributions to */ +/* > the Dif-estimate under computation by STGSYL, 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 STGSY2 is called by STGSYL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] RDSCAL */ +/* > \verbatim */ +/* > RDSCAL is REAL */ +/* > 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 STGSY2 is called by */ +/* > STGSYL. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (M+N+2) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PQ */ +/* > \verbatim */ +/* > PQ is INTEGER */ +/* > On exit, the number of subsystems (of size 2-by-2, 4-by-4 and */ +/* > 8-by-8) solved by this routine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > On exit, if INFO is set to */ +/* > =0: Successful exit */ +/* > <0: If INFO = -i, the i-th argument had an illegal value. */ +/* > >0: The matrix pairs (A, D) and (B, E) have common or very */ +/* > close eigenvalues. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realSYauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* > Umea University, S-901 87 Umea, Sweden. */ + +/* ===================================================================== */ +/* Subroutine */ int stgsy2_(char *trans, integer *ijob, integer *m, integer * + n, real *a, integer *lda, real *b, integer *ldb, real *c__, integer * + ldc, real *d__, integer *ldd, real *e, integer *lde, real *f, integer + *ldf, real *scale, real *rdsum, real *rdscal, integer *iwork, integer + *pq, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1, + d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3; + + /* Local variables */ + extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, + integer *, real *, integer *, real *, integer *); + integer ierr, zdim, ipiv[8], jpiv[8], i__, j, k, p, q; + real alpha, z__[64] /* was [8][8] */; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), + sgemm_(char *, char *, integer *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *), sgemv_(char *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *), + saxpy_(integer *, real *, real *, integer *, real *, integer *), + sgesc2_(integer *, real *, integer *, real *, integer *, integer * + , real *), sgetc2_(integer *, real *, integer *, integer *, + integer *, integer *); + integer ie, je, mb, nb, ii, jj, is, js; + real scaloc; + extern /* Subroutine */ int slatdf_(integer *, integer *, real *, integer + *, real *, real *, real *, integer *, integer *), xerbla_(char *, + integer *, ftnlen), slaset_(char *, integer *, integer *, real *, + real *, real *, integer *); + logical notran; + real rhs[8]; + integer isp1, jsp1; + + +/* -- 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 */ + + +/* ===================================================================== */ +/* Replaced various illegal calls to SCOPY by calls to SLASET. */ +/* Sven Hammarling, 27/5/02. */ + + +/* Decode and test input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + d_dim1 = *ldd; + d_offset = 1 + d_dim1 * 1; + d__ -= d_offset; + e_dim1 = *lde; + e_offset = 1 + e_dim1 * 1; + e -= e_offset; + f_dim1 = *ldf; + f_offset = 1 + f_dim1 * 1; + f -= f_offset; + --iwork; + + /* Function Body */ + *info = 0; + ierr = 0; + notran = lsame_(trans, "N"); + if (! notran && ! lsame_(trans, "T")) { + *info = -1; + } else if (notran) { + if (*ijob < 0 || *ijob > 2) { + *info = -2; + } + } + if (*info == 0) { + if (*m <= 0) { + *info = -3; + } else if (*n <= 0) { + *info = -4; + } else if (*lda < f2cmax(1,*m)) { + *info = -6; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else if (*ldc < f2cmax(1,*m)) { + *info = -10; + } else if (*ldd < f2cmax(1,*m)) { + *info = -12; + } else if (*lde < f2cmax(1,*n)) { + *info = -14; + } else if (*ldf < f2cmax(1,*m)) { + *info = -16; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STGSY2", &i__1, (ftnlen)6); + return 0; + } + +/* Determine block structure of A */ + + *pq = 0; + p = 0; + i__ = 1; +L10: + if (i__ > *m) { + goto L20; + } + ++p; + iwork[p] = i__; + if (i__ == *m) { + goto L20; + } + if (a[i__ + 1 + i__ * a_dim1] != 0.f) { + i__ += 2; + } else { + ++i__; + } + goto L10; +L20: + iwork[p + 1] = *m + 1; + +/* Determine block structure of B */ + + q = p + 1; + j = 1; +L30: + if (j > *n) { + goto L40; + } + ++q; + iwork[q] = j; + if (j == *n) { + goto L40; + } + if (b[j + 1 + j * b_dim1] != 0.f) { + j += 2; + } else { + ++j; + } + goto L30; +L40: + iwork[q + 1] = *n + 1; + *pq = p * (q - p - 1); + + if (notran) { + +/* Solve (I, J) - subsystem */ +/* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */ +/* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */ +/* for I = P, P - 1, ..., 1; J = 1, 2, ..., Q */ + + *scale = 1.f; + scaloc = 1.f; + i__1 = q; + for (j = p + 2; j <= i__1; ++j) { + js = iwork[j]; + jsp1 = js + 1; + je = iwork[j + 1] - 1; + nb = je - js + 1; + for (i__ = p; i__ >= 1; --i__) { + + is = iwork[i__]; + isp1 = is + 1; + ie = iwork[i__ + 1] - 1; + mb = ie - is + 1; + zdim = mb * nb << 1; + + if (mb == 1 && nb == 1) { + +/* Build a 2-by-2 system Z * x = RHS */ + + z__[0] = a[is + is * a_dim1]; + z__[1] = d__[is + is * d_dim1]; + z__[8] = -b[js + js * b_dim1]; + z__[9] = -e[js + js * e_dim1]; + +/* Set up right hand side(s) */ + + rhs[0] = c__[is + js * c_dim1]; + rhs[1] = f[is + js * f_dim1]; + +/* Solve Z * x = RHS */ + + sgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + + if (*ijob == 0) { + sgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.f) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + sscal_(m, &scaloc, &c__[k * c_dim1 + 1], & + c__1); + sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L50: */ + } + *scale *= scaloc; + } + } else { + slatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal, + ipiv, jpiv); + } + +/* Unpack solution vector(s) */ + + c__[is + js * c_dim1] = rhs[0]; + f[is + js * f_dim1] = rhs[1]; + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (i__ > 1) { + alpha = -rhs[0]; + i__2 = is - 1; + saxpy_(&i__2, &alpha, &a[is * a_dim1 + 1], &c__1, & + c__[js * c_dim1 + 1], &c__1); + i__2 = is - 1; + saxpy_(&i__2, &alpha, &d__[is * d_dim1 + 1], &c__1, & + f[js * f_dim1 + 1], &c__1); + } + if (j < q) { + i__2 = *n - je; + saxpy_(&i__2, &rhs[1], &b[js + (je + 1) * b_dim1], + ldb, &c__[is + (je + 1) * c_dim1], ldc); + i__2 = *n - je; + saxpy_(&i__2, &rhs[1], &e[js + (je + 1) * e_dim1], + lde, &f[is + (je + 1) * f_dim1], ldf); + } + + } else if (mb == 1 && nb == 2) { + +/* Build a 4-by-4 system Z * x = RHS */ + + z__[0] = a[is + is * a_dim1]; + z__[1] = 0.f; + z__[2] = d__[is + is * d_dim1]; + z__[3] = 0.f; + + z__[8] = 0.f; + z__[9] = a[is + is * a_dim1]; + z__[10] = 0.f; + z__[11] = d__[is + is * d_dim1]; + + z__[16] = -b[js + js * b_dim1]; + z__[17] = -b[js + jsp1 * b_dim1]; + z__[18] = -e[js + js * e_dim1]; + z__[19] = -e[js + jsp1 * e_dim1]; + + z__[24] = -b[jsp1 + js * b_dim1]; + z__[25] = -b[jsp1 + jsp1 * b_dim1]; + z__[26] = 0.f; + z__[27] = -e[jsp1 + jsp1 * e_dim1]; + +/* Set up right hand side(s) */ + + rhs[0] = c__[is + js * c_dim1]; + rhs[1] = c__[is + jsp1 * c_dim1]; + rhs[2] = f[is + js * f_dim1]; + rhs[3] = f[is + jsp1 * f_dim1]; + +/* Solve Z * x = RHS */ + + sgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + + if (*ijob == 0) { + sgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.f) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + sscal_(m, &scaloc, &c__[k * c_dim1 + 1], & + c__1); + sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L60: */ + } + *scale *= scaloc; + } + } else { + slatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal, + ipiv, jpiv); + } + +/* Unpack solution vector(s) */ + + c__[is + js * c_dim1] = rhs[0]; + c__[is + jsp1 * c_dim1] = rhs[1]; + f[is + js * f_dim1] = rhs[2]; + f[is + jsp1 * f_dim1] = rhs[3]; + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (i__ > 1) { + i__2 = is - 1; + sger_(&i__2, &nb, &c_b27, &a[is * a_dim1 + 1], &c__1, + rhs, &c__1, &c__[js * c_dim1 + 1], ldc); + i__2 = is - 1; + sger_(&i__2, &nb, &c_b27, &d__[is * d_dim1 + 1], & + c__1, rhs, &c__1, &f[js * f_dim1 + 1], ldf); + } + if (j < q) { + i__2 = *n - je; + saxpy_(&i__2, &rhs[2], &b[js + (je + 1) * b_dim1], + ldb, &c__[is + (je + 1) * c_dim1], ldc); + i__2 = *n - je; + saxpy_(&i__2, &rhs[2], &e[js + (je + 1) * e_dim1], + lde, &f[is + (je + 1) * f_dim1], ldf); + i__2 = *n - je; + saxpy_(&i__2, &rhs[3], &b[jsp1 + (je + 1) * b_dim1], + ldb, &c__[is + (je + 1) * c_dim1], ldc); + i__2 = *n - je; + saxpy_(&i__2, &rhs[3], &e[jsp1 + (je + 1) * e_dim1], + lde, &f[is + (je + 1) * f_dim1], ldf); + } + + } else if (mb == 2 && nb == 1) { + +/* Build a 4-by-4 system Z * x = RHS */ + + z__[0] = a[is + is * a_dim1]; + z__[1] = a[isp1 + is * a_dim1]; + z__[2] = d__[is + is * d_dim1]; + z__[3] = 0.f; + + z__[8] = a[is + isp1 * a_dim1]; + z__[9] = a[isp1 + isp1 * a_dim1]; + z__[10] = d__[is + isp1 * d_dim1]; + z__[11] = d__[isp1 + isp1 * d_dim1]; + + z__[16] = -b[js + js * b_dim1]; + z__[17] = 0.f; + z__[18] = -e[js + js * e_dim1]; + z__[19] = 0.f; + + z__[24] = 0.f; + z__[25] = -b[js + js * b_dim1]; + z__[26] = 0.f; + z__[27] = -e[js + js * e_dim1]; + +/* Set up right hand side(s) */ + + rhs[0] = c__[is + js * c_dim1]; + rhs[1] = c__[isp1 + js * c_dim1]; + rhs[2] = f[is + js * f_dim1]; + rhs[3] = f[isp1 + js * f_dim1]; + +/* Solve Z * x = RHS */ + + sgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + if (*ijob == 0) { + sgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.f) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + sscal_(m, &scaloc, &c__[k * c_dim1 + 1], & + c__1); + sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L70: */ + } + *scale *= scaloc; + } + } else { + slatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal, + ipiv, jpiv); + } + +/* Unpack solution vector(s) */ + + c__[is + js * c_dim1] = rhs[0]; + c__[isp1 + js * c_dim1] = rhs[1]; + f[is + js * f_dim1] = rhs[2]; + f[isp1 + js * f_dim1] = rhs[3]; + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (i__ > 1) { + i__2 = is - 1; + sgemv_("N", &i__2, &mb, &c_b27, &a[is * a_dim1 + 1], + lda, rhs, &c__1, &c_b42, &c__[js * c_dim1 + 1] + , &c__1); + i__2 = is - 1; + sgemv_("N", &i__2, &mb, &c_b27, &d__[is * d_dim1 + 1], + ldd, rhs, &c__1, &c_b42, &f[js * f_dim1 + 1], + &c__1); + } + if (j < q) { + i__2 = *n - je; + sger_(&mb, &i__2, &c_b42, &rhs[2], &c__1, &b[js + (je + + 1) * b_dim1], ldb, &c__[is + (je + 1) * + c_dim1], ldc); + i__2 = *n - je; + sger_(&mb, &i__2, &c_b42, &rhs[2], &c__1, &e[js + (je + + 1) * e_dim1], lde, &f[is + (je + 1) * + f_dim1], ldf); + } + + } else if (mb == 2 && nb == 2) { + +/* Build an 8-by-8 system Z * x = RHS */ + + slaset_("F", &c__8, &c__8, &c_b56, &c_b56, z__, &c__8); + + z__[0] = a[is + is * a_dim1]; + z__[1] = a[isp1 + is * a_dim1]; + z__[4] = d__[is + is * d_dim1]; + + z__[8] = a[is + isp1 * a_dim1]; + z__[9] = a[isp1 + isp1 * a_dim1]; + z__[12] = d__[is + isp1 * d_dim1]; + z__[13] = d__[isp1 + isp1 * d_dim1]; + + z__[18] = a[is + is * a_dim1]; + z__[19] = a[isp1 + is * a_dim1]; + z__[22] = d__[is + is * d_dim1]; + + z__[26] = a[is + isp1 * a_dim1]; + z__[27] = a[isp1 + isp1 * a_dim1]; + z__[30] = d__[is + isp1 * d_dim1]; + z__[31] = d__[isp1 + isp1 * d_dim1]; + + z__[32] = -b[js + js * b_dim1]; + z__[34] = -b[js + jsp1 * b_dim1]; + z__[36] = -e[js + js * e_dim1]; + z__[38] = -e[js + jsp1 * e_dim1]; + + z__[41] = -b[js + js * b_dim1]; + z__[43] = -b[js + jsp1 * b_dim1]; + z__[45] = -e[js + js * e_dim1]; + z__[47] = -e[js + jsp1 * e_dim1]; + + z__[48] = -b[jsp1 + js * b_dim1]; + z__[50] = -b[jsp1 + jsp1 * b_dim1]; + z__[54] = -e[jsp1 + jsp1 * e_dim1]; + + z__[57] = -b[jsp1 + js * b_dim1]; + z__[59] = -b[jsp1 + jsp1 * b_dim1]; + z__[63] = -e[jsp1 + jsp1 * e_dim1]; + +/* Set up right hand side(s) */ + + k = 1; + ii = mb * nb + 1; + i__2 = nb - 1; + for (jj = 0; jj <= i__2; ++jj) { + scopy_(&mb, &c__[is + (js + jj) * c_dim1], &c__1, & + rhs[k - 1], &c__1); + scopy_(&mb, &f[is + (js + jj) * f_dim1], &c__1, &rhs[ + ii - 1], &c__1); + k += mb; + ii += mb; +/* L80: */ + } + +/* Solve Z * x = RHS */ + + sgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + if (*ijob == 0) { + sgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.f) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + sscal_(m, &scaloc, &c__[k * c_dim1 + 1], & + c__1); + sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L90: */ + } + *scale *= scaloc; + } + } else { + slatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal, + ipiv, jpiv); + } + +/* Unpack solution vector(s) */ + + k = 1; + ii = mb * nb + 1; + i__2 = nb - 1; + for (jj = 0; jj <= i__2; ++jj) { + scopy_(&mb, &rhs[k - 1], &c__1, &c__[is + (js + jj) * + c_dim1], &c__1); + scopy_(&mb, &rhs[ii - 1], &c__1, &f[is + (js + jj) * + f_dim1], &c__1); + k += mb; + ii += mb; +/* L100: */ + } + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (i__ > 1) { + i__2 = is - 1; + sgemm_("N", "N", &i__2, &nb, &mb, &c_b27, &a[is * + a_dim1 + 1], lda, rhs, &mb, &c_b42, &c__[js * + c_dim1 + 1], ldc); + i__2 = is - 1; + sgemm_("N", "N", &i__2, &nb, &mb, &c_b27, &d__[is * + d_dim1 + 1], ldd, rhs, &mb, &c_b42, &f[js * + f_dim1 + 1], ldf); + } + if (j < q) { + k = mb * nb + 1; + i__2 = *n - je; + sgemm_("N", "N", &mb, &i__2, &nb, &c_b42, &rhs[k - 1], + &mb, &b[js + (je + 1) * b_dim1], ldb, &c_b42, + &c__[is + (je + 1) * c_dim1], ldc); + i__2 = *n - je; + sgemm_("N", "N", &mb, &i__2, &nb, &c_b42, &rhs[k - 1], + &mb, &e[js + (je + 1) * e_dim1], lde, &c_b42, + &f[is + (je + 1) * f_dim1], ldf); + } + + } + +/* L110: */ + } +/* L120: */ + } + } else { + +/* Solve (I, J) - subsystem */ +/* A(I, I)**T * R(I, J) + D(I, I)**T * L(J, J) = C(I, J) */ +/* R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) */ +/* for I = 1, 2, ..., P, J = Q, Q - 1, ..., 1 */ + + *scale = 1.f; + scaloc = 1.f; + i__1 = p; + for (i__ = 1; i__ <= i__1; ++i__) { + + is = iwork[i__]; + isp1 = is + 1; + ie = iwork[i__ + 1] - 1; + mb = ie - is + 1; + i__2 = p + 2; + for (j = q; j >= i__2; --j) { + + js = iwork[j]; + jsp1 = js + 1; + je = iwork[j + 1] - 1; + nb = je - js + 1; + zdim = mb * nb << 1; + if (mb == 1 && nb == 1) { + +/* Build a 2-by-2 system Z**T * x = RHS */ + + z__[0] = a[is + is * a_dim1]; + z__[1] = -b[js + js * b_dim1]; + z__[8] = d__[is + is * d_dim1]; + z__[9] = -e[js + js * e_dim1]; + +/* Set up right hand side(s) */ + + rhs[0] = c__[is + js * c_dim1]; + rhs[1] = f[is + js * f_dim1]; + +/* Solve Z**T * x = RHS */ + + sgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + + sgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.f) { + i__3 = *n; + for (k = 1; k <= i__3; ++k) { + sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L130: */ + } + *scale *= scaloc; + } + +/* Unpack solution vector(s) */ + + c__[is + js * c_dim1] = rhs[0]; + f[is + js * f_dim1] = rhs[1]; + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (j > p + 2) { + alpha = rhs[0]; + i__3 = js - 1; + saxpy_(&i__3, &alpha, &b[js * b_dim1 + 1], &c__1, &f[ + is + f_dim1], ldf); + alpha = rhs[1]; + i__3 = js - 1; + saxpy_(&i__3, &alpha, &e[js * e_dim1 + 1], &c__1, &f[ + is + f_dim1], ldf); + } + if (i__ < p) { + alpha = -rhs[0]; + i__3 = *m - ie; + saxpy_(&i__3, &alpha, &a[is + (ie + 1) * a_dim1], lda, + &c__[ie + 1 + js * c_dim1], &c__1); + alpha = -rhs[1]; + i__3 = *m - ie; + saxpy_(&i__3, &alpha, &d__[is + (ie + 1) * d_dim1], + ldd, &c__[ie + 1 + js * c_dim1], &c__1); + } + + } else if (mb == 1 && nb == 2) { + +/* Build a 4-by-4 system Z**T * x = RHS */ + + z__[0] = a[is + is * a_dim1]; + z__[1] = 0.f; + z__[2] = -b[js + js * b_dim1]; + z__[3] = -b[jsp1 + js * b_dim1]; + + z__[8] = 0.f; + z__[9] = a[is + is * a_dim1]; + z__[10] = -b[js + jsp1 * b_dim1]; + z__[11] = -b[jsp1 + jsp1 * b_dim1]; + + z__[16] = d__[is + is * d_dim1]; + z__[17] = 0.f; + z__[18] = -e[js + js * e_dim1]; + z__[19] = 0.f; + + z__[24] = 0.f; + z__[25] = d__[is + is * d_dim1]; + z__[26] = -e[js + jsp1 * e_dim1]; + z__[27] = -e[jsp1 + jsp1 * e_dim1]; + +/* Set up right hand side(s) */ + + rhs[0] = c__[is + js * c_dim1]; + rhs[1] = c__[is + jsp1 * c_dim1]; + rhs[2] = f[is + js * f_dim1]; + rhs[3] = f[is + jsp1 * f_dim1]; + +/* Solve Z**T * x = RHS */ + + sgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + sgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.f) { + i__3 = *n; + for (k = 1; k <= i__3; ++k) { + sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L140: */ + } + *scale *= scaloc; + } + +/* Unpack solution vector(s) */ + + c__[is + js * c_dim1] = rhs[0]; + c__[is + jsp1 * c_dim1] = rhs[1]; + f[is + js * f_dim1] = rhs[2]; + f[is + jsp1 * f_dim1] = rhs[3]; + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (j > p + 2) { + i__3 = js - 1; + saxpy_(&i__3, rhs, &b[js * b_dim1 + 1], &c__1, &f[is + + f_dim1], ldf); + i__3 = js - 1; + saxpy_(&i__3, &rhs[1], &b[jsp1 * b_dim1 + 1], &c__1, & + f[is + f_dim1], ldf); + i__3 = js - 1; + saxpy_(&i__3, &rhs[2], &e[js * e_dim1 + 1], &c__1, &f[ + is + f_dim1], ldf); + i__3 = js - 1; + saxpy_(&i__3, &rhs[3], &e[jsp1 * e_dim1 + 1], &c__1, & + f[is + f_dim1], ldf); + } + if (i__ < p) { + i__3 = *m - ie; + sger_(&i__3, &nb, &c_b27, &a[is + (ie + 1) * a_dim1], + lda, rhs, &c__1, &c__[ie + 1 + js * c_dim1], + ldc); + i__3 = *m - ie; + sger_(&i__3, &nb, &c_b27, &d__[is + (ie + 1) * d_dim1] + , ldd, &rhs[2], &c__1, &c__[ie + 1 + js * + c_dim1], ldc); + } + + } else if (mb == 2 && nb == 1) { + +/* Build a 4-by-4 system Z**T * x = RHS */ + + z__[0] = a[is + is * a_dim1]; + z__[1] = a[is + isp1 * a_dim1]; + z__[2] = -b[js + js * b_dim1]; + z__[3] = 0.f; + + z__[8] = a[isp1 + is * a_dim1]; + z__[9] = a[isp1 + isp1 * a_dim1]; + z__[10] = 0.f; + z__[11] = -b[js + js * b_dim1]; + + z__[16] = d__[is + is * d_dim1]; + z__[17] = d__[is + isp1 * d_dim1]; + z__[18] = -e[js + js * e_dim1]; + z__[19] = 0.f; + + z__[24] = 0.f; + z__[25] = d__[isp1 + isp1 * d_dim1]; + z__[26] = 0.f; + z__[27] = -e[js + js * e_dim1]; + +/* Set up right hand side(s) */ + + rhs[0] = c__[is + js * c_dim1]; + rhs[1] = c__[isp1 + js * c_dim1]; + rhs[2] = f[is + js * f_dim1]; + rhs[3] = f[isp1 + js * f_dim1]; + +/* Solve Z**T * x = RHS */ + + sgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + + sgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.f) { + i__3 = *n; + for (k = 1; k <= i__3; ++k) { + sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L150: */ + } + *scale *= scaloc; + } + +/* Unpack solution vector(s) */ + + c__[is + js * c_dim1] = rhs[0]; + c__[isp1 + js * c_dim1] = rhs[1]; + f[is + js * f_dim1] = rhs[2]; + f[isp1 + js * f_dim1] = rhs[3]; + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (j > p + 2) { + i__3 = js - 1; + sger_(&mb, &i__3, &c_b42, rhs, &c__1, &b[js * b_dim1 + + 1], &c__1, &f[is + f_dim1], ldf); + i__3 = js - 1; + sger_(&mb, &i__3, &c_b42, &rhs[2], &c__1, &e[js * + e_dim1 + 1], &c__1, &f[is + f_dim1], ldf); + } + if (i__ < p) { + i__3 = *m - ie; + sgemv_("T", &mb, &i__3, &c_b27, &a[is + (ie + 1) * + a_dim1], lda, rhs, &c__1, &c_b42, &c__[ie + 1 + + js * c_dim1], &c__1); + i__3 = *m - ie; + sgemv_("T", &mb, &i__3, &c_b27, &d__[is + (ie + 1) * + d_dim1], ldd, &rhs[2], &c__1, &c_b42, &c__[ie + + 1 + js * c_dim1], &c__1); + } + + } else if (mb == 2 && nb == 2) { + +/* Build an 8-by-8 system Z**T * x = RHS */ + + slaset_("F", &c__8, &c__8, &c_b56, &c_b56, z__, &c__8); + + z__[0] = a[is + is * a_dim1]; + z__[1] = a[is + isp1 * a_dim1]; + z__[4] = -b[js + js * b_dim1]; + z__[6] = -b[jsp1 + js * b_dim1]; + + z__[8] = a[isp1 + is * a_dim1]; + z__[9] = a[isp1 + isp1 * a_dim1]; + z__[13] = -b[js + js * b_dim1]; + z__[15] = -b[jsp1 + js * b_dim1]; + + z__[18] = a[is + is * a_dim1]; + z__[19] = a[is + isp1 * a_dim1]; + z__[20] = -b[js + jsp1 * b_dim1]; + z__[22] = -b[jsp1 + jsp1 * b_dim1]; + + z__[26] = a[isp1 + is * a_dim1]; + z__[27] = a[isp1 + isp1 * a_dim1]; + z__[29] = -b[js + jsp1 * b_dim1]; + z__[31] = -b[jsp1 + jsp1 * b_dim1]; + + z__[32] = d__[is + is * d_dim1]; + z__[33] = d__[is + isp1 * d_dim1]; + z__[36] = -e[js + js * e_dim1]; + + z__[41] = d__[isp1 + isp1 * d_dim1]; + z__[45] = -e[js + js * e_dim1]; + + z__[50] = d__[is + is * d_dim1]; + z__[51] = d__[is + isp1 * d_dim1]; + z__[52] = -e[js + jsp1 * e_dim1]; + z__[54] = -e[jsp1 + jsp1 * e_dim1]; + + z__[59] = d__[isp1 + isp1 * d_dim1]; + z__[61] = -e[js + jsp1 * e_dim1]; + z__[63] = -e[jsp1 + jsp1 * e_dim1]; + +/* Set up right hand side(s) */ + + k = 1; + ii = mb * nb + 1; + i__3 = nb - 1; + for (jj = 0; jj <= i__3; ++jj) { + scopy_(&mb, &c__[is + (js + jj) * c_dim1], &c__1, & + rhs[k - 1], &c__1); + scopy_(&mb, &f[is + (js + jj) * f_dim1], &c__1, &rhs[ + ii - 1], &c__1); + k += mb; + ii += mb; +/* L160: */ + } + + +/* Solve Z**T * x = RHS */ + + sgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + + sgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.f) { + i__3 = *n; + for (k = 1; k <= i__3; ++k) { + sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L170: */ + } + *scale *= scaloc; + } + +/* Unpack solution vector(s) */ + + k = 1; + ii = mb * nb + 1; + i__3 = nb - 1; + for (jj = 0; jj <= i__3; ++jj) { + scopy_(&mb, &rhs[k - 1], &c__1, &c__[is + (js + jj) * + c_dim1], &c__1); + scopy_(&mb, &rhs[ii - 1], &c__1, &f[is + (js + jj) * + f_dim1], &c__1); + k += mb; + ii += mb; +/* L180: */ + } + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (j > p + 2) { + i__3 = js - 1; + sgemm_("N", "T", &mb, &i__3, &nb, &c_b42, &c__[is + + js * c_dim1], ldc, &b[js * b_dim1 + 1], ldb, & + c_b42, &f[is + f_dim1], ldf); + i__3 = js - 1; + sgemm_("N", "T", &mb, &i__3, &nb, &c_b42, &f[is + js * + f_dim1], ldf, &e[js * e_dim1 + 1], lde, & + c_b42, &f[is + f_dim1], ldf); + } + if (i__ < p) { + i__3 = *m - ie; + sgemm_("T", "N", &i__3, &nb, &mb, &c_b27, &a[is + (ie + + 1) * a_dim1], lda, &c__[is + js * c_dim1], + ldc, &c_b42, &c__[ie + 1 + js * c_dim1], ldc); + i__3 = *m - ie; + sgemm_("T", "N", &i__3, &nb, &mb, &c_b27, &d__[is + ( + ie + 1) * d_dim1], ldd, &f[is + js * f_dim1], + ldf, &c_b42, &c__[ie + 1 + js * c_dim1], ldc); + } + + } + +/* L190: */ + } +/* L200: */ + } + + } + return 0; + +/* End of STGSY2 */ + +} /* stgsy2_ */ + diff --git a/lapack-netlib/SRC/stgsyl.c b/lapack-netlib/SRC/stgsyl.c new file mode 100644 index 000000000..90bab1067 --- /dev/null +++ b/lapack-netlib/SRC/stgsyl.c @@ -0,0 +1,1177 @@ +/* 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 STGSYL */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STGSYL + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, */ +/* LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, */ +/* IWORK, INFO ) */ + +/* CHARACTER TRANS */ +/* INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, */ +/* $ LWORK, M, N */ +/* REAL DIF, SCALE */ +/* INTEGER IWORK( * ) */ +/* REAL A( LDA, * ), B( LDB, * ), C( LDC, * ), */ +/* $ D( LDD, * ), E( LDE, * ), F( LDF, * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STGSYL solves the generalized Sylvester equation: */ +/* > */ +/* > A * R - L * B = scale * C (1) */ +/* > D * R - L * E = scale * F */ +/* > */ +/* > where R and L are unknown m-by-n matrices, (A, D), (B, E) and */ +/* > (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n, */ +/* > respectively, with real entries. (A, D) and (B, E) must be in */ +/* > generalized (real) Schur canonical form, i.e. A, B are upper quasi */ +/* > triangular and D, E are upper triangular. */ +/* > */ +/* > The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output */ +/* > scaling factor chosen to avoid overflow. */ +/* > */ +/* > In matrix notation (1) is equivalent to solve Zx = scale b, where */ +/* > Z is defined as */ +/* > */ +/* > Z = [ kron(In, A) -kron(B**T, Im) ] (2) */ +/* > [ kron(In, D) -kron(E**T, Im) ]. */ +/* > */ +/* > Here Ik is the identity matrix of size k and X**T is the transpose of */ +/* > X. kron(X, Y) is the Kronecker product between the matrices X and Y. */ +/* > */ +/* > If TRANS = 'T', STGSYL solves the transposed system Z**T*y = scale*b, */ +/* > which is equivalent to solve for R and L in */ +/* > */ +/* > A**T * R + D**T * L = scale * C (3) */ +/* > R * B**T + L * E**T = scale * -F */ +/* > */ +/* > This case (TRANS = 'T') is used to compute an one-norm-based estimate */ +/* > of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D) */ +/* > and (B,E), using SLACON. */ +/* > */ +/* > If IJOB >= 1, STGSYL computes a Frobenius norm-based estimate */ +/* > of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the */ +/* > reciprocal of the smallest singular value of Z. See [1-2] for more */ +/* > information. */ +/* > */ +/* > This is a level 3 BLAS algorithm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': solve the generalized Sylvester equation (1). */ +/* > = 'T': solve the 'transposed' system (3). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IJOB */ +/* > \verbatim */ +/* > IJOB is INTEGER */ +/* > Specifies what kind of functionality to be performed. */ +/* > = 0: solve (1) only. */ +/* > = 1: The functionality of 0 and 3. */ +/* > = 2: The functionality of 0 and 4. */ +/* > = 3: Only an estimate of Dif[(A,D), (B,E)] is computed. */ +/* > (look ahead strategy IJOB = 1 is used). */ +/* > = 4: Only an estimate of Dif[(A,D), (B,E)] is computed. */ +/* > ( SGECON on sub-systems is used ). */ +/* > Not referenced if TRANS = 'T'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The order of the matrices A and D, and the row dimension of */ +/* > the matrices C, F, R and L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices B and E, and the column dimension */ +/* > of the matrices C, F, R and L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA, M) */ +/* > The upper quasi triangular 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 REAL array, dimension (LDB, N) */ +/* > The upper quasi triangular matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1, N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (LDC, N) */ +/* > On entry, C contains the right-hand-side of the first matrix */ +/* > equation in (1) or (3). */ +/* > On exit, if IJOB = 0, 1 or 2, C has been overwritten by */ +/* > the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R, */ +/* > the solution achieved during the computation of the */ +/* > Dif-estimate. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (LDD, M) */ +/* > The upper triangular matrix D. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDD */ +/* > \verbatim */ +/* > LDD is INTEGER */ +/* > The leading dimension of the array D. LDD >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (LDE, N) */ +/* > The upper triangular matrix E. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDE */ +/* > \verbatim */ +/* > LDE is INTEGER */ +/* > The leading dimension of the array E. LDE >= f2cmax(1, N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] F */ +/* > \verbatim */ +/* > F is REAL array, dimension (LDF, N) */ +/* > On entry, F contains the right-hand-side of the second matrix */ +/* > equation in (1) or (3). */ +/* > On exit, if IJOB = 0, 1 or 2, F has been overwritten by */ +/* > the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L, */ +/* > the solution achieved during the computation of the */ +/* > Dif-estimate. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDF */ +/* > \verbatim */ +/* > LDF is INTEGER */ +/* > The leading dimension of the array F. LDF >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DIF */ +/* > \verbatim */ +/* > DIF is REAL */ +/* > On exit DIF is the reciprocal of a lower bound of the */ +/* > reciprocal of the Dif-function, i.e. DIF is an upper bound of */ +/* > Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2). */ +/* > IF IJOB = 0 or TRANS = 'T', DIF is not touched. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE */ +/* > \verbatim */ +/* > SCALE is REAL */ +/* > On exit SCALE is the scaling factor in (1) or (3). */ +/* > If 0 < SCALE < 1, C and F hold the solutions R and L, resp., */ +/* > to a slightly perturbed system but the input matrices A, B, D */ +/* > and E have not been changed. If SCALE = 0, C and F hold the */ +/* > solutions R and L, respectively, to the homogeneous system */ +/* > with C = F = 0. Normally, SCALE = 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK > = 1. */ +/* > If IJOB = 1 or 2 and TRANS = 'N', LWORK >= f2cmax(1,2*M*N). */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (M+N+6) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > =0: successful exit */ +/* > <0: If INFO = -i, the i-th argument had an illegal value. */ +/* > >0: (A, D) and (B, E) have common or close eigenvalues. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* > Umea University, S-901 87 Umea, Sweden. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > \verbatim */ +/* > */ +/* > [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */ +/* > for Solving the Generalized Sylvester Equation and Estimating the */ +/* > Separation between Regular Matrix Pairs, Report UMINF - 93.23, */ +/* > Department of Computing Science, Umea University, S-901 87 Umea, */ +/* > Sweden, December 1993, Revised April 1994, Also as LAPACK Working */ +/* > Note 75. To appear in ACM Trans. on Math. Software, Vol 22, */ +/* > No 1, 1996. */ +/* > */ +/* > [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester */ +/* > Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal. */ +/* > Appl., 15(4):1045-1060, 1994 */ +/* > */ +/* > [3] B. Kagstrom and L. 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. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int stgsyl_(char *trans, integer *ijob, integer *m, integer * + n, real *a, integer *lda, real *b, integer *ldb, real *c__, integer * + ldc, real *d__, integer *ldd, real *e, integer *lde, real *f, integer + *ldf, real *scale, real *dif, real *work, integer *lwork, integer * + iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1, + d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3, + i__4; + + /* Local variables */ + real dsum; + integer ppqq, i__, j, k, p, q; + extern logical lsame_(char *, char *); + integer ifunc; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + integer linfo; + extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *); + integer lwmin; + real scale2; + integer ie, je, mb, nb; + real dscale; + integer is, js; + extern /* Subroutine */ int stgsy2_(char *, integer *, integer *, integer + *, real *, integer *, real *, integer *, real *, integer *, real * + , integer *, real *, integer *, real *, integer *, real *, real *, + real *, integer *, integer *, integer *); + integer pq; + real scaloc; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, + integer *, real *, integer *), slaset_(char *, integer *, + integer *, real *, real *, real *, integer *); + integer iround; + logical notran; + integer isolve; + logical lquery; + + +/* -- 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 */ + + +/* ===================================================================== */ +/* Replaced various illegal calls to SCOPY by calls to SLASET. */ +/* Sven Hammarling, 1/5/02. */ + + +/* Decode and test input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + d_dim1 = *ldd; + d_offset = 1 + d_dim1 * 1; + d__ -= d_offset; + e_dim1 = *lde; + e_offset = 1 + e_dim1 * 1; + e -= e_offset; + f_dim1 = *ldf; + f_offset = 1 + f_dim1 * 1; + f -= f_offset; + --work; + --iwork; + + /* Function Body */ + *info = 0; + notran = lsame_(trans, "N"); + lquery = *lwork == -1; + + if (! notran && ! lsame_(trans, "T")) { + *info = -1; + } else if (notran) { + if (*ijob < 0 || *ijob > 4) { + *info = -2; + } + } + if (*info == 0) { + if (*m <= 0) { + *info = -3; + } else if (*n <= 0) { + *info = -4; + } else if (*lda < f2cmax(1,*m)) { + *info = -6; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else if (*ldc < f2cmax(1,*m)) { + *info = -10; + } else if (*ldd < f2cmax(1,*m)) { + *info = -12; + } else if (*lde < f2cmax(1,*n)) { + *info = -14; + } else if (*ldf < f2cmax(1,*m)) { + *info = -16; + } + } + + if (*info == 0) { + if (notran) { + if (*ijob == 1 || *ijob == 2) { +/* Computing MAX */ + i__1 = 1, i__2 = (*m << 1) * *n; + lwmin = f2cmax(i__1,i__2); + } else { + lwmin = 1; + } + } else { + lwmin = 1; + } + work[1] = (real) lwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -20; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("STGSYL", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + *scale = 1.f; + if (notran) { + if (*ijob != 0) { + *dif = 0.f; + } + } + return 0; + } + +/* Determine optimal block sizes MB and NB */ + + mb = ilaenv_(&c__2, "STGSYL", trans, m, n, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb = ilaenv_(&c__5, "STGSYL", trans, m, n, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + + isolve = 1; + ifunc = 0; + if (notran) { + if (*ijob >= 3) { + ifunc = *ijob - 2; + slaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc) + ; + slaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf); + } else if (*ijob >= 1 && notran) { + isolve = 2; + } + } + + if (mb <= 1 && nb <= 1 || mb >= *m && nb >= *n) { + + i__1 = isolve; + for (iround = 1; iround <= i__1; ++iround) { + +/* Use unblocked Level 2 solver */ + + dscale = 0.f; + dsum = 1.f; + pq = 0; + stgsy2_(trans, &ifunc, m, n, &a[a_offset], lda, &b[b_offset], ldb, + &c__[c_offset], ldc, &d__[d_offset], ldd, &e[e_offset], + lde, &f[f_offset], ldf, scale, &dsum, &dscale, &iwork[1], + &pq, info); + if (dscale != 0.f) { + if (*ijob == 1 || *ijob == 3) { + *dif = sqrt((real) ((*m << 1) * *n)) / (dscale * sqrt( + dsum)); + } else { + *dif = sqrt((real) pq) / (dscale * sqrt(dsum)); + } + } + + if (isolve == 2 && iround == 1) { + if (notran) { + ifunc = *ijob; + } + scale2 = *scale; + slacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m); + slacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m); + slaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc); + slaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf); + } else if (isolve == 2 && iround == 2) { + slacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc); + slacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf); + *scale = scale2; + } +/* L30: */ + } + + return 0; + } + +/* Determine block structure of A */ + + p = 0; + i__ = 1; +L40: + if (i__ > *m) { + goto L50; + } + ++p; + iwork[p] = i__; + i__ += mb; + if (i__ >= *m) { + goto L50; + } + if (a[i__ + (i__ - 1) * a_dim1] != 0.f) { + ++i__; + } + goto L40; +L50: + + iwork[p + 1] = *m + 1; + if (iwork[p] == iwork[p + 1]) { + --p; + } + +/* Determine block structure of B */ + + q = p + 1; + j = 1; +L60: + if (j > *n) { + goto L70; + } + ++q; + iwork[q] = j; + j += nb; + if (j >= *n) { + goto L70; + } + if (b[j + (j - 1) * b_dim1] != 0.f) { + ++j; + } + goto L60; +L70: + + iwork[q + 1] = *n + 1; + if (iwork[q] == iwork[q + 1]) { + --q; + } + + if (notran) { + + i__1 = isolve; + for (iround = 1; iround <= i__1; ++iround) { + +/* Solve (I, J)-subsystem */ +/* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */ +/* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */ +/* for I = P, P - 1,..., 1; J = 1, 2,..., Q */ + + dscale = 0.f; + dsum = 1.f; + pq = 0; + *scale = 1.f; + i__2 = q; + for (j = p + 2; j <= i__2; ++j) { + js = iwork[j]; + je = iwork[j + 1] - 1; + nb = je - js + 1; + for (i__ = p; i__ >= 1; --i__) { + is = iwork[i__]; + ie = iwork[i__ + 1] - 1; + mb = ie - is + 1; + ppqq = 0; + stgsy2_(trans, &ifunc, &mb, &nb, &a[is + is * a_dim1], + lda, &b[js + js * b_dim1], ldb, &c__[is + js * + c_dim1], ldc, &d__[is + is * d_dim1], ldd, &e[js + + js * e_dim1], lde, &f[is + js * f_dim1], ldf, & + scaloc, &dsum, &dscale, &iwork[q + 2], &ppqq, & + linfo); + if (linfo > 0) { + *info = linfo; + } + + pq += ppqq; + if (scaloc != 1.f) { + i__3 = js - 1; + for (k = 1; k <= i__3; ++k) { + sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L80: */ + } + i__3 = je; + for (k = js; k <= i__3; ++k) { + i__4 = is - 1; + sscal_(&i__4, &scaloc, &c__[k * c_dim1 + 1], & + c__1); + i__4 = is - 1; + sscal_(&i__4, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L90: */ + } + i__3 = je; + for (k = js; k <= i__3; ++k) { + i__4 = *m - ie; + sscal_(&i__4, &scaloc, &c__[ie + 1 + k * c_dim1], + &c__1); + i__4 = *m - ie; + sscal_(&i__4, &scaloc, &f[ie + 1 + k * f_dim1], & + c__1); +/* L100: */ + } + i__3 = *n; + for (k = je + 1; k <= i__3; ++k) { + sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L110: */ + } + *scale *= scaloc; + } + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (i__ > 1) { + i__3 = is - 1; + sgemm_("N", "N", &i__3, &nb, &mb, &c_b51, &a[is * + a_dim1 + 1], lda, &c__[is + js * c_dim1], ldc, + &c_b52, &c__[js * c_dim1 + 1], ldc); + i__3 = is - 1; + sgemm_("N", "N", &i__3, &nb, &mb, &c_b51, &d__[is * + d_dim1 + 1], ldd, &c__[is + js * c_dim1], ldc, + &c_b52, &f[js * f_dim1 + 1], ldf); + } + if (j < q) { + i__3 = *n - je; + sgemm_("N", "N", &mb, &i__3, &nb, &c_b52, &f[is + js * + f_dim1], ldf, &b[js + (je + 1) * b_dim1], + ldb, &c_b52, &c__[is + (je + 1) * c_dim1], + ldc); + i__3 = *n - je; + sgemm_("N", "N", &mb, &i__3, &nb, &c_b52, &f[is + js * + f_dim1], ldf, &e[js + (je + 1) * e_dim1], + lde, &c_b52, &f[is + (je + 1) * f_dim1], ldf); + } +/* L120: */ + } +/* L130: */ + } + if (dscale != 0.f) { + if (*ijob == 1 || *ijob == 3) { + *dif = sqrt((real) ((*m << 1) * *n)) / (dscale * sqrt( + dsum)); + } else { + *dif = sqrt((real) pq) / (dscale * sqrt(dsum)); + } + } + if (isolve == 2 && iround == 1) { + if (notran) { + ifunc = *ijob; + } + scale2 = *scale; + slacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m); + slacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m); + slaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc); + slaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf); + } else if (isolve == 2 && iround == 2) { + slacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc); + slacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf); + *scale = scale2; + } +/* L150: */ + } + + } else { + +/* Solve transposed (I, J)-subsystem */ +/* A(I, I)**T * R(I, J) + D(I, I)**T * L(I, J) = C(I, J) */ +/* R(I, J) * B(J, J)**T + L(I, J) * E(J, J)**T = -F(I, J) */ +/* for I = 1,2,..., P; J = Q, Q-1,..., 1 */ + + *scale = 1.f; + i__1 = p; + for (i__ = 1; i__ <= i__1; ++i__) { + is = iwork[i__]; + ie = iwork[i__ + 1] - 1; + mb = ie - is + 1; + i__2 = p + 2; + for (j = q; j >= i__2; --j) { + js = iwork[j]; + je = iwork[j + 1] - 1; + nb = je - js + 1; + stgsy2_(trans, &ifunc, &mb, &nb, &a[is + is * a_dim1], lda, & + b[js + js * b_dim1], ldb, &c__[is + js * c_dim1], ldc, + &d__[is + is * d_dim1], ldd, &e[js + js * e_dim1], + lde, &f[is + js * f_dim1], ldf, &scaloc, &dsum, & + dscale, &iwork[q + 2], &ppqq, &linfo); + if (linfo > 0) { + *info = linfo; + } + if (scaloc != 1.f) { + i__3 = js - 1; + for (k = 1; k <= i__3; ++k) { + sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L160: */ + } + i__3 = je; + for (k = js; k <= i__3; ++k) { + i__4 = is - 1; + sscal_(&i__4, &scaloc, &c__[k * c_dim1 + 1], &c__1); + i__4 = is - 1; + sscal_(&i__4, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L170: */ + } + i__3 = je; + for (k = js; k <= i__3; ++k) { + i__4 = *m - ie; + sscal_(&i__4, &scaloc, &c__[ie + 1 + k * c_dim1], & + c__1); + i__4 = *m - ie; + sscal_(&i__4, &scaloc, &f[ie + 1 + k * f_dim1], &c__1) + ; +/* L180: */ + } + i__3 = *n; + for (k = je + 1; k <= i__3; ++k) { + sscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + sscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L190: */ + } + *scale *= scaloc; + } + +/* Substitute R(I, J) and L(I, J) into remaining equation. */ + + if (j > p + 2) { + i__3 = js - 1; + sgemm_("N", "T", &mb, &i__3, &nb, &c_b52, &c__[is + js * + c_dim1], ldc, &b[js * b_dim1 + 1], ldb, &c_b52, & + f[is + f_dim1], ldf); + i__3 = js - 1; + sgemm_("N", "T", &mb, &i__3, &nb, &c_b52, &f[is + js * + f_dim1], ldf, &e[js * e_dim1 + 1], lde, &c_b52, & + f[is + f_dim1], ldf); + } + if (i__ < p) { + i__3 = *m - ie; + sgemm_("T", "N", &i__3, &nb, &mb, &c_b51, &a[is + (ie + 1) + * a_dim1], lda, &c__[is + js * c_dim1], ldc, & + c_b52, &c__[ie + 1 + js * c_dim1], ldc); + i__3 = *m - ie; + sgemm_("T", "N", &i__3, &nb, &mb, &c_b51, &d__[is + (ie + + 1) * d_dim1], ldd, &f[is + js * f_dim1], ldf, & + c_b52, &c__[ie + 1 + js * c_dim1], ldc); + } +/* L200: */ + } +/* L210: */ + } + + } + + work[1] = (real) lwmin; + + return 0; + +/* End of STGSYL */ + +} /* stgsyl_ */ + diff --git a/lapack-netlib/SRC/stpcon.c b/lapack-netlib/SRC/stpcon.c new file mode 100644 index 000000000..ffe6739e2 --- /dev/null +++ b/lapack-netlib/SRC/stpcon.c @@ -0,0 +1,662 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#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 STPCON */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STPCON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, */ +/* INFO ) */ + +/* CHARACTER DIAG, NORM, UPLO */ +/* INTEGER INFO, N */ +/* REAL RCOND */ +/* INTEGER IWORK( * ) */ +/* REAL AP( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STPCON estimates the reciprocal of the condition number of a packed */ +/* > triangular matrix A, in either the 1-norm or the infinity-norm. */ +/* > */ +/* > The norm of A is computed and an estimate is obtained for */ +/* > norm(inv(A)), then the reciprocal of the condition number is */ +/* > computed as */ +/* > RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies whether the 1-norm condition number or the */ +/* > infinity-norm condition number is required: */ +/* > = '1' or 'O': 1-norm; */ +/* > = 'I': Infinity-norm. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is REAL 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. */ +/* > If DIAG = 'U', the diagonal elements of A are not referenced */ +/* > and are assumed to be 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > The reciprocal of the condition number of the matrix A, */ +/* > computed as RCOND = 1/(norm(A) * norm(inv(A))). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int stpcon_(char *norm, char *uplo, char *diag, integer *n, + real *ap, real *rcond, real *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer i__1; + real r__1; + + /* Local variables */ + integer kase, kase1; + real scale; + extern logical lsame_(char *, char *); + integer isave[3]; + real anorm; + extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *); + logical upper; + real xnorm; + extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *, + real *, integer *, integer *); + integer ix; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer isamax_(integer *, real *, integer *); + real ainvnm; + logical onenrm; + extern real slantp_(char *, char *, char *, integer *, real *, real *); + char normin[1]; + extern /* Subroutine */ int slatps_(char *, char *, char *, char *, + integer *, real *, real *, real *, real *, integer *); + real smlnum; + logical nounit; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --iwork; + --work; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); + nounit = lsame_(diag, "N"); + + if (! onenrm && ! lsame_(norm, "I")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STPCON", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *rcond = 1.f; + return 0; + } + + *rcond = 0.f; + smlnum = slamch_("Safe minimum") * (real) f2cmax(1,*n); + +/* Compute the norm of the triangular matrix A. */ + + anorm = slantp_(norm, uplo, diag, n, &ap[1], &work[1]); + +/* Continue only if ANORM > 0. */ + + if (anorm > 0.f) { + +/* Estimate the norm of the inverse of A. */ + + ainvnm = 0.f; + *(unsigned char *)normin = 'N'; + if (onenrm) { + kase1 = 1; + } else { + kase1 = 2; + } + kase = 0; +L10: + slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == kase1) { + +/* Multiply by inv(A). */ + + slatps_(uplo, "No transpose", diag, normin, n, &ap[1], &work[ + 1], &scale, &work[(*n << 1) + 1], info); + } else { + +/* Multiply by inv(A**T). */ + + slatps_(uplo, "Transpose", diag, normin, n, &ap[1], &work[1], + &scale, &work[(*n << 1) + 1], info); + } + *(unsigned char *)normin = 'Y'; + +/* Multiply by 1/SCALE if doing so will not cause overflow. */ + + if (scale != 1.f) { + ix = isamax_(n, &work[1], &c__1); + xnorm = (r__1 = work[ix], abs(r__1)); + if (scale < xnorm * smlnum || scale == 0.f) { + goto L20; + } + srscl_(n, &scale, &work[1], &c__1); + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.f) { + *rcond = 1.f / anorm / ainvnm; + } + } + +L20: + return 0; + +/* End of STPCON */ + +} /* stpcon_ */ + diff --git a/lapack-netlib/SRC/stplqt.c b/lapack-netlib/SRC/stplqt.c new file mode 100644 index 000000000..f660e670d --- /dev/null +++ b/lapack-netlib/SRC/stplqt.c @@ -0,0 +1,681 @@ +/* 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 STPLQT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTPQRT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, */ +/* INFO ) */ + +/* INTEGER INFO, LDA, LDB, LDT, N, M, L, MB */ +/* REAL A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTPLQT computes a blocked LQ factorization of a real */ +/* > "triangular-pentagonal" matrix C, which is composed of a */ +/* > triangular block A and pentagonal block B, using the compact */ +/* > WY representation for Q. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix B, and the order of the */ +/* > triangular matrix A. */ +/* > M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix B. */ +/* > N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The number of rows of the lower trapezoidal part of B. */ +/* > MIN(M,N) >= L >= 0. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MB */ +/* > \verbatim */ +/* > MB is INTEGER */ +/* > The block size to be used in the blocked QR. M >= MB >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,M) */ +/* > On entry, the lower triangular M-by-M matrix A. */ +/* > On exit, the elements on and below the diagonal of the array */ +/* > contain the lower triangular matrix L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,N) */ +/* > On entry, the pentagonal M-by-N matrix B. The first N-L columns */ +/* > are rectangular, and the last L columns are lower trapezoidal. */ +/* > On exit, B contains the pentagonal matrix V. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is REAL array, dimension (LDT,N) */ +/* > The lower triangular block reflectors stored in compact form */ +/* > as a sequence of upper triangular blocks. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= MB. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MB*M) */ +/* > \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 doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The input matrix C is a M-by-(M+N) matrix */ +/* > */ +/* > C = [ A ] [ B ] */ +/* > */ +/* > */ +/* > where A is an lower triangular M-by-M matrix, and B is M-by-N pentagonal */ +/* > matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L */ +/* > upper trapezoidal matrix B2: */ +/* > [ B ] = [ B1 ] [ B2 ] */ +/* > [ B1 ] <- M-by-(N-L) rectangular */ +/* > [ B2 ] <- M-by-L lower trapezoidal. */ +/* > */ +/* > The lower trapezoidal matrix B2 consists of the first L columns of a */ +/* > M-by-M lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0, */ +/* > B is rectangular M-by-N; if M=L=N, B is lower triangular. */ +/* > */ +/* > The matrix W stores the elementary reflectors H(i) in the i-th row */ +/* > above the diagonal (of A) in the M-by-(M+N) input matrix C */ +/* > [ C ] = [ A ] [ B ] */ +/* > [ A ] <- lower triangular M-by-M */ +/* > [ B ] <- M-by-N pentagonal */ +/* > */ +/* > so that W can be represented as */ +/* > [ W ] = [ I ] [ V ] */ +/* > [ I ] <- identity, M-by-M */ +/* > [ V ] <- M-by-N, same form as B. */ +/* > */ +/* > Thus, all of information needed for W is contained on exit in B, which */ +/* > we call V above. Note that V has the same form as B; that is, */ +/* > [ V ] = [ V1 ] [ V2 ] */ +/* > [ V1 ] <- M-by-(N-L) rectangular */ +/* > [ V2 ] <- M-by-L lower trapezoidal. */ +/* > */ +/* > The rows of V represent the vectors which define the H(i)'s. */ +/* > */ +/* > The number of blocks is B = ceiling(M/MB), where each */ +/* > block is of order MB except for the last block, which is of order */ +/* > IB = M - (M-1)*MB. For each of the B blocks, a upper triangular block */ +/* > reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB */ +/* > for the last block) T's are stored in the MB-by-N matrix T as */ +/* > */ +/* > T = [T1 T2 ... TB]. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int stplqt_(integer *m, integer *n, integer *l, integer *mb, + real *a, integer *lda, real *b, integer *ldb, real *t, integer *ldt, + real *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, t_dim1, t_offset, i__1, i__2, + i__3, i__4; + + /* Local variables */ + integer i__, iinfo, ib, lb, nb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), stprfb_( + char *, char *, char *, char *, integer *, integer *, integer *, + integer *, real *, integer *, real *, integer *, real *, integer * + , real *, integer *, real *, integer *), stplqt2_(integer *, integer *, integer *, real *, + integer *, real *, integer *, real *, integer *, integer *); + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* 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; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*l < 0 || *l > f2cmin(*m,*n) && f2cmin(*m,*n) >= 0) { + *info = -3; + } else if (*mb < 1 || *mb > *m && *m > 0) { + *info = -4; + } else if (*lda < f2cmax(1,*m)) { + *info = -6; + } else if (*ldb < f2cmax(1,*m)) { + *info = -8; + } else if (*ldt < *mb) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STPLQT", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + + i__1 = *m; + i__2 = *mb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + +/* Compute the QR factorization of the current block */ + +/* Computing MIN */ + i__3 = *m - i__ + 1; + ib = f2cmin(i__3,*mb); +/* Computing MIN */ + i__3 = *n - *l + i__ + ib - 1; + nb = f2cmin(i__3,*n); + if (i__ >= *l) { + lb = 0; + } else { + lb = nb - *n + *l - i__ + 1; + } + + stplqt2_(&ib, &nb, &lb, &a[i__ + i__ * a_dim1], lda, &b[i__ + b_dim1], + ldb, &t[i__ * t_dim1 + 1], ldt, &iinfo); + +/* Update by applying H**T to B(I+IB:M,:) from the right */ + + if (i__ + ib <= *m) { + i__3 = *m - i__ - ib + 1; + i__4 = *m - i__ - ib + 1; + stprfb_("R", "N", "F", "R", &i__3, &nb, &ib, &lb, &b[i__ + b_dim1] + , ldb, &t[i__ * t_dim1 + 1], ldt, &a[i__ + ib + i__ * + a_dim1], lda, &b[i__ + ib + b_dim1], ldb, &work[1], &i__4); + } + } + return 0; + +/* End of STPLQT */ + +} /* stplqt_ */ + diff --git a/lapack-netlib/SRC/stplqt2.c b/lapack-netlib/SRC/stplqt2.c new file mode 100644 index 000000000..1789eeb48 --- /dev/null +++ b/lapack-netlib/SRC/stplqt2.c @@ -0,0 +1,741 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#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 STPLQT2 computes a LQ factorization of a real or complex "triangular-pentagonal" matrix, which +is composed of a triangular block and a pentagonal block, using the compact WY representation for Q. +*/ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STPLQT2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STPLQT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) */ + +/* INTEGER INFO, LDA, LDB, LDT, N, M, L */ +/* REAL A( LDA, * ), B( LDB, * ), T( LDT, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STPLQT2 computes a LQ a factorization of a real "triangular-pentagonal" */ +/* > matrix C, which is composed of a triangular block A and pentagonal block B, */ +/* > using the compact WY representation for Q. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The total number of rows of the matrix B. */ +/* > M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix B, and the order of */ +/* > the triangular matrix A. */ +/* > N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The number of rows of the lower trapezoidal part of B. */ +/* > MIN(M,N) >= L >= 0. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,M) */ +/* > On entry, the lower triangular M-by-M matrix A. */ +/* > On exit, the elements on and below the diagonal of the array */ +/* > contain the lower triangular matrix L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,N) */ +/* > On entry, the pentagonal M-by-N matrix B. The first N-L columns */ +/* > are rectangular, and the last L columns are lower trapezoidal. */ +/* > On exit, B contains the pentagonal matrix V. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is REAL array, dimension (LDT,M) */ +/* > The N-by-N upper triangular factor T of the block reflector. */ +/* > See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax(1,M) */ +/* > \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 doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The input matrix C is a M-by-(M+N) matrix */ +/* > */ +/* > C = [ A ][ B ] */ +/* > */ +/* > */ +/* > where A is an lower triangular M-by-M matrix, and B is M-by-N pentagonal */ +/* > matrix consisting of a M-by-(N-L) rectangular matrix B1 left of a M-by-L */ +/* > upper trapezoidal matrix B2: */ +/* > */ +/* > B = [ B1 ][ B2 ] */ +/* > [ B1 ] <- M-by-(N-L) rectangular */ +/* > [ B2 ] <- M-by-L lower trapezoidal. */ +/* > */ +/* > The lower trapezoidal matrix B2 consists of the first L columns of a */ +/* > N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0, */ +/* > B is rectangular M-by-N; if M=L=N, B is lower triangular. */ +/* > */ +/* > The matrix W stores the elementary reflectors H(i) in the i-th row */ +/* > above the diagonal (of A) in the M-by-(M+N) input matrix C */ +/* > */ +/* > C = [ A ][ B ] */ +/* > [ A ] <- lower triangular M-by-M */ +/* > [ B ] <- M-by-N pentagonal */ +/* > */ +/* > so that W can be represented as */ +/* > */ +/* > W = [ I ][ V ] */ +/* > [ I ] <- identity, M-by-M */ +/* > [ V ] <- M-by-N, same form as B. */ +/* > */ +/* > Thus, all of information needed for W is contained on exit in B, which */ +/* > we call V above. Note that V has the same form as B; that is, */ +/* > */ +/* > W = [ V1 ][ V2 ] */ +/* > [ V1 ] <- M-by-(N-L) rectangular */ +/* > [ V2 ] <- M-by-L lower trapezoidal. */ +/* > */ +/* > The rows of V represent the vectors which define the H(i)'s. */ +/* > The (M+N)-by-(M+N) block reflector H is then given by */ +/* > */ +/* > H = I - W**T * T * W */ +/* > */ +/* > where W^H is the conjugate transpose of W and T is the upper triangular */ +/* > factor of the block reflector. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int stplqt2_(integer *m, integer *n, integer *l, real *a, + integer *lda, real *b, integer *ldb, real *t, integer *ldt, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, t_dim1, t_offset, i__1, i__2, + i__3; + + /* Local variables */ + extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, + integer *, real *, integer *, real *, integer *); + integer i__, j, p; + real alpha; + extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *), strmv_(char *, char *, char *, integer *, real *, + integer *, real *, integer *); + integer mp, np; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slarfg_( + integer *, real *, real *, integer *, real *); + + +/* -- 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; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*l < 0 || *l > f2cmin(*m,*n)) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } else if (*ldb < f2cmax(1,*m)) { + *info = -7; + } else if (*ldt < f2cmax(1,*m)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STPLQT2", &i__1, (ftnlen)7); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *m == 0) { + return 0; + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Generate elementary reflector H(I) to annihilate B(I,:) */ + + p = *n - *l + f2cmin(*l,i__); + i__2 = p + 1; + slarfg_(&i__2, &a[i__ + i__ * a_dim1], &b[i__ + b_dim1], ldb, &t[i__ * + t_dim1 + 1]); + if (i__ < *m) { + +/* W(M-I:1) := C(I+1:M,I:N) * C(I,I:N) [use W = T(M,:)] */ + + i__2 = *m - i__; + for (j = 1; j <= i__2; ++j) { + t[*m + j * t_dim1] = a[i__ + j + i__ * a_dim1]; + } + i__2 = *m - i__; + sgemv_("N", &i__2, &p, &c_b4, &b[i__ + 1 + b_dim1], ldb, &b[i__ + + b_dim1], ldb, &c_b4, &t[*m + t_dim1], ldt); + +/* C(I+1:M,I:N) = C(I+1:M,I:N) + alpha * C(I,I:N)*W(M-1:1)^H */ + + alpha = -t[i__ * t_dim1 + 1]; + i__2 = *m - i__; + for (j = 1; j <= i__2; ++j) { + a[i__ + j + i__ * a_dim1] += alpha * t[*m + j * t_dim1]; + } + i__2 = *m - i__; + sger_(&i__2, &p, &alpha, &t[*m + t_dim1], ldt, &b[i__ + b_dim1], + ldb, &b[i__ + 1 + b_dim1], ldb); + } + } + + i__1 = *m; + for (i__ = 2; i__ <= i__1; ++i__) { + +/* T(I,1:I-1) := C(I:I-1,1:N) * (alpha * C(I,I:N)^H) */ + + alpha = -t[i__ * t_dim1 + 1]; + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[i__ + j * t_dim1] = 0.f; + } +/* Computing MIN */ + i__2 = i__ - 1; + p = f2cmin(i__2,*l); +/* Computing MIN */ + i__2 = *n - *l + 1; + np = f2cmin(i__2,*n); +/* Computing MIN */ + i__2 = p + 1; + mp = f2cmin(i__2,*m); + +/* Triangular part of B2 */ + + i__2 = p; + for (j = 1; j <= i__2; ++j) { + t[i__ + j * t_dim1] = alpha * b[i__ + (*n - *l + j) * b_dim1]; + } + strmv_("L", "N", "N", &p, &b[np * b_dim1 + 1], ldb, &t[i__ + t_dim1], + ldt); + +/* Rectangular part of B2 */ + + i__2 = i__ - 1 - p; + sgemv_("N", &i__2, l, &alpha, &b[mp + np * b_dim1], ldb, &b[i__ + np * + b_dim1], ldb, &c_b10, &t[i__ + mp * t_dim1], ldt); + +/* B1 */ + + i__2 = i__ - 1; + i__3 = *n - *l; + sgemv_("N", &i__2, &i__3, &alpha, &b[b_offset], ldb, &b[i__ + b_dim1], + ldb, &c_b4, &t[i__ + t_dim1], ldt); + +/* T(1:I-1,I) := T(1:I-1,1:I-1) * T(I,1:I-1) */ + + i__2 = i__ - 1; + strmv_("L", "T", "N", &i__2, &t[t_offset], ldt, &t[i__ + t_dim1], ldt); + +/* T(I,I) = tau(I) */ + + t[i__ + i__ * t_dim1] = t[i__ * t_dim1 + 1]; + t[i__ * t_dim1 + 1] = 0.f; + } + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *m; + for (j = i__ + 1; j <= i__2; ++j) { + t[i__ + j * t_dim1] = t[j + i__ * t_dim1]; + t[j + i__ * t_dim1] = 0.f; + } + } + +/* End of STPLQT2 */ + + return 0; +} /* stplqt2_ */ + diff --git a/lapack-netlib/SRC/stpmlqt.c b/lapack-netlib/SRC/stpmlqt.c new file mode 100644 index 000000000..f2ef0f0e5 --- /dev/null +++ b/lapack-netlib/SRC/stpmlqt.c @@ -0,0 +1,789 @@ +/* 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 DTPMLQT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTPMQRT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT, */ +/* A, LDA, B, LDB, WORK, INFO ) */ + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT */ +/* REAL V( LDV, * ), A( LDA, * ), B( LDB, * ), */ +/* $ T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTPMQRT applies a real orthogonal matrix Q obtained from a */ +/* > "triangular-pentagonal" real block reflector H to a general */ +/* > real matrix C, which consists of two blocks A and B. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**T from the Left; */ +/* > = 'R': apply Q or Q**T from the Right. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': No transpose, apply Q; */ +/* > = 'T': Transpose, apply Q**T. */ +/* > \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 matrix B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The order of the trapezoidal part of V. */ +/* > K >= L >= 0. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MB */ +/* > \verbatim */ +/* > MB is INTEGER */ +/* > The block size used for the storage of T. K >= MB >= 1. */ +/* > This must be the same value of MB used to generate T */ +/* > in DTPLQT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is REAL array, dimension (LDV,K) */ +/* > The i-th row must contain the vector which defines the */ +/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* > DTPLQT in B. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. */ +/* > If SIDE = 'L', LDV >= f2cmax(1,M); */ +/* > if SIDE = 'R', LDV >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is REAL array, dimension (LDT,K) */ +/* > The upper triangular factors of the block reflectors */ +/* > as returned by DTPLQT, stored as a MB-by-K matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= MB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension */ +/* > (LDA,N) if SIDE = 'L' or */ +/* > (LDA,K) if SIDE = 'R' */ +/* > On entry, the K-by-N or M-by-K matrix A. */ +/* > On exit, A is overwritten by the corresponding block of */ +/* > Q*C or Q**T*C or C*Q or C*Q**T. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > If SIDE = 'L', LDC >= f2cmax(1,K); */ +/* > If SIDE = 'R', LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,N) */ +/* > On entry, the M-by-N matrix B. */ +/* > On exit, B is overwritten by the corresponding block of */ +/* > Q*C or Q**T*C or C*Q or C*Q**T. See Further Details. */ +/* > \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 REAL array. The dimension of WORK is */ +/* > N*MB if SIDE = 'L', or M*MB if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The columns of the pentagonal matrix V contain the elementary reflectors */ +/* > H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a */ +/* > trapezoidal block V2: */ +/* > */ +/* > V = [V1] [V2]. */ +/* > */ +/* > */ +/* > The size of the trapezoidal block V2 is determined by the parameter L, */ +/* > where 0 <= L <= K; V2 is lower trapezoidal, consisting of the first L */ +/* > rows of a K-by-K upper triangular matrix. If L=K, V2 is lower triangular; */ +/* > if L=0, there is no trapezoidal block, hence V = V1 is rectangular. */ +/* > */ +/* > If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is K-by-M. */ +/* > [B] */ +/* > */ +/* > If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is K-by-N. */ +/* > */ +/* > The real orthogonal matrix Q is formed from V and T. */ +/* > */ +/* > If TRANS='N' and SIDE='L', C is on exit replaced with Q * C. */ +/* > */ +/* > If TRANS='T' and SIDE='L', C is on exit replaced with Q**T * C. */ +/* > */ +/* > If TRANS='N' and SIDE='R', C is on exit replaced with C * Q. */ +/* > */ +/* > If TRANS='T' and SIDE='R', C is on exit replaced with C * Q**T. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int stpmlqt_(char *side, char *trans, integer *m, integer *n, + integer *k, integer *l, integer *mb, real *v, integer *ldv, real *t, + integer *ldt, real *a, integer *lda, real *b, integer *ldb, real * + work, integer *info) +{ + /* System generated locals */ + integer v_dim1, v_offset, a_dim1, a_offset, b_dim1, b_offset, t_dim1, + t_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer ldaq; + logical left, tran; + integer i__; + extern logical lsame_(char *, char *); + logical right; + integer ib, lb, nb, kf; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), stprfb_( + char *, char *, char *, char *, integer *, integer *, integer *, + integer *, real *, integer *, real *, integer *, real *, integer * + , real *, integer *, real *, integer *); + logical notran; + + +/* -- 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 */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + 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; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + right = lsame_(side, "R"); + tran = lsame_(trans, "T"); + notran = lsame_(trans, "N"); + + if (left) { + ldaq = f2cmax(1,*k); + } else if (right) { + ldaq = f2cmax(1,*m); + } + 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 (*l < 0 || *l > *k) { + *info = -6; + } else if (*mb < 1 || *mb > *k && *k > 0) { + *info = -7; + } else if (*ldv < *k) { + *info = -9; + } else if (*ldt < *mb) { + *info = -11; + } else if (*lda < ldaq) { + *info = -13; + } else if (*ldb < f2cmax(1,*m)) { + *info = -15; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("STPMLQT", &i__1, (ftnlen)7); + return 0; + } + + + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + + if (left && notran) { + + i__1 = *k; + i__2 = *mb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = *mb, i__4 = *k - i__ + 1; + ib = f2cmin(i__3,i__4); +/* Computing MIN */ + i__3 = *m - *l + i__ + ib - 1; + nb = f2cmin(i__3,*m); + if (i__ >= *l) { + lb = 0; + } else { + lb = 0; + } + stprfb_("L", "T", "F", "R", &nb, n, &ib, &lb, &v[i__ + v_dim1], + ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ + a_dim1], lda, &b[ + b_offset], ldb, &work[1], &ib); + } + + } else if (right && tran) { + + i__2 = *k; + i__1 = *mb; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { +/* Computing MIN */ + i__3 = *mb, i__4 = *k - i__ + 1; + ib = f2cmin(i__3,i__4); +/* Computing MIN */ + i__3 = *n - *l + i__ + ib - 1; + nb = f2cmin(i__3,*n); + if (i__ >= *l) { + lb = 0; + } else { + lb = nb - *n + *l - i__ + 1; + } + stprfb_("R", "N", "F", "R", m, &nb, &ib, &lb, &v[i__ + v_dim1], + ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ * a_dim1 + 1], lda, + &b[b_offset], ldb, &work[1], m); + } + + } else if (left && tran) { + + kf = (*k - 1) / *mb * *mb + 1; + i__1 = -(*mb); + for (i__ = kf; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { +/* Computing MIN */ + i__2 = *mb, i__3 = *k - i__ + 1; + ib = f2cmin(i__2,i__3); +/* Computing MIN */ + i__2 = *m - *l + i__ + ib - 1; + nb = f2cmin(i__2,*m); + if (i__ >= *l) { + lb = 0; + } else { + lb = 0; + } + stprfb_("L", "N", "F", "R", &nb, n, &ib, &lb, &v[i__ + v_dim1], + ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ + a_dim1], lda, &b[ + b_offset], ldb, &work[1], &ib); + } + + } else if (right && notran) { + + kf = (*k - 1) / *mb * *mb + 1; + i__1 = -(*mb); + for (i__ = kf; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { +/* Computing MIN */ + i__2 = *mb, i__3 = *k - i__ + 1; + ib = f2cmin(i__2,i__3); +/* Computing MIN */ + i__2 = *n - *l + i__ + ib - 1; + nb = f2cmin(i__2,*n); + if (i__ >= *l) { + lb = 0; + } else { + lb = nb - *n + *l - i__ + 1; + } + stprfb_("R", "T", "F", "R", m, &nb, &ib, &lb, &v[i__ + v_dim1], + ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ * a_dim1 + 1], lda, + &b[b_offset], ldb, &work[1], m); + } + + } + + return 0; + +/* End of STPMLQT */ + +} /* stpmlqt_ */ + diff --git a/lapack-netlib/SRC/stpmqrt.c b/lapack-netlib/SRC/stpmqrt.c new file mode 100644 index 000000000..9b48bac79 --- /dev/null +++ b/lapack-netlib/SRC/stpmqrt.c @@ -0,0 +1,791 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#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 STPMQRT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STPMQRT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, */ +/* A, LDA, B, LDB, WORK, INFO ) */ + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, K, LDV, LDA, LDB, M, N, L, NB, LDT */ +/* REAL V( LDV, * ), A( LDA, * ), B( LDB, * ), T( LDT, * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STPMQRT applies a real orthogonal matrix Q obtained from a */ +/* > "triangular-pentagonal" real block reflector H to a general */ +/* > real matrix C, which consists of two blocks A and B. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q^T from the Left; */ +/* > = 'R': apply Q or Q^T from the Right. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': No transpose, apply Q; */ +/* > = 'T': Transpose, apply Q^T. */ +/* > \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 matrix B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The order of the trapezoidal part of V. */ +/* > K >= L >= 0. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The block size used for the storage of T. K >= NB >= 1. */ +/* > This must be the same value of NB used to generate T */ +/* > in CTPQRT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is REAL array, dimension (LDV,K) */ +/* > The i-th column must contain the vector which defines the */ +/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* > CTPQRT in B. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. */ +/* > If SIDE = 'L', LDV >= f2cmax(1,M); */ +/* > if SIDE = 'R', LDV >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is REAL array, dimension (LDT,K) */ +/* > The upper triangular factors of the block reflectors */ +/* > as returned by CTPQRT, stored as a NB-by-K matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension */ +/* > (LDA,N) if SIDE = 'L' or */ +/* > (LDA,K) if SIDE = 'R' */ +/* > On entry, the K-by-N or M-by-K matrix A. */ +/* > On exit, A is overwritten by the corresponding block of */ +/* > Q*C or Q^T*C or C*Q or C*Q^T. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > If SIDE = 'L', LDC >= f2cmax(1,K); */ +/* > If SIDE = 'R', LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,N) */ +/* > On entry, the M-by-N matrix B. */ +/* > On exit, B is overwritten by the corresponding block of */ +/* > Q*C or Q^T*C or C*Q or C*Q^T. See Further Details. */ +/* > \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 REAL array. The dimension of WORK is */ +/* > N*NB if SIDE = 'L', or M*NB if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The columns of the pentagonal matrix V contain the elementary reflectors */ +/* > H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a */ +/* > trapezoidal block V2: */ +/* > */ +/* > V = [V1] */ +/* > [V2]. */ +/* > */ +/* > The size of the trapezoidal block V2 is determined by the parameter L, */ +/* > where 0 <= L <= K; V2 is upper trapezoidal, consisting of the first L */ +/* > rows of a K-by-K upper triangular matrix. If L=K, V2 is upper triangular; */ +/* > if L=0, there is no trapezoidal block, hence V = V1 is rectangular. */ +/* > */ +/* > If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is M-by-K. */ +/* > [B] */ +/* > */ +/* > If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is N-by-K. */ +/* > */ +/* > The real orthogonal matrix Q is formed from V and T. */ +/* > */ +/* > If TRANS='N' and SIDE='L', C is on exit replaced with Q * C. */ +/* > */ +/* > If TRANS='T' and SIDE='L', C is on exit replaced with Q^T * C. */ +/* > */ +/* > If TRANS='N' and SIDE='R', C is on exit replaced with C * Q. */ +/* > */ +/* > If TRANS='T' and SIDE='R', C is on exit replaced with C * Q^T. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int stpmqrt_(char *side, char *trans, integer *m, integer *n, + integer *k, integer *l, integer *nb, real *v, integer *ldv, real *t, + integer *ldt, real *a, integer *lda, real *b, integer *ldb, real * + work, integer *info) +{ + /* System generated locals */ + integer v_dim1, v_offset, a_dim1, a_offset, b_dim1, b_offset, t_dim1, + t_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer ldaq; + logical left, tran; + integer ldvq, i__; + extern logical lsame_(char *, char *); + logical right; + integer ib, lb, mb, kf; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), stprfb_( + char *, char *, char *, char *, integer *, integer *, integer *, + integer *, real *, integer *, real *, integer *, real *, integer * + , real *, integer *, real *, integer *); + logical notran; + + +/* -- 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 */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + 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; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + right = lsame_(side, "R"); + tran = lsame_(trans, "T"); + notran = lsame_(trans, "N"); + + if (left) { + ldvq = f2cmax(1,*m); + ldaq = f2cmax(1,*k); + } else if (right) { + ldvq = f2cmax(1,*n); + ldaq = f2cmax(1,*m); + } + 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 (*l < 0 || *l > *k) { + *info = -6; + } else if (*nb < 1 || *nb > *k && *k > 0) { + *info = -7; + } else if (*ldv < ldvq) { + *info = -9; + } else if (*ldt < *nb) { + *info = -11; + } else if (*lda < ldaq) { + *info = -13; + } else if (*ldb < f2cmax(1,*m)) { + *info = -15; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("STPMQRT", &i__1, (ftnlen)7); + return 0; + } + + + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + + if (left && tran) { + + i__1 = *k; + i__2 = *nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = *nb, i__4 = *k - i__ + 1; + ib = f2cmin(i__3,i__4); +/* Computing MIN */ + i__3 = *m - *l + i__ + ib - 1; + mb = f2cmin(i__3,*m); + if (i__ >= *l) { + lb = 0; + } else { + lb = mb - *m + *l - i__ + 1; + } + stprfb_("L", "T", "F", "C", &mb, n, &ib, &lb, &v[i__ * v_dim1 + 1] + , ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ + a_dim1], lda, & + b[b_offset], ldb, &work[1], &ib); + } + + } else if (right && notran) { + + i__2 = *k; + i__1 = *nb; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { +/* Computing MIN */ + i__3 = *nb, i__4 = *k - i__ + 1; + ib = f2cmin(i__3,i__4); +/* Computing MIN */ + i__3 = *n - *l + i__ + ib - 1; + mb = f2cmin(i__3,*n); + if (i__ >= *l) { + lb = 0; + } else { + lb = mb - *n + *l - i__ + 1; + } + stprfb_("R", "N", "F", "C", m, &mb, &ib, &lb, &v[i__ * v_dim1 + 1] + , ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ * a_dim1 + 1], + lda, &b[b_offset], ldb, &work[1], m); + } + + } else if (left && notran) { + + kf = (*k - 1) / *nb * *nb + 1; + i__1 = -(*nb); + for (i__ = kf; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { +/* Computing MIN */ + i__2 = *nb, i__3 = *k - i__ + 1; + ib = f2cmin(i__2,i__3); +/* Computing MIN */ + i__2 = *m - *l + i__ + ib - 1; + mb = f2cmin(i__2,*m); + if (i__ >= *l) { + lb = 0; + } else { + lb = mb - *m + *l - i__ + 1; + } + stprfb_("L", "N", "F", "C", &mb, n, &ib, &lb, &v[i__ * v_dim1 + 1] + , ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ + a_dim1], lda, & + b[b_offset], ldb, &work[1], &ib); + } + + } else if (right && tran) { + + kf = (*k - 1) / *nb * *nb + 1; + i__1 = -(*nb); + for (i__ = kf; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { +/* Computing MIN */ + i__2 = *nb, i__3 = *k - i__ + 1; + ib = f2cmin(i__2,i__3); +/* Computing MIN */ + i__2 = *n - *l + i__ + ib - 1; + mb = f2cmin(i__2,*n); + if (i__ >= *l) { + lb = 0; + } else { + lb = mb - *n + *l - i__ + 1; + } + stprfb_("R", "T", "F", "C", m, &mb, &ib, &lb, &v[i__ * v_dim1 + 1] + , ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ * a_dim1 + 1], + lda, &b[b_offset], ldb, &work[1], m); + } + + } + + return 0; + +/* End of STPMQRT */ + +} /* stpmqrt_ */ + diff --git a/lapack-netlib/SRC/stpqrt.c b/lapack-netlib/SRC/stpqrt.c new file mode 100644 index 000000000..0611a8ba9 --- /dev/null +++ b/lapack-netlib/SRC/stpqrt.c @@ -0,0 +1,681 @@ +/* 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 STPQRT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STPQRT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, */ +/* INFO ) */ + +/* INTEGER INFO, LDA, LDB, LDT, N, M, L, NB */ +/* REAL A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STPQRT computes a blocked QR factorization of a real */ +/* > "triangular-pentagonal" matrix C, which is composed of a */ +/* > triangular block A and pentagonal block B, using the compact */ +/* > WY representation for Q. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \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 matrix B, and the order of the */ +/* > triangular matrix A. */ +/* > N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The number of rows of the upper trapezoidal part of B. */ +/* > MIN(M,N) >= L >= 0. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The block size to be used in the blocked QR. N >= NB >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the upper triangular N-by-N matrix A. */ +/* > On exit, the elements on and above the diagonal of the array */ +/* > contain the upper triangular matrix R. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,N) */ +/* > On entry, the pentagonal M-by-N matrix B. The first M-L rows */ +/* > are rectangular, and the last L rows are upper trapezoidal. */ +/* > On exit, B contains the pentagonal matrix V. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is REAL array, dimension (LDT,N) */ +/* > The upper triangular block reflectors stored in compact form */ +/* > as a sequence of upper triangular blocks. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (NB*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The input matrix C is a (N+M)-by-N matrix */ +/* > */ +/* > C = [ A ] */ +/* > [ B ] */ +/* > */ +/* > where A is an upper triangular N-by-N matrix, and B is M-by-N pentagonal */ +/* > matrix consisting of a (M-L)-by-N rectangular matrix B1 on top of a L-by-N */ +/* > upper trapezoidal matrix B2: */ +/* > */ +/* > B = [ B1 ] <- (M-L)-by-N rectangular */ +/* > [ B2 ] <- L-by-N upper trapezoidal. */ +/* > */ +/* > The upper trapezoidal matrix B2 consists of the first L rows of a */ +/* > N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, */ +/* > B is rectangular M-by-N; if M=L=N, B is upper triangular. */ +/* > */ +/* > The matrix W stores the elementary reflectors H(i) in the i-th column */ +/* > below the diagonal (of A) in the (N+M)-by-N input matrix C */ +/* > */ +/* > C = [ A ] <- upper triangular N-by-N */ +/* > [ B ] <- M-by-N pentagonal */ +/* > */ +/* > so that W can be represented as */ +/* > */ +/* > W = [ I ] <- identity, N-by-N */ +/* > [ V ] <- M-by-N, same form as B. */ +/* > */ +/* > Thus, all of information needed for W is contained on exit in B, which */ +/* > we call V above. Note that V has the same form as B; that is, */ +/* > */ +/* > V = [ V1 ] <- (M-L)-by-N rectangular */ +/* > [ V2 ] <- L-by-N upper trapezoidal. */ +/* > */ +/* > The columns of V represent the vectors which define the H(i)'s. */ +/* > */ +/* > The number of blocks is B = ceiling(N/NB), where each */ +/* > block is of order NB except for the last block, which is of order */ +/* > IB = N - (B-1)*NB. For each of the B blocks, a upper triangular block */ +/* > reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB */ +/* > for the last block) T's are stored in the NB-by-N matrix T as */ +/* > */ +/* > T = [T1 T2 ... TB]. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int stpqrt_(integer *m, integer *n, integer *l, integer *nb, + real *a, integer *lda, real *b, integer *ldb, real *t, integer *ldt, + real *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, t_dim1, t_offset, i__1, i__2, + i__3; + + /* Local variables */ + integer i__, iinfo, ib, lb, mb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), stprfb_( + char *, char *, char *, char *, integer *, integer *, integer *, + integer *, real *, integer *, real *, integer *, real *, integer * + , real *, integer *, real *, integer *), stpqrt2_(integer *, integer *, integer *, real *, + integer *, real *, integer *, real *, integer *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* 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; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*l < 0 || *l > f2cmin(*m,*n) && f2cmin(*m,*n) >= 0) { + *info = -3; + } else if (*nb < 1 || *nb > *n && *n > 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } else if (*ldb < f2cmax(1,*m)) { + *info = -8; + } else if (*ldt < *nb) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STPQRT", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + + i__1 = *n; + i__2 = *nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + +/* Compute the QR factorization of the current block */ + +/* Computing MIN */ + i__3 = *n - i__ + 1; + ib = f2cmin(i__3,*nb); +/* Computing MIN */ + i__3 = *m - *l + i__ + ib - 1; + mb = f2cmin(i__3,*m); + if (i__ >= *l) { + lb = 0; + } else { + lb = mb - *m + *l - i__ + 1; + } + + stpqrt2_(&mb, &ib, &lb, &a[i__ + i__ * a_dim1], lda, &b[i__ * b_dim1 + + 1], ldb, &t[i__ * t_dim1 + 1], ldt, &iinfo); + +/* Update by applying H^H to B(:,I+IB:N) from the left */ + + if (i__ + ib <= *n) { + i__3 = *n - i__ - ib + 1; + stprfb_("L", "T", "F", "C", &mb, &i__3, &ib, &lb, &b[i__ * b_dim1 + + 1], ldb, &t[i__ * t_dim1 + 1], ldt, &a[i__ + (i__ + ib) + * a_dim1], lda, &b[(i__ + ib) * b_dim1 + 1], ldb, &work[1] + , &ib); + } + } + return 0; + +/* End of STPQRT */ + +} /* stpqrt_ */ + diff --git a/lapack-netlib/SRC/stpqrt2.c b/lapack-netlib/SRC/stpqrt2.c new file mode 100644 index 000000000..f17660085 --- /dev/null +++ b/lapack-netlib/SRC/stpqrt2.c @@ -0,0 +1,732 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#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 STPQRT2 computes a QR factorization of a real or complex "triangular-pentagonal" matrix, which +is composed of a triangular block and a pentagonal block, using the compact WY representation for Q. +*/ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STPQRT2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) */ + +/* INTEGER INFO, LDA, LDB, LDT, N, M, L */ +/* REAL A( LDA, * ), B( LDB, * ), T( LDT, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STPQRT2 computes a QR factorization of a real "triangular-pentagonal" */ +/* > matrix C, which is composed of a triangular block A and pentagonal block B, */ +/* > using the compact WY representation for Q. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The total number of rows of the matrix B. */ +/* > M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix B, and the order of */ +/* > the triangular matrix A. */ +/* > N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The number of rows of the upper trapezoidal part of B. */ +/* > MIN(M,N) >= L >= 0. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the upper triangular N-by-N matrix A. */ +/* > On exit, the elements on and above the diagonal of the array */ +/* > contain the upper triangular matrix R. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,N) */ +/* > On entry, the pentagonal M-by-N matrix B. The first M-L rows */ +/* > are rectangular, and the last L rows are upper trapezoidal. */ +/* > On exit, B contains the pentagonal matrix V. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is REAL array, dimension (LDT,N) */ +/* > The N-by-N upper triangular factor T of the block reflector. */ +/* > See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax(1,N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The input matrix C is a (N+M)-by-N matrix */ +/* > */ +/* > C = [ A ] */ +/* > [ B ] */ +/* > */ +/* > where A is an upper triangular N-by-N matrix, and B is M-by-N pentagonal */ +/* > matrix consisting of a (M-L)-by-N rectangular matrix B1 on top of a L-by-N */ +/* > upper trapezoidal matrix B2: */ +/* > */ +/* > B = [ B1 ] <- (M-L)-by-N rectangular */ +/* > [ B2 ] <- L-by-N upper trapezoidal. */ +/* > */ +/* > The upper trapezoidal matrix B2 consists of the first L rows of a */ +/* > N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, */ +/* > B is rectangular M-by-N; if M=L=N, B is upper triangular. */ +/* > */ +/* > The matrix W stores the elementary reflectors H(i) in the i-th column */ +/* > below the diagonal (of A) in the (N+M)-by-N input matrix C */ +/* > */ +/* > C = [ A ] <- upper triangular N-by-N */ +/* > [ B ] <- M-by-N pentagonal */ +/* > */ +/* > so that W can be represented as */ +/* > */ +/* > W = [ I ] <- identity, N-by-N */ +/* > [ V ] <- M-by-N, same form as B. */ +/* > */ +/* > Thus, all of information needed for W is contained on exit in B, which */ +/* > we call V above. Note that V has the same form as B; that is, */ +/* > */ +/* > V = [ V1 ] <- (M-L)-by-N rectangular */ +/* > [ V2 ] <- L-by-N upper trapezoidal. */ +/* > */ +/* > The columns of V represent the vectors which define the H(i)'s. */ +/* > The (M+N)-by-(M+N) block reflector H is then given by */ +/* > */ +/* > H = I - W * T * W^H */ +/* > */ +/* > where W^H is the conjugate transpose of W and T is the upper triangular */ +/* > factor of the block reflector. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int stpqrt2_(integer *m, integer *n, integer *l, real *a, + integer *lda, real *b, integer *ldb, real *t, integer *ldt, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, t_dim1, t_offset, i__1, i__2, + i__3; + + /* Local variables */ + extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, + integer *, real *, integer *, real *, integer *); + integer i__, j, p; + real alpha; + extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *), strmv_(char *, char *, char *, integer *, real *, + integer *, real *, integer *); + integer mp, np; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slarfg_( + integer *, real *, real *, integer *, real *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* 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; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*l < 0 || *l > f2cmin(*m,*n)) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*m)) { + *info = -7; + } else if (*ldt < f2cmax(1,*n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STPQRT2", &i__1, (ftnlen)7); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *m == 0) { + return 0; + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Generate elementary reflector H(I) to annihilate B(:,I) */ + + p = *m - *l + f2cmin(*l,i__); + i__2 = p + 1; + slarfg_(&i__2, &a[i__ + i__ * a_dim1], &b[i__ * b_dim1 + 1], &c__1, & + t[i__ + t_dim1]); + if (i__ < *n) { + +/* W(1:N-I) := C(I:M,I+1:N)^H * C(I:M,I) [use W = T(:,N)] */ + + i__2 = *n - i__; + for (j = 1; j <= i__2; ++j) { + t[j + *n * t_dim1] = a[i__ + (i__ + j) * a_dim1]; + } + i__2 = *n - i__; + sgemv_("T", &p, &i__2, &c_b5, &b[(i__ + 1) * b_dim1 + 1], ldb, &b[ + i__ * b_dim1 + 1], &c__1, &c_b5, &t[*n * t_dim1 + 1], & + c__1); + +/* C(I:M,I+1:N) = C(I:m,I+1:N) + alpha*C(I:M,I)*W(1:N-1)^H */ + + alpha = -t[i__ + t_dim1]; + i__2 = *n - i__; + for (j = 1; j <= i__2; ++j) { + a[i__ + (i__ + j) * a_dim1] += alpha * t[j + *n * t_dim1]; + } + i__2 = *n - i__; + sger_(&p, &i__2, &alpha, &b[i__ * b_dim1 + 1], &c__1, &t[*n * + t_dim1 + 1], &c__1, &b[(i__ + 1) * b_dim1 + 1], ldb); + } + } + + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + +/* T(1:I-1,I) := C(I:M,1:I-1)^H * (alpha * C(I:M,I)) */ + + alpha = -t[i__ + t_dim1]; + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[j + i__ * t_dim1] = 0.f; + } +/* Computing MIN */ + i__2 = i__ - 1; + p = f2cmin(i__2,*l); +/* Computing MIN */ + i__2 = *m - *l + 1; + mp = f2cmin(i__2,*m); +/* Computing MIN */ + i__2 = p + 1; + np = f2cmin(i__2,*n); + +/* Triangular part of B2 */ + + i__2 = p; + for (j = 1; j <= i__2; ++j) { + t[j + i__ * t_dim1] = alpha * b[*m - *l + j + i__ * b_dim1]; + } + strmv_("U", "T", "N", &p, &b[mp + b_dim1], ldb, &t[i__ * t_dim1 + 1], + &c__1); + +/* Rectangular part of B2 */ + + i__2 = i__ - 1 - p; + sgemv_("T", l, &i__2, &alpha, &b[mp + np * b_dim1], ldb, &b[mp + i__ * + b_dim1], &c__1, &c_b17, &t[np + i__ * t_dim1], &c__1); + +/* B1 */ + + i__2 = *m - *l; + i__3 = i__ - 1; + sgemv_("T", &i__2, &i__3, &alpha, &b[b_offset], ldb, &b[i__ * b_dim1 + + 1], &c__1, &c_b5, &t[i__ * t_dim1 + 1], &c__1); + +/* T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I) */ + + i__2 = i__ - 1; + strmv_("U", "N", "N", &i__2, &t[t_offset], ldt, &t[i__ * t_dim1 + 1], + &c__1); + +/* T(I,I) = tau(I) */ + + t[i__ + i__ * t_dim1] = t[i__ + t_dim1]; + t[i__ + t_dim1] = 0.f; + } + +/* End of STPQRT2 */ + + return 0; +} /* stpqrt2_ */ + diff --git a/lapack-netlib/SRC/stprfb.c b/lapack-netlib/SRC/stprfb.c new file mode 100644 index 000000000..76176ea4b --- /dev/null +++ b/lapack-netlib/SRC/stprfb.c @@ -0,0 +1,1355 @@ +/* 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 STPRFB applies a real or complex "triangular-pentagonal" blocked reflector to a real or complex + matrix, which is composed of two blocks. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STPRFB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, */ +/* V, LDV, T, LDT, A, LDA, B, LDB, WORK, LDWORK ) */ + +/* CHARACTER DIRECT, SIDE, STOREV, TRANS */ +/* INTEGER K, L, LDA, LDB, LDT, LDV, LDWORK, M, N */ +/* REAL A( LDA, * ), B( LDB, * ), T( LDT, * ), */ +/* $ V( LDV, * ), WORK( LDWORK, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STPRFB applies a real "triangular-pentagonal" block reflector H or its */ +/* > conjugate transpose H^H to a real matrix C, which is composed of two */ +/* > blocks A and B, either from the left or 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': Columns */ +/* > = 'R': Rows */ +/* > \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 matrix B. */ +/* > N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The order of the matrix T, i.e. the number of elementary */ +/* > reflectors whose product defines the block reflector. */ +/* > K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The order of the trapezoidal part of V. */ +/* > K >= L >= 0. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is REAL array, dimension */ +/* > (LDV,K) if STOREV = 'C' */ +/* > (LDV,M) if STOREV = 'R' and SIDE = 'L' */ +/* > (LDV,N) if STOREV = 'R' and SIDE = 'R' */ +/* > The pentagonal matrix V, which contains the elementary reflectors */ +/* > H(1), H(2), ..., H(K). 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 REAL 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] A */ +/* > \verbatim */ +/* > A is REAL array, dimension */ +/* > (LDA,N) if SIDE = 'L' or (LDA,K) if SIDE = 'R' */ +/* > On entry, the K-by-N or M-by-K matrix A. */ +/* > On exit, A is overwritten by the corresponding block of */ +/* > H*C or H^H*C or C*H or C*H^H. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > If SIDE = 'L', LDA >= f2cmax(1,K); */ +/* > If SIDE = 'R', LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,N) */ +/* > On entry, the M-by-N matrix B. */ +/* > On exit, B is overwritten by the corresponding block of */ +/* > H*C or H^H*C or C*H or C*H^H. See Further Details. */ +/* > \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 REAL array, dimension */ +/* > (LDWORK,N) if SIDE = 'L', */ +/* > (LDWORK,K) if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDWORK */ +/* > \verbatim */ +/* > LDWORK is INTEGER */ +/* > The leading dimension of the array WORK. */ +/* > If SIDE = 'L', LDWORK >= K; */ +/* > if SIDE = 'R', LDWORK >= M. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix C is a composite matrix formed from blocks A and B. */ +/* > The block B is of size M-by-N; if SIDE = 'R', A is of size M-by-K, */ +/* > and if SIDE = 'L', A is of size K-by-N. */ +/* > */ +/* > If SIDE = 'R' and DIRECT = 'F', C = [A B]. */ +/* > */ +/* > If SIDE = 'L' and DIRECT = 'F', C = [A] */ +/* > [B]. */ +/* > */ +/* > If SIDE = 'R' and DIRECT = 'B', C = [B A]. */ +/* > */ +/* > If SIDE = 'L' and DIRECT = 'B', C = [B] */ +/* > [A]. */ +/* > */ +/* > The pentagonal matrix V is composed of a rectangular block V1 and a */ +/* > trapezoidal block V2. The size of the trapezoidal block is determined by */ +/* > the parameter L, where 0<=L<=K. If L=K, the V2 block of V is triangular; */ +/* > if L=0, there is no trapezoidal block, thus V = V1 is rectangular. */ +/* > */ +/* > If DIRECT = 'F' and STOREV = 'C': V = [V1] */ +/* > [V2] */ +/* > - V2 is upper trapezoidal (first L rows of K-by-K upper triangular) */ +/* > */ +/* > If DIRECT = 'F' and STOREV = 'R': V = [V1 V2] */ +/* > */ +/* > - V2 is lower trapezoidal (first L columns of K-by-K lower triangular) */ +/* > */ +/* > If DIRECT = 'B' and STOREV = 'C': V = [V2] */ +/* > [V1] */ +/* > - V2 is lower trapezoidal (last L rows of K-by-K lower triangular) */ +/* > */ +/* > If DIRECT = 'B' and STOREV = 'R': V = [V2 V1] */ +/* > */ +/* > - V2 is upper trapezoidal (last L columns of K-by-K upper triangular) */ +/* > */ +/* > If STOREV = 'C' and SIDE = 'L', V is M-by-K with V2 L-by-K. */ +/* > */ +/* > If STOREV = 'C' and SIDE = 'R', V is N-by-K with V2 L-by-K. */ +/* > */ +/* > If STOREV = 'R' and SIDE = 'L', V is K-by-M with V2 K-by-L. */ +/* > */ +/* > If STOREV = 'R' and SIDE = 'R', V is K-by-N with V2 K-by-L. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int stprfb_(char *side, char *trans, char *direct, char * + storev, integer *m, integer *n, integer *k, integer *l, real *v, + integer *ldv, real *t, integer *ldt, real *a, integer *lda, real *b, + integer *ldb, real *work, integer *ldwork) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, t_dim1, t_offset, v_dim1, + v_offset, work_dim1, work_offset, i__1, i__2; + + /* Local variables */ + logical left, backward; + integer i__, j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *); + logical right; + extern /* Subroutine */ int strmm_(char *, char *, char *, char *, + integer *, integer *, real *, real *, integer *, real *, integer * + ); + integer kp, mp, np; + logical column, row, forward; + + +/* -- 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 */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + 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 || *l < 0) { + return 0; + } + + if (lsame_(storev, "C")) { + column = TRUE_; + row = FALSE_; + } else if (lsame_(storev, "R")) { + column = FALSE_; + row = TRUE_; + } else { + column = FALSE_; + row = FALSE_; + } + + if (lsame_(side, "L")) { + left = TRUE_; + right = FALSE_; + } else if (lsame_(side, "R")) { + left = FALSE_; + right = TRUE_; + } else { + left = FALSE_; + right = FALSE_; + } + + if (lsame_(direct, "F")) { + forward = TRUE_; + backward = FALSE_; + } else if (lsame_(direct, "B")) { + forward = FALSE_; + backward = TRUE_; + } else { + forward = FALSE_; + backward = FALSE_; + } + +/* --------------------------------------------------------------------------- */ + + if (column && forward && left) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ I ] (K-by-K) */ +/* [ V ] (M-by-K) */ + +/* Form H C or H^H C where C = [ A ] (K-by-N) */ +/* [ B ] (M-by-N) */ + +/* H = I - W T W^H or H^H = I - W T^H W^H */ + +/* A = A - T (A + V^H B) or A = A - T^H (A + V^H B) */ +/* B = B - V T (A + V^H B) or B = B - V T^H (A + V^H B) */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *m - *l + 1; + mp = f2cmin(i__1,*m); +/* Computing MIN */ + i__1 = *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] = b[*m - *l + i__ + j * b_dim1]; + } + } + strmm_("L", "U", "T", "N", l, n, &c_b12, &v[mp + v_dim1], ldv, &work[ + work_offset], ldwork); + i__1 = *m - *l; + sgemm_("T", "N", l, n, &i__1, &c_b12, &v[v_offset], ldv, &b[b_offset], + ldb, &c_b12, &work[work_offset], ldwork); + i__1 = *k - *l; + sgemm_("T", "N", &i__1, n, m, &c_b12, &v[kp * v_dim1 + 1], ldv, &b[ + b_offset], ldb, &c_b20, &work[kp + work_dim1], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] += a[i__ + j * a_dim1]; + } + } + + strmm_("L", "U", trans, "N", k, n, &c_b12, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] -= work[i__ + j * work_dim1]; + } + } + + i__1 = *m - *l; + sgemm_("N", "N", &i__1, n, k, &c_b27, &v[v_offset], ldv, &work[ + work_offset], ldwork, &c_b12, &b[b_offset], ldb); + i__1 = *k - *l; + sgemm_("N", "N", l, n, &i__1, &c_b27, &v[mp + kp * v_dim1], ldv, & + work[kp + work_dim1], ldwork, &c_b12, &b[mp + b_dim1], ldb); + strmm_("L", "U", "N", "N", l, n, &c_b12, &v[mp + v_dim1], ldv, &work[ + work_offset], ldwork); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + b[*m - *l + i__ + j * b_dim1] -= work[i__ + j * work_dim1]; + } + } + +/* --------------------------------------------------------------------------- */ + + } else if (column && forward && right) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ I ] (K-by-K) */ +/* [ V ] (N-by-K) */ + +/* Form C H or C H^H where C = [ A B ] (A is M-by-K, B is M-by-N) */ + +/* H = I - W T W^H or H^H = I - W T^H W^H */ + +/* A = A - (A + B V) T or A = A - (A + B V) T^H */ +/* B = B - (A + B V) T V^H or B = B - (A + B V) T^H V^H */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *n - *l + 1; + np = f2cmin(i__1,*n); +/* Computing MIN */ + i__1 = *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] = b[i__ + (*n - *l + j) * b_dim1]; + } + } + strmm_("R", "U", "N", "N", m, l, &c_b12, &v[np + v_dim1], ldv, &work[ + work_offset], ldwork); + i__1 = *n - *l; + sgemm_("N", "N", m, l, &i__1, &c_b12, &b[b_offset], ldb, &v[v_offset], + ldv, &c_b12, &work[work_offset], ldwork); + i__1 = *k - *l; + sgemm_("N", "N", m, &i__1, n, &c_b12, &b[b_offset], ldb, &v[kp * + v_dim1 + 1], ldv, &c_b20, &work[kp * work_dim1 + 1], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] += a[i__ + j * a_dim1]; + } + } + + strmm_("R", "U", trans, "N", m, k, &c_b12, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] -= work[i__ + j * work_dim1]; + } + } + + i__1 = *n - *l; + sgemm_("N", "T", m, &i__1, k, &c_b27, &work[work_offset], ldwork, &v[ + v_offset], ldv, &c_b12, &b[b_offset], ldb); + i__1 = *k - *l; + sgemm_("N", "T", m, l, &i__1, &c_b27, &work[kp * work_dim1 + 1], + ldwork, &v[np + kp * v_dim1], ldv, &c_b12, &b[np * b_dim1 + 1] + , ldb); + strmm_("R", "U", "T", "N", m, l, &c_b12, &v[np + v_dim1], ldv, &work[ + work_offset], ldwork); + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + (*n - *l + j) * b_dim1] -= work[i__ + j * work_dim1]; + } + } + +/* --------------------------------------------------------------------------- */ + + } else if (column && backward && left) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ V ] (M-by-K) */ +/* [ I ] (K-by-K) */ + +/* Form H C or H^H C where C = [ B ] (M-by-N) */ +/* [ A ] (K-by-N) */ + +/* H = I - W T W^H or H^H = I - W T^H W^H */ + +/* A = A - T (A + V^H B) or A = A - T^H (A + V^H B) */ +/* B = B - V T (A + V^H B) or B = B - V T^H (A + V^H B) */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *l + 1; + mp = f2cmin(i__1,*m); +/* Computing MIN */ + i__1 = *k - *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*k - *l + i__ + j * work_dim1] = b[i__ + j * b_dim1]; + } + } + + strmm_("L", "L", "T", "N", l, n, &c_b12, &v[kp * v_dim1 + 1], ldv, & + work[kp + work_dim1], ldwork); + i__1 = *m - *l; + sgemm_("T", "N", l, n, &i__1, &c_b12, &v[mp + kp * v_dim1], ldv, &b[ + mp + b_dim1], ldb, &c_b12, &work[kp + work_dim1], ldwork); + i__1 = *k - *l; + sgemm_("T", "N", &i__1, n, m, &c_b12, &v[v_offset], ldv, &b[b_offset], + ldb, &c_b20, &work[work_offset], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] += a[i__ + j * a_dim1]; + } + } + + strmm_("L", "L", trans, "N", k, n, &c_b12, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] -= work[i__ + j * work_dim1]; + } + } + + i__1 = *m - *l; + sgemm_("N", "N", &i__1, n, k, &c_b27, &v[mp + v_dim1], ldv, &work[ + work_offset], ldwork, &c_b12, &b[mp + b_dim1], ldb); + i__1 = *k - *l; + sgemm_("N", "N", l, n, &i__1, &c_b27, &v[v_offset], ldv, &work[ + work_offset], ldwork, &c_b12, &b[b_offset], ldb); + strmm_("L", "L", "N", "N", l, n, &c_b12, &v[kp * v_dim1 + 1], ldv, & + work[kp + work_dim1], ldwork); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= work[*k - *l + i__ + j * work_dim1]; + } + } + +/* --------------------------------------------------------------------------- */ + + } else if (column && backward && right) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ V ] (N-by-K) */ +/* [ I ] (K-by-K) */ + +/* Form C H or C H^H where C = [ B A ] (B is M-by-N, A is M-by-K) */ + +/* H = I - W T W^H or H^H = I - W T^H W^H */ + +/* A = A - (A + B V) T or A = A - (A + B V) T^H */ +/* B = B - (A + B V) T V^H or B = B - (A + B V) T^H V^H */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *l + 1; + np = f2cmin(i__1,*n); +/* Computing MIN */ + i__1 = *k - *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + (*k - *l + j) * work_dim1] = b[i__ + j * b_dim1]; + } + } + strmm_("R", "L", "N", "N", m, l, &c_b12, &v[kp * v_dim1 + 1], ldv, & + work[kp * work_dim1 + 1], ldwork); + i__1 = *n - *l; + sgemm_("N", "N", m, l, &i__1, &c_b12, &b[np * b_dim1 + 1], ldb, &v[np + + kp * v_dim1], ldv, &c_b12, &work[kp * work_dim1 + 1], + ldwork); + i__1 = *k - *l; + sgemm_("N", "N", m, &i__1, n, &c_b12, &b[b_offset], ldb, &v[v_offset], + ldv, &c_b20, &work[work_offset], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] += a[i__ + j * a_dim1]; + } + } + + strmm_("R", "L", trans, "N", m, k, &c_b12, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] -= work[i__ + j * work_dim1]; + } + } + + i__1 = *n - *l; + sgemm_("N", "T", m, &i__1, k, &c_b27, &work[work_offset], ldwork, &v[ + np + v_dim1], ldv, &c_b12, &b[np * b_dim1 + 1], ldb); + i__1 = *k - *l; + sgemm_("N", "T", m, l, &i__1, &c_b27, &work[work_offset], ldwork, &v[ + v_offset], ldv, &c_b12, &b[b_offset], ldb); + strmm_("R", "L", "T", "N", m, l, &c_b12, &v[kp * v_dim1 + 1], ldv, & + work[kp * work_dim1 + 1], ldwork); + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= work[i__ + (*k - *l + j) * work_dim1]; + } + } + +/* --------------------------------------------------------------------------- */ + + } else if (row && forward && left) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ I V ] ( I is K-by-K, V is K-by-M ) */ + +/* Form H C or H^H C where C = [ A ] (K-by-N) */ +/* [ B ] (M-by-N) */ + +/* H = I - W^H T W or H^H = I - W^H T^H W */ + +/* A = A - T (A + V B) or A = A - T^H (A + V B) */ +/* B = B - V^H T (A + V B) or B = B - V^H T^H (A + V B) */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *m - *l + 1; + mp = f2cmin(i__1,*m); +/* Computing MIN */ + i__1 = *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] = b[*m - *l + i__ + j * b_dim1]; + } + } + strmm_("L", "L", "N", "N", l, n, &c_b12, &v[mp * v_dim1 + 1], ldv, & + work[work_offset], ldb); + i__1 = *m - *l; + sgemm_("N", "N", l, n, &i__1, &c_b12, &v[v_offset], ldv, &b[b_offset], + ldb, &c_b12, &work[work_offset], ldwork); + i__1 = *k - *l; + sgemm_("N", "N", &i__1, n, m, &c_b12, &v[kp + v_dim1], ldv, &b[ + b_offset], ldb, &c_b20, &work[kp + work_dim1], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] += a[i__ + j * a_dim1]; + } + } + + strmm_("L", "U", trans, "N", k, n, &c_b12, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] -= work[i__ + j * work_dim1]; + } + } + + i__1 = *m - *l; + sgemm_("T", "N", &i__1, n, k, &c_b27, &v[v_offset], ldv, &work[ + work_offset], ldwork, &c_b12, &b[b_offset], ldb); + i__1 = *k - *l; + sgemm_("T", "N", l, n, &i__1, &c_b27, &v[kp + mp * v_dim1], ldv, & + work[kp + work_dim1], ldwork, &c_b12, &b[mp + b_dim1], ldb); + strmm_("L", "L", "T", "N", l, n, &c_b12, &v[mp * v_dim1 + 1], ldv, & + work[work_offset], ldwork); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + b[*m - *l + i__ + j * b_dim1] -= work[i__ + j * work_dim1]; + } + } + +/* --------------------------------------------------------------------------- */ + + } else if (row && forward && right) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ I V ] ( I is K-by-K, V is K-by-N ) */ + +/* Form C H or C H^H where C = [ A B ] (A is M-by-K, B is M-by-N) */ + +/* H = I - W^H T W or H^H = I - W^H T^H W */ + +/* A = A - (A + B V^H) T or A = A - (A + B V^H) T^H */ +/* B = B - (A + B V^H) T V or B = B - (A + B V^H) T^H V */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *n - *l + 1; + np = f2cmin(i__1,*n); +/* Computing MIN */ + i__1 = *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] = b[i__ + (*n - *l + j) * b_dim1]; + } + } + strmm_("R", "L", "T", "N", m, l, &c_b12, &v[np * v_dim1 + 1], ldv, & + work[work_offset], ldwork); + i__1 = *n - *l; + sgemm_("N", "T", m, l, &i__1, &c_b12, &b[b_offset], ldb, &v[v_offset], + ldv, &c_b12, &work[work_offset], ldwork); + i__1 = *k - *l; + sgemm_("N", "T", m, &i__1, n, &c_b12, &b[b_offset], ldb, &v[kp + + v_dim1], ldv, &c_b20, &work[kp * work_dim1 + 1], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] += a[i__ + j * a_dim1]; + } + } + + strmm_("R", "U", trans, "N", m, k, &c_b12, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] -= work[i__ + j * work_dim1]; + } + } + + i__1 = *n - *l; + sgemm_("N", "N", m, &i__1, k, &c_b27, &work[work_offset], ldwork, &v[ + v_offset], ldv, &c_b12, &b[b_offset], ldb); + i__1 = *k - *l; + sgemm_("N", "N", m, l, &i__1, &c_b27, &work[kp * work_dim1 + 1], + ldwork, &v[kp + np * v_dim1], ldv, &c_b12, &b[np * b_dim1 + 1] + , ldb); + strmm_("R", "L", "N", "N", m, l, &c_b12, &v[np * v_dim1 + 1], ldv, & + work[work_offset], ldwork); + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + (*n - *l + j) * b_dim1] -= work[i__ + j * work_dim1]; + } + } + +/* --------------------------------------------------------------------------- */ + + } else if (row && backward && left) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ V I ] ( I is K-by-K, V is K-by-M ) */ + +/* Form H C or H^H C where C = [ B ] (M-by-N) */ +/* [ A ] (K-by-N) */ + +/* H = I - W^H T W or H^H = I - W^H T^H W */ + +/* A = A - T (A + V B) or A = A - T^H (A + V B) */ +/* B = B - V^H T (A + V B) or B = B - V^H T^H (A + V B) */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *l + 1; + mp = f2cmin(i__1,*m); +/* Computing MIN */ + i__1 = *k - *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*k - *l + i__ + j * work_dim1] = b[i__ + j * b_dim1]; + } + } + strmm_("L", "U", "N", "N", l, n, &c_b12, &v[kp + v_dim1], ldv, &work[ + kp + work_dim1], ldwork); + i__1 = *m - *l; + sgemm_("N", "N", l, n, &i__1, &c_b12, &v[kp + mp * v_dim1], ldv, &b[ + mp + b_dim1], ldb, &c_b12, &work[kp + work_dim1], ldwork); + i__1 = *k - *l; + sgemm_("N", "N", &i__1, n, m, &c_b12, &v[v_offset], ldv, &b[b_offset], + ldb, &c_b20, &work[work_offset], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] += a[i__ + j * a_dim1]; + } + } + + strmm_("L", "L ", trans, "N", k, n, &c_b12, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] -= work[i__ + j * work_dim1]; + } + } + + i__1 = *m - *l; + sgemm_("T", "N", &i__1, n, k, &c_b27, &v[mp * v_dim1 + 1], ldv, &work[ + work_offset], ldwork, &c_b12, &b[mp + b_dim1], ldb); + i__1 = *k - *l; + sgemm_("T", "N", l, n, &i__1, &c_b27, &v[v_offset], ldv, &work[ + work_offset], ldwork, &c_b12, &b[b_offset], ldb); + strmm_("L", "U", "T", "N", l, n, &c_b12, &v[kp + v_dim1], ldv, &work[ + kp + work_dim1], ldwork); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= work[*k - *l + i__ + j * work_dim1]; + } + } + +/* --------------------------------------------------------------------------- */ + + } else if (row && backward && right) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ V I ] ( I is K-by-K, V is K-by-N ) */ + +/* Form C H or C H^H where C = [ B A ] (A is M-by-K, B is M-by-N) */ + +/* H = I - W^H T W or H^H = I - W^H T^H W */ + +/* A = A - (A + B V^H) T or A = A - (A + B V^H) T^H */ +/* B = B - (A + B V^H) T V or B = B - (A + B V^H) T^H V */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *l + 1; + np = f2cmin(i__1,*n); +/* Computing MIN */ + i__1 = *k - *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + (*k - *l + j) * work_dim1] = b[i__ + j * b_dim1]; + } + } + strmm_("R", "U", "T", "N", m, l, &c_b12, &v[kp + v_dim1], ldv, &work[ + kp * work_dim1 + 1], ldwork); + i__1 = *n - *l; + sgemm_("N", "T", m, l, &i__1, &c_b12, &b[np * b_dim1 + 1], ldb, &v[kp + + np * v_dim1], ldv, &c_b12, &work[kp * work_dim1 + 1], + ldwork); + i__1 = *k - *l; + sgemm_("N", "T", m, &i__1, n, &c_b12, &b[b_offset], ldb, &v[v_offset], + ldv, &c_b20, &work[work_offset], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] += a[i__ + j * a_dim1]; + } + } + + strmm_("R", "L", trans, "N", m, k, &c_b12, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] -= work[i__ + j * work_dim1]; + } + } + + i__1 = *n - *l; + sgemm_("N", "N", m, &i__1, k, &c_b27, &work[work_offset], ldwork, &v[ + np * v_dim1 + 1], ldv, &c_b12, &b[np * b_dim1 + 1], ldb); + i__1 = *k - *l; + sgemm_("N", "N", m, l, &i__1, &c_b27, &work[work_offset], ldwork, &v[ + v_offset], ldv, &c_b12, &b[b_offset], ldb); + strmm_("R", "U", "N", "N", m, l, &c_b12, &v[kp + v_dim1], ldv, &work[ + kp * work_dim1 + 1], ldwork); + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= work[i__ + (*k - *l + j) * work_dim1]; + } + } + + } + + return 0; + +/* End of STPRFB */ + +} /* stprfb_ */ + diff --git a/lapack-netlib/SRC/stprfs.c b/lapack-netlib/SRC/stprfs.c new file mode 100644 index 000000000..9fecf134c --- /dev/null +++ b/lapack-netlib/SRC/stprfs.c @@ -0,0 +1,942 @@ +/* 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 STPRFS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STPRFS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, */ +/* FERR, BERR, WORK, IWORK, INFO ) */ + +/* CHARACTER DIAG, TRANS, UPLO */ +/* INTEGER INFO, LDB, LDX, N, NRHS */ +/* INTEGER IWORK( * ) */ +/* REAL AP( * ), B( LDB, * ), BERR( * ), FERR( * ), */ +/* $ WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STPRFS provides error bounds and backward error estimates for the */ +/* > solution to a system of linear equations with a triangular packed */ +/* > coefficient matrix. */ +/* > */ +/* > The solution matrix X must be computed by STPTRS or some other */ +/* > means before entering this routine. STPRFS does not do iterative */ +/* > refinement because doing so cannot improve the backward error. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is REAL array, dimension (N*(N+1)/2) */ +/* > The upper or lower 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)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* > If DIAG = 'U', the diagonal elements of A are not referenced */ +/* > and are assumed to be 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,NRHS) */ +/* > The right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (LDX,NRHS) */ +/* > The solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is REAL array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is REAL array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int stprfs_(char *uplo, char *trans, char *diag, integer *n, + integer *nrhs, real *ap, real *b, integer *ldb, real *x, integer *ldx, + real *ferr, real *berr, real *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3; + real r__1, r__2, r__3; + + /* Local variables */ + integer kase; + real safe1, safe2; + integer i__, j, k; + real s; + extern logical lsame_(char *, char *); + integer isave[3]; + logical upper; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *), saxpy_(integer *, real *, real *, integer *, real *, + integer *), stpmv_(char *, char *, char *, integer *, real *, + real *, integer *), stpsv_(char *, char *, + char *, integer *, real *, real *, integer *), slacn2_(integer *, real *, real *, integer *, real *, + integer *, integer *); + integer kc; + real xk; + extern real slamch_(char *); + integer nz; + real safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical notran; + char transt[1]; + logical nounit; + real lstres, eps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + notran = lsame_(trans, "N"); + nounit = lsame_(diag, "N"); + + 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 (*n < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else if (*ldx < f2cmax(1,*n)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STPRFS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.f; + berr[j] = 0.f; +/* L10: */ + } + return 0; + } + + if (notran) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = *n + 1; + eps = slamch_("Epsilon"); + safmin = slamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Compute residual R = B - op(A) * X, */ +/* where op(A) = A or A**T, depending on TRANS. */ + + scopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1); + stpmv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1); + saxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* f2cmax(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] = (r__1 = b[i__ + j * b_dim1], abs(r__1)); +/* L20: */ + } + + if (notran) { + +/* Compute abs(A)*abs(X) + abs(B). */ + + if (upper) { + kc = 1; + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (r__1 = x[k + j * x_dim1], abs(r__1)); + i__3 = k; + for (i__ = 1; i__ <= i__3; ++i__) { + work[i__] += (r__1 = ap[kc + i__ - 1], abs(r__1)) + * xk; +/* L30: */ + } + kc += k; +/* L40: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (r__1 = x[k + j * x_dim1], abs(r__1)); + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + work[i__] += (r__1 = ap[kc + i__ - 1], abs(r__1)) + * xk; +/* L50: */ + } + work[k] += xk; + kc += k; +/* L60: */ + } + } + } else { + kc = 1; + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (r__1 = x[k + j * x_dim1], abs(r__1)); + i__3 = *n; + for (i__ = k; i__ <= i__3; ++i__) { + work[i__] += (r__1 = ap[kc + i__ - k], abs(r__1)) + * xk; +/* L70: */ + } + kc = kc + *n - k + 1; +/* L80: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (r__1 = x[k + j * x_dim1], abs(r__1)); + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + work[i__] += (r__1 = ap[kc + i__ - k], abs(r__1)) + * xk; +/* L90: */ + } + work[k] += xk; + kc = kc + *n - k + 1; +/* L100: */ + } + } + } + } else { + +/* Compute abs(A**T)*abs(X) + abs(B). */ + + if (upper) { + kc = 1; + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; + i__3 = k; + for (i__ = 1; i__ <= i__3; ++i__) { + s += (r__1 = ap[kc + i__ - 1], abs(r__1)) * (r__2 + = x[i__ + j * x_dim1], abs(r__2)); +/* L110: */ + } + work[k] += s; + kc += k; +/* L120: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = (r__1 = x[k + j * x_dim1], abs(r__1)); + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + s += (r__1 = ap[kc + i__ - 1], abs(r__1)) * (r__2 + = x[i__ + j * x_dim1], abs(r__2)); +/* L130: */ + } + work[k] += s; + kc += k; +/* L140: */ + } + } + } else { + kc = 1; + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; + i__3 = *n; + for (i__ = k; i__ <= i__3; ++i__) { + s += (r__1 = ap[kc + i__ - k], abs(r__1)) * (r__2 + = x[i__ + j * x_dim1], abs(r__2)); +/* L150: */ + } + work[k] += s; + kc = kc + *n - k + 1; +/* L160: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = (r__1 = x[k + j * x_dim1], abs(r__1)); + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + s += (r__1 = ap[kc + i__ - k], abs(r__1)) * (r__2 + = x[i__ + j * x_dim1], abs(r__2)); +/* L170: */ + } + work[k] += s; + kc = kc + *n - k + 1; +/* L180: */ + } + } + } + } + s = 0.f; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + r__2 = s, r__3 = (r__1 = work[*n + i__], abs(r__1)) / work[ + i__]; + s = f2cmax(r__2,r__3); + } else { +/* Computing MAX */ + r__2 = s, r__3 = ((r__1 = work[*n + i__], abs(r__1)) + safe1) + / (work[i__] + safe1); + s = f2cmax(r__2,r__3); + } +/* L190: */ + } + berr[j] = s; + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(op(A)))* */ +/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(op(A)) is the inverse of op(A) */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ + +/* Use SLACN2 to estimate the infinity-norm of the matrix */ +/* inv(op(A)) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { + work[i__] = (r__1 = work[*n + i__], abs(r__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (r__1 = work[*n + i__], abs(r__1)) + nz * eps * + work[i__] + safe1; + } +/* L200: */ + } + + kase = 0; +L210: + slacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & + kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(op(A)**T). */ + + stpsv_(uplo, transt, diag, n, &ap[1], &work[*n + 1], &c__1); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L220: */ + } + } else { + +/* Multiply by inv(op(A))*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L230: */ + } + stpsv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1); + } + goto L210; + } + +/* Normalize error. */ + + lstres = 0.f; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], abs(r__1)); + lstres = f2cmax(r__2,r__3); +/* L240: */ + } + if (lstres != 0.f) { + ferr[j] /= lstres; + } + +/* L250: */ + } + + return 0; + +/* End of STPRFS */ + +} /* stprfs_ */ + diff --git a/lapack-netlib/SRC/stptri.c b/lapack-netlib/SRC/stptri.c new file mode 100644 index 000000000..10ff0f4ca --- /dev/null +++ b/lapack-netlib/SRC/stptri.c @@ -0,0 +1,645 @@ +/* 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 STPTRI */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STPTRI + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STPTRI( UPLO, DIAG, N, AP, INFO ) */ + +/* CHARACTER DIAG, UPLO */ +/* INTEGER INFO, N */ +/* REAL AP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STPTRI computes the inverse of a real upper or lower triangular */ +/* > matrix A stored in packed format. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is REAL array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangular matrix A, stored */ +/* > columnwise in a linear array. The j-th column of A is stored */ +/* > in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* > See below for further details. */ +/* > On exit, the (triangular) inverse of the original matrix, in */ +/* > the same packed storage format. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, A(i,i) is exactly zero. The triangular */ +/* > matrix is singular and its inverse can not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > A triangular matrix A can be transferred to packed storage using one */ +/* > of the following program segments: */ +/* > */ +/* > UPLO = 'U': UPLO = 'L': */ +/* > */ +/* > JC = 1 JC = 1 */ +/* > DO 2 J = 1, N DO 2 J = 1, N */ +/* > DO 1 I = 1, J DO 1 I = J, N */ +/* > AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) */ +/* > 1 CONTINUE 1 CONTINUE */ +/* > JC = JC + J JC = JC + N - J + 1 */ +/* > 2 CONTINUE 2 CONTINUE */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int stptri_(char *uplo, char *diag, integer *n, real *ap, + integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + logical upper; + extern /* Subroutine */ int stpmv_(char *, char *, char *, integer *, + real *, real *, integer *); + integer jc, jj; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + integer jclast; + logical nounit; + real ajj; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + nounit = lsame_(diag, "N"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STPTRI", &i__1, (ftnlen)6); + return 0; + } + +/* Check for singularity if non-unit. */ + + if (nounit) { + if (upper) { + jj = 0; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + jj += *info; + if (ap[jj] == 0.f) { + return 0; + } +/* L10: */ + } + } else { + jj = 1; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (ap[jj] == 0.f) { + return 0; + } + jj = jj + *n - *info + 1; +/* L20: */ + } + } + *info = 0; + } + + if (upper) { + +/* Compute inverse of upper triangular matrix. */ + + jc = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (nounit) { + ap[jc + j - 1] = 1.f / ap[jc + j - 1]; + ajj = -ap[jc + j - 1]; + } else { + ajj = -1.f; + } + +/* Compute elements 1:j-1 of j-th column. */ + + i__2 = j - 1; + stpmv_("Upper", "No transpose", diag, &i__2, &ap[1], &ap[jc], & + c__1); + i__2 = j - 1; + sscal_(&i__2, &ajj, &ap[jc], &c__1); + jc += j; +/* L30: */ + } + + } else { + +/* Compute inverse of lower triangular matrix. */ + + jc = *n * (*n + 1) / 2; + for (j = *n; j >= 1; --j) { + if (nounit) { + ap[jc] = 1.f / ap[jc]; + ajj = -ap[jc]; + } else { + ajj = -1.f; + } + if (j < *n) { + +/* Compute elements j+1:n of j-th column. */ + + i__1 = *n - j; + stpmv_("Lower", "No transpose", diag, &i__1, &ap[jclast], &ap[ + jc + 1], &c__1); + i__1 = *n - j; + sscal_(&i__1, &ajj, &ap[jc + 1], &c__1); + } + jclast = jc; + jc = jc - *n + j - 2; +/* L40: */ + } + } + + return 0; + +/* End of STPTRI */ + +} /* stptri_ */ + diff --git a/lapack-netlib/SRC/stptrs.c b/lapack-netlib/SRC/stptrs.c new file mode 100644 index 000000000..d59e81f81 --- /dev/null +++ b/lapack-netlib/SRC/stptrs.c @@ -0,0 +1,626 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#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 STPTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STPTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO ) */ + +/* CHARACTER DIAG, TRANS, UPLO */ +/* INTEGER INFO, LDB, N, NRHS */ +/* REAL AP( * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STPTRS solves a triangular system of the form */ +/* > */ +/* > A * X = B or A**T * X = B, */ +/* > */ +/* > where A is a triangular matrix of order N stored in packed format, */ +/* > and B is an N-by-NRHS matrix. A check is made to verify that A is */ +/* > nonsingular. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is REAL array, dimension (N*(N+1)/2) */ +/* > The 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)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, if INFO = 0, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the i-th diagonal element of A is zero, */ +/* > indicating that the matrix is singular and the */ +/* > solutions X have not been computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int stptrs_(char *uplo, char *trans, char *diag, integer *n, + integer *nrhs, real *ap, real *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1; + + /* Local variables */ + integer j; + extern logical lsame_(char *, char *); + logical upper; + extern /* Subroutine */ int stpsv_(char *, char *, char *, integer *, + real *, real *, integer *); + integer jc; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical nounit; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + nounit = lsame_(diag, "N"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STPTRS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check for singularity. */ + + if (nounit) { + if (upper) { + jc = 1; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (ap[jc + *info - 1] == 0.f) { + return 0; + } + jc += *info; +/* L10: */ + } + } else { + jc = 1; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (ap[jc] == 0.f) { + return 0; + } + jc = jc + *n - *info + 1; +/* L20: */ + } + } + } + *info = 0; + +/* Solve A * x = b or A**T * x = b. */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + stpsv_(uplo, trans, diag, n, &ap[1], &b[j * b_dim1 + 1], &c__1); +/* L30: */ + } + + return 0; + +/* End of STPTRS */ + +} /* stptrs_ */ + diff --git a/lapack-netlib/SRC/stpttf.c b/lapack-netlib/SRC/stpttf.c new file mode 100644 index 000000000..d2cea0463 --- /dev/null +++ b/lapack-netlib/SRC/stpttf.c @@ -0,0 +1,925 @@ +/* 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 STPTTF copies a triangular matrix from the standard packed format (TP) to the rectangular full +packed format (TF). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STPTTF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STPTTF( TRANSR, UPLO, N, AP, ARF, INFO ) */ + +/* CHARACTER TRANSR, UPLO */ +/* INTEGER INFO, N */ +/* REAL AP( 0: * ), ARF( 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STPTTF copies a triangular matrix A from standard packed format (TP) */ +/* > to rectangular full packed format (TF). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER*1 */ +/* > = 'N': ARF in Normal format is wanted; */ +/* > = 'T': ARF in Conjugate-transpose format is wanted. */ +/* > \endverbatim */ +/* > */ +/* > \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 order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is REAL array, dimension ( N*(N+1)/2 ), */ +/* > On entry, 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. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ARF */ +/* > \verbatim */ +/* > ARF is REAL array, dimension ( N*(N+1)/2 ), */ +/* > On exit, the upper or lower triangular matrix A stored in */ +/* > RFP format. For a further discussion see Notes below. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > We first consider Rectangular Full Packed (RFP) 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 */ +/* > the 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 */ +/* > the transpose of the last three columns of AP lower. */ +/* > 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 = 'T'. RFP A in both UPLO cases is just the */ +/* > 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 then consider Rectangular Full Packed (RFP) 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 */ +/* > the 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 */ +/* > the transpose of the last two columns of AP lower. */ +/* > 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 = 'T'. RFP A in both UPLO cases is just the */ +/* > 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 */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int stpttf_(char *transr, char *uplo, integer *n, real *ap, + real *arf, integer *info) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, k; + logical normaltransr; + extern logical lsame_(char *, char *); + logical lower; + integer n1, n2, ij, jp, js, nt; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical nisodd; + integer lda, ijp; + + +/* -- 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. */ + + *info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + if (! normaltransr && ! lsame_(transr, "T")) { + *info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STPTTF", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (normaltransr) { + arf[0] = ap[0]; + } else { + arf[0] = ap[0]; + } + return 0; + } + +/* Size of array ARF(0:NT-1) */ + + nt = *n * (*n + 1) / 2; + +/* Set N1 and N2 depending on LOWER */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + +/* If N is odd, set NISODD = .TRUE. */ +/* If N is even, set K = N/2 and NISODD = .FALSE. */ + +/* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) */ +/* where noe = 0 if n is even, noe = 1 if n is odd */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = FALSE_; + lda = *n + 1; + } else { + nisodd = TRUE_; + lda = *n; + } + +/* ARF^C has lda rows and n+1-noe cols */ + + if (! normaltransr) { + lda = (*n + 1) / 2; + } + +/* start execution: there are eight cases */ + + if (nisodd) { + +/* N is odd */ + + if (normaltransr) { + +/* N is odd and TRANSR = 'N' */ + + if (lower) { + +/* N is odd, TRANSR = 'N', and UPLO = 'L' */ + + ijp = 0; + jp = 0; + i__1 = n2; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + ij = i__ + jp; + arf[ij] = ap[ijp]; + ++ijp; + } + jp += lda; + } + i__1 = n2 - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = n2; + for (j = i__ + 1; j <= i__2; ++j) { + ij = i__ + j * lda; + arf[ij] = ap[ijp]; + ++ijp; + } + } + + } else { + +/* N is odd, TRANSR = 'N', and UPLO = 'U' */ + + ijp = 0; + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + ij = n2 + j; + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = ap[ijp]; + ++ijp; + ij += lda; + } + } + js = 0; + i__1 = *n - 1; + for (j = n1; j <= i__1; ++j) { + ij = js; + i__2 = js + j; + for (ij = js; ij <= i__2; ++ij) { + arf[ij] = ap[ijp]; + ++ijp; + } + js += lda; + } + + } + + } else { + +/* N is odd and TRANSR = 'T' */ + + if (lower) { + +/* N is odd, TRANSR = 'T', and UPLO = 'L' */ + + ijp = 0; + i__1 = n2; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = *n * lda - 1; + i__3 = lda; + for (ij = i__ * (lda + 1); i__3 < 0 ? ij >= i__2 : ij <= + i__2; ij += i__3) { + arf[ij] = ap[ijp]; + ++ijp; + } + } + js = 1; + i__1 = n2 - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + n2 - j - 1; + for (ij = js; ij <= i__3; ++ij) { + arf[ij] = ap[ijp]; + ++ijp; + } + js = js + lda + 1; + } + + } else { + +/* N is odd, TRANSR = 'T', and UPLO = 'U' */ + + ijp = 0; + js = n2 * lda; + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + j; + for (ij = js; ij <= i__3; ++ij) { + arf[ij] = ap[ijp]; + ++ijp; + } + js += lda; + } + i__1 = n1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__3 = i__ + (n1 + i__) * lda; + i__2 = lda; + for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij += + i__2) { + arf[ij] = ap[ijp]; + ++ijp; + } + } + + } + + } + + } else { + +/* N is even */ + + if (normaltransr) { + +/* N is even and TRANSR = 'N' */ + + if (lower) { + +/* N is even, TRANSR = 'N', and UPLO = 'L' */ + + ijp = 0; + jp = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + ij = i__ + 1 + jp; + arf[ij] = ap[ijp]; + ++ijp; + } + jp += lda; + } + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = k - 1; + for (j = i__; j <= i__2; ++j) { + ij = i__ + j * lda; + arf[ij] = ap[ijp]; + ++ijp; + } + } + + } else { + +/* N is even, TRANSR = 'N', and UPLO = 'U' */ + + ijp = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + ij = k + 1 + j; + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = ap[ijp]; + ++ijp; + ij += lda; + } + } + js = 0; + i__1 = *n - 1; + for (j = k; j <= i__1; ++j) { + ij = js; + i__2 = js + j; + for (ij = js; ij <= i__2; ++ij) { + arf[ij] = ap[ijp]; + ++ijp; + } + js += lda; + } + + } + + } else { + +/* N is even and TRANSR = 'T' */ + + if (lower) { + +/* N is even, TRANSR = 'T', and UPLO = 'L' */ + + ijp = 0; + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = (*n + 1) * lda - 1; + i__3 = lda; + for (ij = i__ + (i__ + 1) * lda; i__3 < 0 ? ij >= i__2 : + ij <= i__2; ij += i__3) { + arf[ij] = ap[ijp]; + ++ijp; + } + } + js = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + k - j - 1; + for (ij = js; ij <= i__3; ++ij) { + arf[ij] = ap[ijp]; + ++ijp; + } + js = js + lda + 1; + } + + } else { + +/* N is even, TRANSR = 'T', and UPLO = 'U' */ + + ijp = 0; + js = (k + 1) * lda; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + j; + for (ij = js; ij <= i__3; ++ij) { + arf[ij] = ap[ijp]; + ++ijp; + } + js += lda; + } + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__3 = i__ + (k + i__) * lda; + i__2 = lda; + for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij += + i__2) { + arf[ij] = ap[ijp]; + ++ijp; + } + } + + } + + } + + } + + return 0; + +/* End of STPTTF */ + +} /* stpttf_ */ + diff --git a/lapack-netlib/SRC/stpttr.c b/lapack-netlib/SRC/stpttr.c new file mode 100644 index 000000000..7c2567aad --- /dev/null +++ b/lapack-netlib/SRC/stpttr.c @@ -0,0 +1,567 @@ +/* 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 STPTTR copies a triangular matrix from the standard packed format (TP) to the standard full for +mat (TR). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STPTTR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STPTTR( UPLO, N, AP, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N, LDA */ +/* REAL A( LDA, * ), AP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STPTTR copies a triangular matrix A from standard packed format (TP) */ +/* > to standard full format (TR). */ +/* > \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 order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is REAL array, dimension ( N*(N+1)/2 ), */ +/* > On entry, 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. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension ( LDA, N ) */ +/* > On exit, the triangular matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int stpttr_(char *uplo, integer *n, real *ap, real *a, + integer *lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, k; + extern logical lsame_(char *, char *); + logical lower; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + *info = 0; + lower = lsame_(uplo, "L"); + if (! lower && ! lsame_(uplo, "U")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STPTTR", &i__1, (ftnlen)6); + return 0; + } + + if (lower) { + k = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + ++k; + a[i__ + j * a_dim1] = ap[k]; + } + } + } else { + k = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ++k; + a[i__ + j * a_dim1] = ap[k]; + } + } + } + + + return 0; + +/* End of STPTTR */ + +} /* stpttr_ */ + diff --git a/lapack-netlib/SRC/strcon.c b/lapack-netlib/SRC/strcon.c new file mode 100644 index 000000000..855482bfd --- /dev/null +++ b/lapack-netlib/SRC/strcon.c @@ -0,0 +1,675 @@ +/* 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 STRCON */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STRCON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, */ +/* IWORK, INFO ) */ + +/* CHARACTER DIAG, NORM, UPLO */ +/* INTEGER INFO, LDA, N */ +/* REAL RCOND */ +/* INTEGER IWORK( * ) */ +/* REAL A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STRCON estimates the reciprocal of the condition number of a */ +/* > triangular matrix A, in either the 1-norm or the infinity-norm. */ +/* > */ +/* > The norm of A is computed and an estimate is obtained for */ +/* > norm(inv(A)), then the reciprocal of the condition number is */ +/* > computed as */ +/* > RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies whether the 1-norm condition number or the */ +/* > infinity-norm condition number is required: */ +/* > = '1' or 'O': 1-norm; */ +/* > = 'I': Infinity-norm. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > The triangular matrix A. If UPLO = 'U', the leading N-by-N */ +/* > upper triangular part of the array A contains the upper */ +/* > triangular matrix, and the strictly lower triangular part of */ +/* > A is not referenced. If UPLO = 'L', the leading N-by-N lower */ +/* > triangular part of the array A contains the lower triangular */ +/* > matrix, and the strictly upper triangular part of A is not */ +/* > referenced. If DIAG = 'U', the diagonal elements of A are */ +/* > also not referenced and are assumed to be 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > The reciprocal of the condition number of the matrix A, */ +/* > computed as RCOND = 1/(norm(A) * norm(inv(A))). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int strcon_(char *norm, char *uplo, char *diag, integer *n, + real *a, integer *lda, real *rcond, real *work, integer *iwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + real r__1; + + /* Local variables */ + integer kase, kase1; + real scale; + extern logical lsame_(char *, char *); + integer isave[3]; + real anorm; + extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *); + logical upper; + real xnorm; + extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *, + real *, integer *, integer *); + integer ix; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer isamax_(integer *, real *, integer *); + real ainvnm; + logical onenrm; + char normin[1]; + extern real slantr_(char *, char *, char *, integer *, integer *, real *, + integer *, real *); + extern /* Subroutine */ int slatrs_(char *, char *, char *, char *, + integer *, real *, integer *, real *, real *, real *, integer *); + real smlnum; + logical nounit; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); + nounit = lsame_(diag, "N"); + + if (! onenrm && ! lsame_(norm, "I")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STRCON", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *rcond = 1.f; + return 0; + } + + *rcond = 0.f; + smlnum = slamch_("Safe minimum") * (real) f2cmax(1,*n); + +/* Compute the norm of the triangular matrix A. */ + + anorm = slantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &work[1]); + +/* Continue only if ANORM > 0. */ + + if (anorm > 0.f) { + +/* Estimate the norm of the inverse of A. */ + + ainvnm = 0.f; + *(unsigned char *)normin = 'N'; + if (onenrm) { + kase1 = 1; + } else { + kase1 = 2; + } + kase = 0; +L10: + slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == kase1) { + +/* Multiply by inv(A). */ + + slatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset], + lda, &work[1], &scale, &work[(*n << 1) + 1], info); + } else { + +/* Multiply by inv(A**T). */ + + slatrs_(uplo, "Transpose", diag, normin, n, &a[a_offset], lda, + &work[1], &scale, &work[(*n << 1) + 1], info); + } + *(unsigned char *)normin = 'Y'; + +/* Multiply by 1/SCALE if doing so will not cause overflow. */ + + if (scale != 1.f) { + ix = isamax_(n, &work[1], &c__1); + xnorm = (r__1 = work[ix], abs(r__1)); + if (scale < xnorm * smlnum || scale == 0.f) { + goto L20; + } + srscl_(n, &scale, &work[1], &c__1); + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.f) { + *rcond = 1.f / anorm / ainvnm; + } + } + +L20: + return 0; + +/* End of STRCON */ + +} /* strcon_ */ + diff --git a/lapack-netlib/SRC/strevc.c b/lapack-netlib/SRC/strevc.c new file mode 100644 index 000000000..b754f1822 --- /dev/null +++ b/lapack-netlib/SRC/strevc.c @@ -0,0 +1,1674 @@ +/* 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 STREVC */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STREVC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, */ +/* LDVR, MM, M, WORK, INFO ) */ + +/* CHARACTER HOWMNY, SIDE */ +/* INTEGER INFO, LDT, LDVL, LDVR, M, MM, N */ +/* LOGICAL SELECT( * ) */ +/* REAL T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STREVC computes some or all of the right and/or left eigenvectors of */ +/* > a real upper quasi-triangular matrix T. */ +/* > Matrices of this type are produced by the Schur factorization of */ +/* > a real general matrix: A = Q*T*Q**T, as computed by SHSEQR. */ +/* > */ +/* > The right eigenvector x and the left eigenvector y of T corresponding */ +/* > to an eigenvalue w are defined by: */ +/* > */ +/* > T*x = w*x, (y**H)*T = w*(y**H) */ +/* > */ +/* > where y**H denotes the conjugate transpose of y. */ +/* > The eigenvalues are not input to this routine, but are read directly */ +/* > from the diagonal blocks of T. */ +/* > */ +/* > This routine returns the matrices X and/or Y of right and left */ +/* > eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an */ +/* > input matrix. If Q is the orthogonal factor that reduces a matrix */ +/* > A to Schur form T, then Q*X and Q*Y are the matrices of right and */ +/* > left eigenvectors of A. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'R': compute right eigenvectors only; */ +/* > = 'L': compute left eigenvectors only; */ +/* > = 'B': compute both right and left eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] HOWMNY */ +/* > \verbatim */ +/* > HOWMNY is CHARACTER*1 */ +/* > = 'A': compute all right and/or left eigenvectors; */ +/* > = 'B': compute all right and/or left eigenvectors, */ +/* > backtransformed by the matrices in VR and/or VL; */ +/* > = 'S': compute selected right and/or left eigenvectors, */ +/* > as indicated by the logical array SELECT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > If HOWMNY = 'S', SELECT specifies the eigenvectors to be */ +/* > computed. */ +/* > If w(j) is a real eigenvalue, the corresponding real */ +/* > eigenvector is computed if SELECT(j) is .TRUE.. */ +/* > If w(j) and w(j+1) are the real and imaginary parts of a */ +/* > complex eigenvalue, the corresponding complex eigenvector is */ +/* > computed if either SELECT(j) or SELECT(j+1) is .TRUE., and */ +/* > on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to */ +/* > .FALSE.. */ +/* > Not referenced if HOWMNY = 'A' or 'B'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix T. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is REAL array, dimension (LDT,N) */ +/* > The upper quasi-triangular matrix T in Schur canonical form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VL */ +/* > \verbatim */ +/* > VL is REAL array, dimension (LDVL,MM) */ +/* > On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */ +/* > contain an N-by-N matrix Q (usually the orthogonal matrix Q */ +/* > of Schur vectors returned by SHSEQR). */ +/* > On exit, if SIDE = 'L' or 'B', VL contains: */ +/* > if HOWMNY = 'A', the matrix Y of left eigenvectors of T; */ +/* > if HOWMNY = 'B', the matrix Q*Y; */ +/* > if HOWMNY = 'S', the left eigenvectors of T specified by */ +/* > SELECT, stored consecutively in the columns */ +/* > of VL, in the same order as their */ +/* > eigenvalues. */ +/* > A complex eigenvector corresponding to a complex eigenvalue */ +/* > is stored in two consecutive columns, the first holding the */ +/* > real part, and the second the imaginary part. */ +/* > Not referenced if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the array VL. LDVL >= 1, and if */ +/* > SIDE = 'L' or 'B', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VR */ +/* > \verbatim */ +/* > VR is REAL array, dimension (LDVR,MM) */ +/* > On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */ +/* > contain an N-by-N matrix Q (usually the orthogonal matrix Q */ +/* > of Schur vectors returned by SHSEQR). */ +/* > On exit, if SIDE = 'R' or 'B', VR contains: */ +/* > if HOWMNY = 'A', the matrix X of right eigenvectors of T; */ +/* > if HOWMNY = 'B', the matrix Q*X; */ +/* > if HOWMNY = 'S', the right eigenvectors of T specified by */ +/* > SELECT, stored consecutively in the columns */ +/* > of VR, in the same order as their */ +/* > eigenvalues. */ +/* > A complex eigenvector corresponding to a complex eigenvalue */ +/* > is stored in two consecutive columns, the first holding the */ +/* > real part and the second the imaginary part. */ +/* > Not referenced if SIDE = 'L'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the array VR. LDVR >= 1, and if */ +/* > SIDE = 'R' or 'B', LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MM */ +/* > \verbatim */ +/* > MM is INTEGER */ +/* > The number of columns in the arrays VL and/or VR. MM >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of columns in the arrays VL and/or VR actually */ +/* > used to store the eigenvectors. */ +/* > If HOWMNY = 'A' or 'B', M is set to N. */ +/* > Each selected real eigenvector occupies one column and each */ +/* > selected complex eigenvector occupies two columns. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The algorithm used in this program is basically backward (forward) */ +/* > substitution, with scaling to make the the code robust against */ +/* > possible overflow. */ +/* > */ +/* > Each eigenvector is normalized so that the element of largest */ +/* > magnitude has magnitude 1; here the magnitude of a complex number */ +/* > (x,y) is taken to be |x| + |y|. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int strevc_(char *side, char *howmny, logical *select, + integer *n, real *t, integer *ldt, real *vl, integer *ldvl, real *vr, + integer *ldvr, integer *mm, integer *m, real *work, integer *info) +{ + /* System generated locals */ + integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, + i__2, i__3; + real r__1, r__2, r__3, r__4; + + /* Local variables */ + real beta, emax; + logical pair, allv; + integer ierr; + real unfl, ovfl, smin; + extern real sdot_(integer *, real *, integer *, real *, integer *); + logical over; + real vmax; + integer jnxt, i__, j, k; + real scale, x[4] /* was [2][2] */; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + real remax; + logical leftv; + extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *); + logical bothv; + real vcrit; + logical somev; + integer j1, j2; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + integer n2; + real xnorm; + extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, + real *, integer *), slaln2_(logical *, integer *, integer *, real + *, real *, real *, integer *, real *, real *, real *, integer *, + real *, real *, real *, integer *, real *, real *, integer *); + integer ii, ki; + extern /* Subroutine */ int slabad_(real *, real *); + integer ip, is; + real wi; + extern real slamch_(char *); + real wr; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real bignum; + extern integer isamax_(integer *, real *, integer *); + logical rightv; + real smlnum, rec, ulp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + --select; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --work; + + /* Function Body */ + bothv = lsame_(side, "B"); + rightv = lsame_(side, "R") || bothv; + leftv = lsame_(side, "L") || bothv; + + allv = lsame_(howmny, "A"); + over = lsame_(howmny, "B"); + somev = lsame_(howmny, "S"); + + *info = 0; + if (! rightv && ! leftv) { + *info = -1; + } else if (! allv && ! over && ! somev) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*ldt < f2cmax(1,*n)) { + *info = -6; + } else if (*ldvl < 1 || leftv && *ldvl < *n) { + *info = -8; + } else if (*ldvr < 1 || rightv && *ldvr < *n) { + *info = -10; + } else { + +/* Set M to the number of columns required to store the selected */ +/* eigenvectors, standardize the array SELECT if necessary, and */ +/* test MM. */ + + if (somev) { + *m = 0; + pair = FALSE_; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (pair) { + pair = FALSE_; + select[j] = FALSE_; + } else { + if (j < *n) { + if (t[j + 1 + j * t_dim1] == 0.f) { + if (select[j]) { + ++(*m); + } + } else { + pair = TRUE_; + if (select[j] || select[j + 1]) { + select[j] = TRUE_; + *m += 2; + } + } + } else { + if (select[*n]) { + ++(*m); + } + } + } +/* L10: */ + } + } else { + *m = *n; + } + + if (*mm < *m) { + *info = -11; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STREVC", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + +/* Set the constants to control overflow. */ + + unfl = slamch_("Safe minimum"); + ovfl = 1.f / unfl; + slabad_(&unfl, &ovfl); + ulp = slamch_("Precision"); + smlnum = unfl * (*n / ulp); + bignum = (1.f - ulp) / smlnum; + +/* Compute 1-norm of each column of strictly upper triangular */ +/* part of T to control overflow in triangular solver. */ + + work[1] = 0.f; + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + work[j] = 0.f; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[j] += (r__1 = t[i__ + j * t_dim1], abs(r__1)); +/* L20: */ + } +/* L30: */ + } + +/* Index IP is used to specify the real or complex eigenvalue: */ +/* IP = 0, real eigenvalue, */ +/* 1, first of conjugate complex pair: (wr,wi) */ +/* -1, second of conjugate complex pair: (wr,wi) */ + + n2 = *n << 1; + + if (rightv) { + +/* Compute right eigenvectors. */ + + ip = 0; + is = *m; + for (ki = *n; ki >= 1; --ki) { + + if (ip == 1) { + goto L130; + } + if (ki == 1) { + goto L40; + } + if (t[ki + (ki - 1) * t_dim1] == 0.f) { + goto L40; + } + ip = -1; + +L40: + if (somev) { + if (ip == 0) { + if (! select[ki]) { + goto L130; + } + } else { + if (! select[ki - 1]) { + goto L130; + } + } + } + +/* Compute the KI-th eigenvalue (WR,WI). */ + + wr = t[ki + ki * t_dim1]; + wi = 0.f; + if (ip != 0) { + wi = sqrt((r__1 = t[ki + (ki - 1) * t_dim1], abs(r__1))) * + sqrt((r__2 = t[ki - 1 + ki * t_dim1], abs(r__2))); + } +/* Computing MAX */ + r__1 = ulp * (abs(wr) + abs(wi)); + smin = f2cmax(r__1,smlnum); + + if (ip == 0) { + +/* Real right eigenvector */ + + work[ki + *n] = 1.f; + +/* Form right-hand side */ + + i__1 = ki - 1; + for (k = 1; k <= i__1; ++k) { + work[k + *n] = -t[k + ki * t_dim1]; +/* L50: */ + } + +/* Solve the upper quasi-triangular system: */ +/* (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK. */ + + jnxt = ki - 1; + for (j = ki - 1; j >= 1; --j) { + if (j > jnxt) { + goto L60; + } + j1 = j; + j2 = j; + jnxt = j - 1; + if (j > 1) { + if (t[j + (j - 1) * t_dim1] != 0.f) { + j1 = j - 1; + jnxt = j - 2; + } + } + + if (j1 == j2) { + +/* 1-by-1 diagonal block */ + + slaln2_(&c_false, &c__1, &c__1, &smin, &c_b22, &t[j + + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * + n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm, + &ierr); + +/* Scale X(1,1) to avoid overflow when updating */ +/* the right-hand side. */ + + if (xnorm > 1.f) { + if (work[j] > bignum / xnorm) { + x[0] /= xnorm; + scale /= xnorm; + } + } + +/* Scale if necessary */ + + if (scale != 1.f) { + sscal_(&ki, &scale, &work[*n + 1], &c__1); + } + work[j + *n] = x[0]; + +/* Update right-hand side */ + + i__1 = j - 1; + r__1 = -x[0]; + saxpy_(&i__1, &r__1, &t[j * t_dim1 + 1], &c__1, &work[ + *n + 1], &c__1); + + } else { + +/* 2-by-2 diagonal block */ + + slaln2_(&c_false, &c__2, &c__1, &smin, &c_b22, &t[j - + 1 + (j - 1) * t_dim1], ldt, &c_b22, &c_b22, & + work[j - 1 + *n], n, &wr, &c_b25, x, &c__2, & + scale, &xnorm, &ierr); + +/* Scale X(1,1) and X(2,1) to avoid overflow when */ +/* updating the right-hand side. */ + + if (xnorm > 1.f) { +/* Computing MAX */ + r__1 = work[j - 1], r__2 = work[j]; + beta = f2cmax(r__1,r__2); + if (beta > bignum / xnorm) { + x[0] /= xnorm; + x[1] /= xnorm; + scale /= xnorm; + } + } + +/* Scale if necessary */ + + if (scale != 1.f) { + sscal_(&ki, &scale, &work[*n + 1], &c__1); + } + work[j - 1 + *n] = x[0]; + work[j + *n] = x[1]; + +/* Update right-hand side */ + + i__1 = j - 2; + r__1 = -x[0]; + saxpy_(&i__1, &r__1, &t[(j - 1) * t_dim1 + 1], &c__1, + &work[*n + 1], &c__1); + i__1 = j - 2; + r__1 = -x[1]; + saxpy_(&i__1, &r__1, &t[j * t_dim1 + 1], &c__1, &work[ + *n + 1], &c__1); + } +L60: + ; + } + +/* Copy the vector x or Q*x to VR and normalize. */ + + if (! over) { + scopy_(&ki, &work[*n + 1], &c__1, &vr[is * vr_dim1 + 1], & + c__1); + + ii = isamax_(&ki, &vr[is * vr_dim1 + 1], &c__1); + remax = 1.f / (r__1 = vr[ii + is * vr_dim1], abs(r__1)); + sscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1); + + i__1 = *n; + for (k = ki + 1; k <= i__1; ++k) { + vr[k + is * vr_dim1] = 0.f; +/* L70: */ + } + } else { + if (ki > 1) { + i__1 = ki - 1; + sgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, & + work[*n + 1], &c__1, &work[ki + *n], &vr[ki * + vr_dim1 + 1], &c__1); + } + + ii = isamax_(n, &vr[ki * vr_dim1 + 1], &c__1); + remax = 1.f / (r__1 = vr[ii + ki * vr_dim1], abs(r__1)); + sscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1); + } + + } else { + +/* Complex right eigenvector. */ + +/* Initial solve */ +/* [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0. */ +/* [ (T(KI,KI-1) T(KI,KI) ) ] */ + + if ((r__1 = t[ki - 1 + ki * t_dim1], abs(r__1)) >= (r__2 = t[ + ki + (ki - 1) * t_dim1], abs(r__2))) { + work[ki - 1 + *n] = 1.f; + work[ki + n2] = wi / t[ki - 1 + ki * t_dim1]; + } else { + work[ki - 1 + *n] = -wi / t[ki + (ki - 1) * t_dim1]; + work[ki + n2] = 1.f; + } + work[ki + *n] = 0.f; + work[ki - 1 + n2] = 0.f; + +/* Form right-hand side */ + + i__1 = ki - 2; + for (k = 1; k <= i__1; ++k) { + work[k + *n] = -work[ki - 1 + *n] * t[k + (ki - 1) * + t_dim1]; + work[k + n2] = -work[ki + n2] * t[k + ki * t_dim1]; +/* L80: */ + } + +/* Solve upper quasi-triangular system: */ +/* (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2) */ + + jnxt = ki - 2; + for (j = ki - 2; j >= 1; --j) { + if (j > jnxt) { + goto L90; + } + j1 = j; + j2 = j; + jnxt = j - 1; + if (j > 1) { + if (t[j + (j - 1) * t_dim1] != 0.f) { + j1 = j - 1; + jnxt = j - 2; + } + } + + if (j1 == j2) { + +/* 1-by-1 diagonal block */ + + slaln2_(&c_false, &c__1, &c__2, &smin, &c_b22, &t[j + + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * + n], n, &wr, &wi, x, &c__2, &scale, &xnorm, & + ierr); + +/* Scale X(1,1) and X(1,2) to avoid overflow when */ +/* updating the right-hand side. */ + + if (xnorm > 1.f) { + if (work[j] > bignum / xnorm) { + x[0] /= xnorm; + x[2] /= xnorm; + scale /= xnorm; + } + } + +/* Scale if necessary */ + + if (scale != 1.f) { + sscal_(&ki, &scale, &work[*n + 1], &c__1); + sscal_(&ki, &scale, &work[n2 + 1], &c__1); + } + work[j + *n] = x[0]; + work[j + n2] = x[2]; + +/* Update the right-hand side */ + + i__1 = j - 1; + r__1 = -x[0]; + saxpy_(&i__1, &r__1, &t[j * t_dim1 + 1], &c__1, &work[ + *n + 1], &c__1); + i__1 = j - 1; + r__1 = -x[2]; + saxpy_(&i__1, &r__1, &t[j * t_dim1 + 1], &c__1, &work[ + n2 + 1], &c__1); + + } else { + +/* 2-by-2 diagonal block */ + + slaln2_(&c_false, &c__2, &c__2, &smin, &c_b22, &t[j - + 1 + (j - 1) * t_dim1], ldt, &c_b22, &c_b22, & + work[j - 1 + *n], n, &wr, &wi, x, &c__2, & + scale, &xnorm, &ierr); + +/* Scale X to avoid overflow when updating */ +/* the right-hand side. */ + + if (xnorm > 1.f) { +/* Computing MAX */ + r__1 = work[j - 1], r__2 = work[j]; + beta = f2cmax(r__1,r__2); + if (beta > bignum / xnorm) { + rec = 1.f / xnorm; + x[0] *= rec; + x[2] *= rec; + x[1] *= rec; + x[3] *= rec; + scale *= rec; + } + } + +/* Scale if necessary */ + + if (scale != 1.f) { + sscal_(&ki, &scale, &work[*n + 1], &c__1); + sscal_(&ki, &scale, &work[n2 + 1], &c__1); + } + work[j - 1 + *n] = x[0]; + work[j + *n] = x[1]; + work[j - 1 + n2] = x[2]; + work[j + n2] = x[3]; + +/* Update the right-hand side */ + + i__1 = j - 2; + r__1 = -x[0]; + saxpy_(&i__1, &r__1, &t[(j - 1) * t_dim1 + 1], &c__1, + &work[*n + 1], &c__1); + i__1 = j - 2; + r__1 = -x[1]; + saxpy_(&i__1, &r__1, &t[j * t_dim1 + 1], &c__1, &work[ + *n + 1], &c__1); + i__1 = j - 2; + r__1 = -x[2]; + saxpy_(&i__1, &r__1, &t[(j - 1) * t_dim1 + 1], &c__1, + &work[n2 + 1], &c__1); + i__1 = j - 2; + r__1 = -x[3]; + saxpy_(&i__1, &r__1, &t[j * t_dim1 + 1], &c__1, &work[ + n2 + 1], &c__1); + } +L90: + ; + } + +/* Copy the vector x or Q*x to VR and normalize. */ + + if (! over) { + scopy_(&ki, &work[*n + 1], &c__1, &vr[(is - 1) * vr_dim1 + + 1], &c__1); + scopy_(&ki, &work[n2 + 1], &c__1, &vr[is * vr_dim1 + 1], & + c__1); + + emax = 0.f; + i__1 = ki; + for (k = 1; k <= i__1; ++k) { +/* Computing MAX */ + r__3 = emax, r__4 = (r__1 = vr[k + (is - 1) * vr_dim1] + , abs(r__1)) + (r__2 = vr[k + is * vr_dim1], + abs(r__2)); + emax = f2cmax(r__3,r__4); +/* L100: */ + } + + remax = 1.f / emax; + sscal_(&ki, &remax, &vr[(is - 1) * vr_dim1 + 1], &c__1); + sscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1); + + i__1 = *n; + for (k = ki + 1; k <= i__1; ++k) { + vr[k + (is - 1) * vr_dim1] = 0.f; + vr[k + is * vr_dim1] = 0.f; +/* L110: */ + } + + } else { + + if (ki > 2) { + i__1 = ki - 2; + sgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, & + work[*n + 1], &c__1, &work[ki - 1 + *n], &vr[( + ki - 1) * vr_dim1 + 1], &c__1); + i__1 = ki - 2; + sgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, & + work[n2 + 1], &c__1, &work[ki + n2], &vr[ki * + vr_dim1 + 1], &c__1); + } else { + sscal_(n, &work[ki - 1 + *n], &vr[(ki - 1) * vr_dim1 + + 1], &c__1); + sscal_(n, &work[ki + n2], &vr[ki * vr_dim1 + 1], & + c__1); + } + + emax = 0.f; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { +/* Computing MAX */ + r__3 = emax, r__4 = (r__1 = vr[k + (ki - 1) * vr_dim1] + , abs(r__1)) + (r__2 = vr[k + ki * vr_dim1], + abs(r__2)); + emax = f2cmax(r__3,r__4); +/* L120: */ + } + remax = 1.f / emax; + sscal_(n, &remax, &vr[(ki - 1) * vr_dim1 + 1], &c__1); + sscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1); + } + } + + --is; + if (ip != 0) { + --is; + } +L130: + if (ip == 1) { + ip = 0; + } + if (ip == -1) { + ip = 1; + } +/* L140: */ + } + } + + if (leftv) { + +/* Compute left eigenvectors. */ + + ip = 0; + is = 1; + i__1 = *n; + for (ki = 1; ki <= i__1; ++ki) { + + if (ip == -1) { + goto L250; + } + if (ki == *n) { + goto L150; + } + if (t[ki + 1 + ki * t_dim1] == 0.f) { + goto L150; + } + ip = 1; + +L150: + if (somev) { + if (! select[ki]) { + goto L250; + } + } + +/* Compute the KI-th eigenvalue (WR,WI). */ + + wr = t[ki + ki * t_dim1]; + wi = 0.f; + if (ip != 0) { + wi = sqrt((r__1 = t[ki + (ki + 1) * t_dim1], abs(r__1))) * + sqrt((r__2 = t[ki + 1 + ki * t_dim1], abs(r__2))); + } +/* Computing MAX */ + r__1 = ulp * (abs(wr) + abs(wi)); + smin = f2cmax(r__1,smlnum); + + if (ip == 0) { + +/* Real left eigenvector. */ + + work[ki + *n] = 1.f; + +/* Form right-hand side */ + + i__2 = *n; + for (k = ki + 1; k <= i__2; ++k) { + work[k + *n] = -t[ki + k * t_dim1]; +/* L160: */ + } + +/* Solve the quasi-triangular system: */ +/* (T(KI+1:N,KI+1:N) - WR)**T*X = SCALE*WORK */ + + vmax = 1.f; + vcrit = bignum; + + jnxt = ki + 1; + i__2 = *n; + for (j = ki + 1; j <= i__2; ++j) { + if (j < jnxt) { + goto L170; + } + j1 = j; + j2 = j; + jnxt = j + 1; + if (j < *n) { + if (t[j + 1 + j * t_dim1] != 0.f) { + j2 = j + 1; + jnxt = j + 2; + } + } + + if (j1 == j2) { + +/* 1-by-1 diagonal block */ + +/* Scale if necessary to avoid overflow when forming */ +/* the right-hand side. */ + + if (work[j] > vcrit) { + rec = 1.f / vmax; + i__3 = *n - ki + 1; + sscal_(&i__3, &rec, &work[ki + *n], &c__1); + vmax = 1.f; + vcrit = bignum; + } + + i__3 = j - ki - 1; + work[j + *n] -= sdot_(&i__3, &t[ki + 1 + j * t_dim1], + &c__1, &work[ki + 1 + *n], &c__1); + +/* Solve (T(J,J)-WR)**T*X = WORK */ + + slaln2_(&c_false, &c__1, &c__1, &smin, &c_b22, &t[j + + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * + n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm, + &ierr); + +/* Scale if necessary */ + + if (scale != 1.f) { + i__3 = *n - ki + 1; + sscal_(&i__3, &scale, &work[ki + *n], &c__1); + } + work[j + *n] = x[0]; +/* Computing MAX */ + r__2 = (r__1 = work[j + *n], abs(r__1)); + vmax = f2cmax(r__2,vmax); + vcrit = bignum / vmax; + + } else { + +/* 2-by-2 diagonal block */ + +/* Scale if necessary to avoid overflow when forming */ +/* the right-hand side. */ + +/* Computing MAX */ + r__1 = work[j], r__2 = work[j + 1]; + beta = f2cmax(r__1,r__2); + if (beta > vcrit) { + rec = 1.f / vmax; + i__3 = *n - ki + 1; + sscal_(&i__3, &rec, &work[ki + *n], &c__1); + vmax = 1.f; + vcrit = bignum; + } + + i__3 = j - ki - 1; + work[j + *n] -= sdot_(&i__3, &t[ki + 1 + j * t_dim1], + &c__1, &work[ki + 1 + *n], &c__1); + + i__3 = j - ki - 1; + work[j + 1 + *n] -= sdot_(&i__3, &t[ki + 1 + (j + 1) * + t_dim1], &c__1, &work[ki + 1 + *n], &c__1); + +/* Solve */ +/* [T(J,J)-WR T(J,J+1) ]**T* X = SCALE*( WORK1 ) */ +/* [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 ) */ + + slaln2_(&c_true, &c__2, &c__1, &smin, &c_b22, &t[j + + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * + n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm, + &ierr); + +/* Scale if necessary */ + + if (scale != 1.f) { + i__3 = *n - ki + 1; + sscal_(&i__3, &scale, &work[ki + *n], &c__1); + } + work[j + *n] = x[0]; + work[j + 1 + *n] = x[1]; + +/* Computing MAX */ + r__3 = (r__1 = work[j + *n], abs(r__1)), r__4 = (r__2 + = work[j + 1 + *n], abs(r__2)), r__3 = f2cmax( + r__3,r__4); + vmax = f2cmax(r__3,vmax); + vcrit = bignum / vmax; + + } +L170: + ; + } + +/* Copy the vector x or Q*x to VL and normalize. */ + + if (! over) { + i__2 = *n - ki + 1; + scopy_(&i__2, &work[ki + *n], &c__1, &vl[ki + is * + vl_dim1], &c__1); + + i__2 = *n - ki + 1; + ii = isamax_(&i__2, &vl[ki + is * vl_dim1], &c__1) + ki - + 1; + remax = 1.f / (r__1 = vl[ii + is * vl_dim1], abs(r__1)); + i__2 = *n - ki + 1; + sscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1); + + i__2 = ki - 1; + for (k = 1; k <= i__2; ++k) { + vl[k + is * vl_dim1] = 0.f; +/* L180: */ + } + + } else { + + if (ki < *n) { + i__2 = *n - ki; + sgemv_("N", n, &i__2, &c_b22, &vl[(ki + 1) * vl_dim1 + + 1], ldvl, &work[ki + 1 + *n], &c__1, &work[ + ki + *n], &vl[ki * vl_dim1 + 1], &c__1); + } + + ii = isamax_(n, &vl[ki * vl_dim1 + 1], &c__1); + remax = 1.f / (r__1 = vl[ii + ki * vl_dim1], abs(r__1)); + sscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1); + + } + + } else { + +/* Complex left eigenvector. */ + +/* Initial solve: */ +/* ((T(KI,KI) T(KI,KI+1) )**T - (WR - I* WI))*X = 0. */ +/* ((T(KI+1,KI) T(KI+1,KI+1)) ) */ + + if ((r__1 = t[ki + (ki + 1) * t_dim1], abs(r__1)) >= (r__2 = + t[ki + 1 + ki * t_dim1], abs(r__2))) { + work[ki + *n] = wi / t[ki + (ki + 1) * t_dim1]; + work[ki + 1 + n2] = 1.f; + } else { + work[ki + *n] = 1.f; + work[ki + 1 + n2] = -wi / t[ki + 1 + ki * t_dim1]; + } + work[ki + 1 + *n] = 0.f; + work[ki + n2] = 0.f; + +/* Form right-hand side */ + + i__2 = *n; + for (k = ki + 2; k <= i__2; ++k) { + work[k + *n] = -work[ki + *n] * t[ki + k * t_dim1]; + work[k + n2] = -work[ki + 1 + n2] * t[ki + 1 + k * t_dim1] + ; +/* L190: */ + } + +/* Solve complex quasi-triangular system: */ +/* ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2 */ + + vmax = 1.f; + vcrit = bignum; + + jnxt = ki + 2; + i__2 = *n; + for (j = ki + 2; j <= i__2; ++j) { + if (j < jnxt) { + goto L200; + } + j1 = j; + j2 = j; + jnxt = j + 1; + if (j < *n) { + if (t[j + 1 + j * t_dim1] != 0.f) { + j2 = j + 1; + jnxt = j + 2; + } + } + + if (j1 == j2) { + +/* 1-by-1 diagonal block */ + +/* Scale if necessary to avoid overflow when */ +/* forming the right-hand side elements. */ + + if (work[j] > vcrit) { + rec = 1.f / vmax; + i__3 = *n - ki + 1; + sscal_(&i__3, &rec, &work[ki + *n], &c__1); + i__3 = *n - ki + 1; + sscal_(&i__3, &rec, &work[ki + n2], &c__1); + vmax = 1.f; + vcrit = bignum; + } + + i__3 = j - ki - 2; + work[j + *n] -= sdot_(&i__3, &t[ki + 2 + j * t_dim1], + &c__1, &work[ki + 2 + *n], &c__1); + i__3 = j - ki - 2; + work[j + n2] -= sdot_(&i__3, &t[ki + 2 + j * t_dim1], + &c__1, &work[ki + 2 + n2], &c__1); + +/* Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2 */ + + r__1 = -wi; + slaln2_(&c_false, &c__1, &c__2, &smin, &c_b22, &t[j + + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * + n], n, &wr, &r__1, x, &c__2, &scale, &xnorm, & + ierr); + +/* Scale if necessary */ + + if (scale != 1.f) { + i__3 = *n - ki + 1; + sscal_(&i__3, &scale, &work[ki + *n], &c__1); + i__3 = *n - ki + 1; + sscal_(&i__3, &scale, &work[ki + n2], &c__1); + } + work[j + *n] = x[0]; + work[j + n2] = x[2]; +/* Computing MAX */ + r__3 = (r__1 = work[j + *n], abs(r__1)), r__4 = (r__2 + = work[j + n2], abs(r__2)), r__3 = f2cmax(r__3, + r__4); + vmax = f2cmax(r__3,vmax); + vcrit = bignum / vmax; + + } else { + +/* 2-by-2 diagonal block */ + +/* Scale if necessary to avoid overflow when forming */ +/* the right-hand side elements. */ + +/* Computing MAX */ + r__1 = work[j], r__2 = work[j + 1]; + beta = f2cmax(r__1,r__2); + if (beta > vcrit) { + rec = 1.f / vmax; + i__3 = *n - ki + 1; + sscal_(&i__3, &rec, &work[ki + *n], &c__1); + i__3 = *n - ki + 1; + sscal_(&i__3, &rec, &work[ki + n2], &c__1); + vmax = 1.f; + vcrit = bignum; + } + + i__3 = j - ki - 2; + work[j + *n] -= sdot_(&i__3, &t[ki + 2 + j * t_dim1], + &c__1, &work[ki + 2 + *n], &c__1); + + i__3 = j - ki - 2; + work[j + n2] -= sdot_(&i__3, &t[ki + 2 + j * t_dim1], + &c__1, &work[ki + 2 + n2], &c__1); + + i__3 = j - ki - 2; + work[j + 1 + *n] -= sdot_(&i__3, &t[ki + 2 + (j + 1) * + t_dim1], &c__1, &work[ki + 2 + *n], &c__1); + + i__3 = j - ki - 2; + work[j + 1 + n2] -= sdot_(&i__3, &t[ki + 2 + (j + 1) * + t_dim1], &c__1, &work[ki + 2 + n2], &c__1); + +/* Solve 2-by-2 complex linear equation */ +/* ([T(j,j) T(j,j+1) ]**T-(wr-i*wi)*I)*X = SCALE*B */ +/* ([T(j+1,j) T(j+1,j+1)] ) */ + + r__1 = -wi; + slaln2_(&c_true, &c__2, &c__2, &smin, &c_b22, &t[j + + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * + n], n, &wr, &r__1, x, &c__2, &scale, &xnorm, & + ierr); + +/* Scale if necessary */ + + if (scale != 1.f) { + i__3 = *n - ki + 1; + sscal_(&i__3, &scale, &work[ki + *n], &c__1); + i__3 = *n - ki + 1; + sscal_(&i__3, &scale, &work[ki + n2], &c__1); + } + work[j + *n] = x[0]; + work[j + n2] = x[2]; + work[j + 1 + *n] = x[1]; + work[j + 1 + n2] = x[3]; +/* Computing MAX */ + r__1 = abs(x[0]), r__2 = abs(x[2]), r__1 = f2cmax(r__1, + r__2), r__2 = abs(x[1]), r__1 = f2cmax(r__1,r__2) + , r__2 = abs(x[3]), r__1 = f2cmax(r__1,r__2); + vmax = f2cmax(r__1,vmax); + vcrit = bignum / vmax; + + } +L200: + ; + } + +/* Copy the vector x or Q*x to VL and normalize. */ + + if (! over) { + i__2 = *n - ki + 1; + scopy_(&i__2, &work[ki + *n], &c__1, &vl[ki + is * + vl_dim1], &c__1); + i__2 = *n - ki + 1; + scopy_(&i__2, &work[ki + n2], &c__1, &vl[ki + (is + 1) * + vl_dim1], &c__1); + + emax = 0.f; + i__2 = *n; + for (k = ki; k <= i__2; ++k) { +/* Computing MAX */ + r__3 = emax, r__4 = (r__1 = vl[k + is * vl_dim1], abs( + r__1)) + (r__2 = vl[k + (is + 1) * vl_dim1], + abs(r__2)); + emax = f2cmax(r__3,r__4); +/* L220: */ + } + remax = 1.f / emax; + i__2 = *n - ki + 1; + sscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1); + i__2 = *n - ki + 1; + sscal_(&i__2, &remax, &vl[ki + (is + 1) * vl_dim1], &c__1) + ; + + i__2 = ki - 1; + for (k = 1; k <= i__2; ++k) { + vl[k + is * vl_dim1] = 0.f; + vl[k + (is + 1) * vl_dim1] = 0.f; +/* L230: */ + } + } else { + if (ki < *n - 1) { + i__2 = *n - ki - 1; + sgemv_("N", n, &i__2, &c_b22, &vl[(ki + 2) * vl_dim1 + + 1], ldvl, &work[ki + 2 + *n], &c__1, &work[ + ki + *n], &vl[ki * vl_dim1 + 1], &c__1); + i__2 = *n - ki - 1; + sgemv_("N", n, &i__2, &c_b22, &vl[(ki + 2) * vl_dim1 + + 1], ldvl, &work[ki + 2 + n2], &c__1, &work[ + ki + 1 + n2], &vl[(ki + 1) * vl_dim1 + 1], & + c__1); + } else { + sscal_(n, &work[ki + *n], &vl[ki * vl_dim1 + 1], & + c__1); + sscal_(n, &work[ki + 1 + n2], &vl[(ki + 1) * vl_dim1 + + 1], &c__1); + } + + emax = 0.f; + i__2 = *n; + for (k = 1; k <= i__2; ++k) { +/* Computing MAX */ + r__3 = emax, r__4 = (r__1 = vl[k + ki * vl_dim1], abs( + r__1)) + (r__2 = vl[k + (ki + 1) * vl_dim1], + abs(r__2)); + emax = f2cmax(r__3,r__4); +/* L240: */ + } + remax = 1.f / emax; + sscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1); + sscal_(n, &remax, &vl[(ki + 1) * vl_dim1 + 1], &c__1); + + } + + } + + ++is; + if (ip != 0) { + ++is; + } +L250: + if (ip == -1) { + ip = 0; + } + if (ip == 1) { + ip = -1; + } + +/* L260: */ + } + + } + + return 0; + +/* End of STREVC */ + +} /* strevc_ */ + diff --git a/lapack-netlib/SRC/strevc3.c b/lapack-netlib/SRC/strevc3.c new file mode 100644 index 000000000..2b422d613 --- /dev/null +++ b/lapack-netlib/SRC/strevc3.c @@ -0,0 +1,1933 @@ +/* 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 STREVC3 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STREVC3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, */ +/* VR, LDVR, MM, M, WORK, LWORK, INFO ) */ + +/* CHARACTER HOWMNY, SIDE */ +/* INTEGER INFO, LDT, LDVL, LDVR, LWORK, M, MM, N */ +/* LOGICAL SELECT( * ) */ +/* REAL T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STREVC3 computes some or all of the right and/or left eigenvectors of */ +/* > a real upper quasi-triangular matrix T. */ +/* > Matrices of this type are produced by the Schur factorization of */ +/* > a real general matrix: A = Q*T*Q**T, as computed by SHSEQR. */ +/* > */ +/* > The right eigenvector x and the left eigenvector y of T corresponding */ +/* > to an eigenvalue w are defined by: */ +/* > */ +/* > T*x = w*x, (y**T)*T = w*(y**T) */ +/* > */ +/* > where y**T denotes the transpose of the vector y. */ +/* > The eigenvalues are not input to this routine, but are read directly */ +/* > from the diagonal blocks of T. */ +/* > */ +/* > This routine returns the matrices X and/or Y of right and left */ +/* > eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an */ +/* > input matrix. If Q is the orthogonal factor that reduces a matrix */ +/* > A to Schur form T, then Q*X and Q*Y are the matrices of right and */ +/* > left eigenvectors of A. */ +/* > */ +/* > This uses a Level 3 BLAS version of the back transformation. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'R': compute right eigenvectors only; */ +/* > = 'L': compute left eigenvectors only; */ +/* > = 'B': compute both right and left eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] HOWMNY */ +/* > \verbatim */ +/* > HOWMNY is CHARACTER*1 */ +/* > = 'A': compute all right and/or left eigenvectors; */ +/* > = 'B': compute all right and/or left eigenvectors, */ +/* > backtransformed by the matrices in VR and/or VL; */ +/* > = 'S': compute selected right and/or left eigenvectors, */ +/* > as indicated by the logical array SELECT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > If HOWMNY = 'S', SELECT specifies the eigenvectors to be */ +/* > computed. */ +/* > If w(j) is a real eigenvalue, the corresponding real */ +/* > eigenvector is computed if SELECT(j) is .TRUE.. */ +/* > If w(j) and w(j+1) are the real and imaginary parts of a */ +/* > complex eigenvalue, the corresponding complex eigenvector is */ +/* > computed if either SELECT(j) or SELECT(j+1) is .TRUE., and */ +/* > on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to */ +/* > .FALSE.. */ +/* > Not referenced if HOWMNY = 'A' or 'B'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix T. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is REAL array, dimension (LDT,N) */ +/* > The upper quasi-triangular matrix T in Schur canonical form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VL */ +/* > \verbatim */ +/* > VL is REAL array, dimension (LDVL,MM) */ +/* > On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */ +/* > contain an N-by-N matrix Q (usually the orthogonal matrix Q */ +/* > of Schur vectors returned by SHSEQR). */ +/* > On exit, if SIDE = 'L' or 'B', VL contains: */ +/* > if HOWMNY = 'A', the matrix Y of left eigenvectors of T; */ +/* > if HOWMNY = 'B', the matrix Q*Y; */ +/* > if HOWMNY = 'S', the left eigenvectors of T specified by */ +/* > SELECT, stored consecutively in the columns */ +/* > of VL, in the same order as their */ +/* > eigenvalues. */ +/* > A complex eigenvector corresponding to a complex eigenvalue */ +/* > is stored in two consecutive columns, the first holding the */ +/* > real part, and the second the imaginary part. */ +/* > Not referenced if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the array VL. */ +/* > LDVL >= 1, and if SIDE = 'L' or 'B', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VR */ +/* > \verbatim */ +/* > VR is REAL array, dimension (LDVR,MM) */ +/* > On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */ +/* > contain an N-by-N matrix Q (usually the orthogonal matrix Q */ +/* > of Schur vectors returned by SHSEQR). */ +/* > On exit, if SIDE = 'R' or 'B', VR contains: */ +/* > if HOWMNY = 'A', the matrix X of right eigenvectors of T; */ +/* > if HOWMNY = 'B', the matrix Q*X; */ +/* > if HOWMNY = 'S', the right eigenvectors of T specified by */ +/* > SELECT, stored consecutively in the columns */ +/* > of VR, in the same order as their */ +/* > eigenvalues. */ +/* > A complex eigenvector corresponding to a complex eigenvalue */ +/* > is stored in two consecutive columns, the first holding the */ +/* > real part and the second the imaginary part. */ +/* > Not referenced if SIDE = 'L'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the array VR. */ +/* > LDVR >= 1, and if SIDE = 'R' or 'B', LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MM */ +/* > \verbatim */ +/* > MM is INTEGER */ +/* > The number of columns in the arrays VL and/or VR. MM >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of columns in the arrays VL and/or VR actually */ +/* > used to store the eigenvectors. */ +/* > If HOWMNY = 'A' or 'B', M is set to N. */ +/* > Each selected real eigenvector occupies one column and each */ +/* > selected complex eigenvector occupies two columns. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MAX(1,LWORK)) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of array WORK. LWORK >= f2cmax(1,3*N). */ +/* > For optimum performance, LWORK >= N + 2*N*NB, where NB is */ +/* > the optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* @generated from dtrevc3.f, fortran d -> s, Tue Apr 19 01:47:44 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The algorithm used in this program is basically backward (forward) */ +/* > substitution, with scaling to make the the code robust against */ +/* > possible overflow. */ +/* > */ +/* > Each eigenvector is normalized so that the element of largest */ +/* > magnitude has magnitude 1; here the magnitude of a complex number */ +/* > (x,y) is taken to be |x| + |y|. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int strevc3_(char *side, char *howmny, logical *select, + integer *n, real *t, integer *ldt, real *vl, integer *ldvl, real *vr, + integer *ldvr, integer *mm, integer *m, real *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + address a__1[2]; + integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1[2], + i__2, i__3, i__4; + real r__1, r__2, r__3, r__4; + char ch__1[2]; + + /* Local variables */ + real beta, emax; + logical pair, allv; + integer ierr; + real unfl, ovfl, smin; + extern real sdot_(integer *, real *, integer *, real *, integer *); + logical over; + real vmax; + integer jnxt, i__, j, k; + real scale, x[4] /* was [2][2] */; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), + sgemm_(char *, char *, integer *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *); + real remax; + logical leftv; + extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *); + logical bothv; + real vcrit; + logical somev; + integer j1, j2; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + real xnorm; + extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, + real *, integer *); + integer iscomplex[128]; + extern /* Subroutine */ int slaln2_(logical *, integer *, integer *, real + *, real *, real *, integer *, real *, real *, real *, integer *, + real *, real *, real *, integer *, real *, real *, integer *); + integer nb, ii, ki; + extern /* Subroutine */ int slabad_(real *, real *); + integer ip, is, iv; + real wi; + extern real slamch_(char *); + real wr; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + real bignum; + extern integer isamax_(integer *, real *, integer *); + extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, + integer *, real *, integer *), slaset_(char *, integer *, + integer *, real *, real *, real *, integer *); + logical rightv; + integer ki2, maxwrk; + real smlnum; + logical lquery; + real rec, ulp; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + --select; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --work; + + /* Function Body */ + bothv = lsame_(side, "B"); + rightv = lsame_(side, "R") || bothv; + leftv = lsame_(side, "L") || bothv; + + allv = lsame_(howmny, "A"); + over = lsame_(howmny, "B"); + somev = lsame_(howmny, "S"); + + *info = 0; +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = side; + i__1[1] = 1, a__1[1] = howmny; + s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); + nb = ilaenv_(&c__1, "STREVC", ch__1, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)2); + maxwrk = *n + (*n << 1) * nb; + work[1] = (real) maxwrk; + lquery = *lwork == -1; + if (! rightv && ! leftv) { + *info = -1; + } else if (! allv && ! over && ! somev) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*ldt < f2cmax(1,*n)) { + *info = -6; + } else if (*ldvl < 1 || leftv && *ldvl < *n) { + *info = -8; + } else if (*ldvr < 1 || rightv && *ldvr < *n) { + *info = -10; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__2 = 1, i__3 = *n * 3; + if (*lwork < f2cmax(i__2,i__3) && ! lquery) { + *info = -14; + } else { + +/* Set M to the number of columns required to store the selected */ +/* eigenvectors, standardize the array SELECT if necessary, and */ +/* test MM. */ + + if (somev) { + *m = 0; + pair = FALSE_; + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + if (pair) { + pair = FALSE_; + select[j] = FALSE_; + } else { + if (j < *n) { + if (t[j + 1 + j * t_dim1] == 0.f) { + if (select[j]) { + ++(*m); + } + } else { + pair = TRUE_; + if (select[j] || select[j + 1]) { + select[j] = TRUE_; + *m += 2; + } + } + } else { + if (select[*n]) { + ++(*m); + } + } + } +/* L10: */ + } + } else { + *m = *n; + } + + if (*mm < *m) { + *info = -11; + } + } + } + if (*info != 0) { + i__2 = -(*info); + xerbla_("STREVC3", &i__2, (ftnlen)7); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + +/* Use blocked version of back-transformation if sufficient workspace. */ +/* Zero-out the workspace to avoid potential NaN propagation. */ + + if (over && *lwork >= *n + (*n << 4)) { + nb = (*lwork - *n) / (*n << 1); + nb = f2cmin(nb,128); + i__2 = (nb << 1) + 1; + slaset_("F", n, &i__2, &c_b17, &c_b17, &work[1], n); + } else { + nb = 1; + } + +/* Set the constants to control overflow. */ + + unfl = slamch_("Safe minimum"); + ovfl = 1.f / unfl; + slabad_(&unfl, &ovfl); + ulp = slamch_("Precision"); + smlnum = unfl * (*n / ulp); + bignum = (1.f - ulp) / smlnum; + +/* Compute 1-norm of each column of strictly upper triangular */ +/* part of T to control overflow in triangular solver. */ + + work[1] = 0.f; + i__2 = *n; + for (j = 2; j <= i__2; ++j) { + work[j] = 0.f; + i__3 = j - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + work[j] += (r__1 = t[i__ + j * t_dim1], abs(r__1)); +/* L20: */ + } +/* L30: */ + } + +/* Index IP is used to specify the real or complex eigenvalue: */ +/* IP = 0, real eigenvalue, */ +/* 1, first of conjugate complex pair: (wr,wi) */ +/* -1, second of conjugate complex pair: (wr,wi) */ +/* ISCOMPLEX array stores IP for each column in current block. */ + + if (rightv) { + +/* ============================================================ */ +/* Compute right eigenvectors. */ + +/* IV is index of column in current block. */ +/* For complex right vector, uses IV-1 for real part and IV for complex part. */ +/* Non-blocked version always uses IV=2; */ +/* blocked version starts with IV=NB, goes down to 1 or 2. */ +/* (Note the "0-th" column is used for 1-norms computed above.) */ + iv = 2; + if (nb > 2) { + iv = nb; + } + ip = 0; + is = *m; + for (ki = *n; ki >= 1; --ki) { + if (ip == -1) { +/* previous iteration (ki+1) was second of conjugate pair, */ +/* so this ki is first of conjugate pair; skip to end of loop */ + ip = 1; + goto L140; + } else if (ki == 1) { +/* last column, so this ki must be real eigenvalue */ + ip = 0; + } else if (t[ki + (ki - 1) * t_dim1] == 0.f) { +/* zero on sub-diagonal, so this ki is real eigenvalue */ + ip = 0; + } else { +/* non-zero on sub-diagonal, so this ki is second of conjugate pair */ + ip = -1; + } + if (somev) { + if (ip == 0) { + if (! select[ki]) { + goto L140; + } + } else { + if (! select[ki - 1]) { + goto L140; + } + } + } + +/* Compute the KI-th eigenvalue (WR,WI). */ + + wr = t[ki + ki * t_dim1]; + wi = 0.f; + if (ip != 0) { + wi = sqrt((r__1 = t[ki + (ki - 1) * t_dim1], abs(r__1))) * + sqrt((r__2 = t[ki - 1 + ki * t_dim1], abs(r__2))); + } +/* Computing MAX */ + r__1 = ulp * (abs(wr) + abs(wi)); + smin = f2cmax(r__1,smlnum); + + if (ip == 0) { + +/* -------------------------------------------------------- */ +/* Real right eigenvector */ + + work[ki + iv * *n] = 1.f; + +/* Form right-hand side. */ + + i__2 = ki - 1; + for (k = 1; k <= i__2; ++k) { + work[k + iv * *n] = -t[k + ki * t_dim1]; +/* L50: */ + } + +/* Solve upper quasi-triangular system: */ +/* [ T(1:KI-1,1:KI-1) - WR ]*X = SCALE*WORK. */ + + jnxt = ki - 1; + for (j = ki - 1; j >= 1; --j) { + if (j > jnxt) { + goto L60; + } + j1 = j; + j2 = j; + jnxt = j - 1; + if (j > 1) { + if (t[j + (j - 1) * t_dim1] != 0.f) { + j1 = j - 1; + jnxt = j - 2; + } + } + + if (j1 == j2) { + +/* 1-by-1 diagonal block */ + + slaln2_(&c_false, &c__1, &c__1, &smin, &c_b29, &t[j + + j * t_dim1], ldt, &c_b29, &c_b29, &work[j + + iv * *n], n, &wr, &c_b17, x, &c__2, &scale, & + xnorm, &ierr); + +/* Scale X(1,1) to avoid overflow when updating */ +/* the right-hand side. */ + + if (xnorm > 1.f) { + if (work[j] > bignum / xnorm) { + x[0] /= xnorm; + scale /= xnorm; + } + } + +/* Scale if necessary */ + + if (scale != 1.f) { + sscal_(&ki, &scale, &work[iv * *n + 1], &c__1); + } + work[j + iv * *n] = x[0]; + +/* Update right-hand side */ + + i__2 = j - 1; + r__1 = -x[0]; + saxpy_(&i__2, &r__1, &t[j * t_dim1 + 1], &c__1, &work[ + iv * *n + 1], &c__1); + + } else { + +/* 2-by-2 diagonal block */ + + slaln2_(&c_false, &c__2, &c__1, &smin, &c_b29, &t[j - + 1 + (j - 1) * t_dim1], ldt, &c_b29, &c_b29, & + work[j - 1 + iv * *n], n, &wr, &c_b17, x, & + c__2, &scale, &xnorm, &ierr); + +/* Scale X(1,1) and X(2,1) to avoid overflow when */ +/* updating the right-hand side. */ + + if (xnorm > 1.f) { +/* Computing MAX */ + r__1 = work[j - 1], r__2 = work[j]; + beta = f2cmax(r__1,r__2); + if (beta > bignum / xnorm) { + x[0] /= xnorm; + x[1] /= xnorm; + scale /= xnorm; + } + } + +/* Scale if necessary */ + + if (scale != 1.f) { + sscal_(&ki, &scale, &work[iv * *n + 1], &c__1); + } + work[j - 1 + iv * *n] = x[0]; + work[j + iv * *n] = x[1]; + +/* Update right-hand side */ + + i__2 = j - 2; + r__1 = -x[0]; + saxpy_(&i__2, &r__1, &t[(j - 1) * t_dim1 + 1], &c__1, + &work[iv * *n + 1], &c__1); + i__2 = j - 2; + r__1 = -x[1]; + saxpy_(&i__2, &r__1, &t[j * t_dim1 + 1], &c__1, &work[ + iv * *n + 1], &c__1); + } +L60: + ; + } + +/* Copy the vector x or Q*x to VR and normalize. */ + + if (! over) { +/* ------------------------------ */ +/* no back-transform: copy x to VR and normalize. */ + scopy_(&ki, &work[iv * *n + 1], &c__1, &vr[is * vr_dim1 + + 1], &c__1); + + ii = isamax_(&ki, &vr[is * vr_dim1 + 1], &c__1); + remax = 1.f / (r__1 = vr[ii + is * vr_dim1], abs(r__1)); + sscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1); + + i__2 = *n; + for (k = ki + 1; k <= i__2; ++k) { + vr[k + is * vr_dim1] = 0.f; +/* L70: */ + } + + } else if (nb == 1) { +/* ------------------------------ */ +/* version 1: back-transform each vector with GEMV, Q*x. */ + if (ki > 1) { + i__2 = ki - 1; + sgemv_("N", n, &i__2, &c_b29, &vr[vr_offset], ldvr, & + work[iv * *n + 1], &c__1, &work[ki + iv * *n], + &vr[ki * vr_dim1 + 1], &c__1); + } + + ii = isamax_(n, &vr[ki * vr_dim1 + 1], &c__1); + remax = 1.f / (r__1 = vr[ii + ki * vr_dim1], abs(r__1)); + sscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1); + + } else { +/* ------------------------------ */ +/* version 2: back-transform block of vectors with GEMM */ +/* zero out below vector */ + i__2 = *n; + for (k = ki + 1; k <= i__2; ++k) { + work[k + iv * *n] = 0.f; + } + iscomplex[iv - 1] = ip; +/* back-transform and normalization is done below */ + } + } else { + +/* -------------------------------------------------------- */ +/* Complex right eigenvector. */ + +/* Initial solve */ +/* [ ( T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I*WI) ]*X = 0. */ +/* [ ( T(KI, KI-1) T(KI, KI) ) ] */ + + if ((r__1 = t[ki - 1 + ki * t_dim1], abs(r__1)) >= (r__2 = t[ + ki + (ki - 1) * t_dim1], abs(r__2))) { + work[ki - 1 + (iv - 1) * *n] = 1.f; + work[ki + iv * *n] = wi / t[ki - 1 + ki * t_dim1]; + } else { + work[ki - 1 + (iv - 1) * *n] = -wi / t[ki + (ki - 1) * + t_dim1]; + work[ki + iv * *n] = 1.f; + } + work[ki + (iv - 1) * *n] = 0.f; + work[ki - 1 + iv * *n] = 0.f; + +/* Form right-hand side. */ + + i__2 = ki - 2; + for (k = 1; k <= i__2; ++k) { + work[k + (iv - 1) * *n] = -work[ki - 1 + (iv - 1) * *n] * + t[k + (ki - 1) * t_dim1]; + work[k + iv * *n] = -work[ki + iv * *n] * t[k + ki * + t_dim1]; +/* L80: */ + } + +/* Solve upper quasi-triangular system: */ +/* [ T(1:KI-2,1:KI-2) - (WR+i*WI) ]*X = SCALE*(WORK+i*WORK2) */ + + jnxt = ki - 2; + for (j = ki - 2; j >= 1; --j) { + if (j > jnxt) { + goto L90; + } + j1 = j; + j2 = j; + jnxt = j - 1; + if (j > 1) { + if (t[j + (j - 1) * t_dim1] != 0.f) { + j1 = j - 1; + jnxt = j - 2; + } + } + + if (j1 == j2) { + +/* 1-by-1 diagonal block */ + + slaln2_(&c_false, &c__1, &c__2, &smin, &c_b29, &t[j + + j * t_dim1], ldt, &c_b29, &c_b29, &work[j + ( + iv - 1) * *n], n, &wr, &wi, x, &c__2, &scale, + &xnorm, &ierr); + +/* Scale X(1,1) and X(1,2) to avoid overflow when */ +/* updating the right-hand side. */ + + if (xnorm > 1.f) { + if (work[j] > bignum / xnorm) { + x[0] /= xnorm; + x[2] /= xnorm; + scale /= xnorm; + } + } + +/* Scale if necessary */ + + if (scale != 1.f) { + sscal_(&ki, &scale, &work[(iv - 1) * *n + 1], & + c__1); + sscal_(&ki, &scale, &work[iv * *n + 1], &c__1); + } + work[j + (iv - 1) * *n] = x[0]; + work[j + iv * *n] = x[2]; + +/* Update the right-hand side */ + + i__2 = j - 1; + r__1 = -x[0]; + saxpy_(&i__2, &r__1, &t[j * t_dim1 + 1], &c__1, &work[ + (iv - 1) * *n + 1], &c__1); + i__2 = j - 1; + r__1 = -x[2]; + saxpy_(&i__2, &r__1, &t[j * t_dim1 + 1], &c__1, &work[ + iv * *n + 1], &c__1); + + } else { + +/* 2-by-2 diagonal block */ + + slaln2_(&c_false, &c__2, &c__2, &smin, &c_b29, &t[j - + 1 + (j - 1) * t_dim1], ldt, &c_b29, &c_b29, & + work[j - 1 + (iv - 1) * *n], n, &wr, &wi, x, & + c__2, &scale, &xnorm, &ierr); + +/* Scale X to avoid overflow when updating */ +/* the right-hand side. */ + + if (xnorm > 1.f) { +/* Computing MAX */ + r__1 = work[j - 1], r__2 = work[j]; + beta = f2cmax(r__1,r__2); + if (beta > bignum / xnorm) { + rec = 1.f / xnorm; + x[0] *= rec; + x[2] *= rec; + x[1] *= rec; + x[3] *= rec; + scale *= rec; + } + } + +/* Scale if necessary */ + + if (scale != 1.f) { + sscal_(&ki, &scale, &work[(iv - 1) * *n + 1], & + c__1); + sscal_(&ki, &scale, &work[iv * *n + 1], &c__1); + } + work[j - 1 + (iv - 1) * *n] = x[0]; + work[j + (iv - 1) * *n] = x[1]; + work[j - 1 + iv * *n] = x[2]; + work[j + iv * *n] = x[3]; + +/* Update the right-hand side */ + + i__2 = j - 2; + r__1 = -x[0]; + saxpy_(&i__2, &r__1, &t[(j - 1) * t_dim1 + 1], &c__1, + &work[(iv - 1) * *n + 1], &c__1); + i__2 = j - 2; + r__1 = -x[1]; + saxpy_(&i__2, &r__1, &t[j * t_dim1 + 1], &c__1, &work[ + (iv - 1) * *n + 1], &c__1); + i__2 = j - 2; + r__1 = -x[2]; + saxpy_(&i__2, &r__1, &t[(j - 1) * t_dim1 + 1], &c__1, + &work[iv * *n + 1], &c__1); + i__2 = j - 2; + r__1 = -x[3]; + saxpy_(&i__2, &r__1, &t[j * t_dim1 + 1], &c__1, &work[ + iv * *n + 1], &c__1); + } +L90: + ; + } + +/* Copy the vector x or Q*x to VR and normalize. */ + + if (! over) { +/* ------------------------------ */ +/* no back-transform: copy x to VR and normalize. */ + scopy_(&ki, &work[(iv - 1) * *n + 1], &c__1, &vr[(is - 1) + * vr_dim1 + 1], &c__1); + scopy_(&ki, &work[iv * *n + 1], &c__1, &vr[is * vr_dim1 + + 1], &c__1); + + emax = 0.f; + i__2 = ki; + for (k = 1; k <= i__2; ++k) { +/* Computing MAX */ + r__3 = emax, r__4 = (r__1 = vr[k + (is - 1) * vr_dim1] + , abs(r__1)) + (r__2 = vr[k + is * vr_dim1], + abs(r__2)); + emax = f2cmax(r__3,r__4); +/* L100: */ + } + remax = 1.f / emax; + sscal_(&ki, &remax, &vr[(is - 1) * vr_dim1 + 1], &c__1); + sscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1); + + i__2 = *n; + for (k = ki + 1; k <= i__2; ++k) { + vr[k + (is - 1) * vr_dim1] = 0.f; + vr[k + is * vr_dim1] = 0.f; +/* L110: */ + } + + } else if (nb == 1) { +/* ------------------------------ */ +/* version 1: back-transform each vector with GEMV, Q*x. */ + if (ki > 2) { + i__2 = ki - 2; + sgemv_("N", n, &i__2, &c_b29, &vr[vr_offset], ldvr, & + work[(iv - 1) * *n + 1], &c__1, &work[ki - 1 + + (iv - 1) * *n], &vr[(ki - 1) * vr_dim1 + 1], + &c__1); + i__2 = ki - 2; + sgemv_("N", n, &i__2, &c_b29, &vr[vr_offset], ldvr, & + work[iv * *n + 1], &c__1, &work[ki + iv * *n], + &vr[ki * vr_dim1 + 1], &c__1); + } else { + sscal_(n, &work[ki - 1 + (iv - 1) * *n], &vr[(ki - 1) + * vr_dim1 + 1], &c__1); + sscal_(n, &work[ki + iv * *n], &vr[ki * vr_dim1 + 1], + &c__1); + } + + emax = 0.f; + i__2 = *n; + for (k = 1; k <= i__2; ++k) { +/* Computing MAX */ + r__3 = emax, r__4 = (r__1 = vr[k + (ki - 1) * vr_dim1] + , abs(r__1)) + (r__2 = vr[k + ki * vr_dim1], + abs(r__2)); + emax = f2cmax(r__3,r__4); +/* L120: */ + } + remax = 1.f / emax; + sscal_(n, &remax, &vr[(ki - 1) * vr_dim1 + 1], &c__1); + sscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1); + + } else { +/* ------------------------------ */ +/* version 2: back-transform block of vectors with GEMM */ +/* zero out below vector */ + i__2 = *n; + for (k = ki + 1; k <= i__2; ++k) { + work[k + (iv - 1) * *n] = 0.f; + work[k + iv * *n] = 0.f; + } + iscomplex[iv - 2] = -ip; + iscomplex[iv - 1] = ip; + --iv; +/* back-transform and normalization is done below */ + } + } + if (nb > 1) { +/* -------------------------------------------------------- */ +/* Blocked version of back-transform */ +/* For complex case, KI2 includes both vectors (KI-1 and KI) */ + if (ip == 0) { + ki2 = ki; + } else { + ki2 = ki - 1; + } +/* Columns IV:NB of work are valid vectors. */ +/* When the number of vectors stored reaches NB-1 or NB, */ +/* or if this was last vector, do the GEMM */ + if (iv <= 2 || ki2 == 1) { + i__2 = nb - iv + 1; + i__3 = ki2 + nb - iv; + sgemm_("N", "N", n, &i__2, &i__3, &c_b29, &vr[vr_offset], + ldvr, &work[iv * *n + 1], n, &c_b17, &work[(nb + + iv) * *n + 1], n); +/* normalize vectors */ + i__2 = nb; + for (k = iv; k <= i__2; ++k) { + if (iscomplex[k - 1] == 0) { +/* real eigenvector */ + ii = isamax_(n, &work[(nb + k) * *n + 1], &c__1); + remax = 1.f / (r__1 = work[ii + (nb + k) * *n], + abs(r__1)); + } else if (iscomplex[k - 1] == 1) { +/* first eigenvector of conjugate pair */ + emax = 0.f; + i__3 = *n; + for (ii = 1; ii <= i__3; ++ii) { +/* Computing MAX */ + r__3 = emax, r__4 = (r__1 = work[ii + (nb + k) + * *n], abs(r__1)) + (r__2 = work[ii + + (nb + k + 1) * *n], abs(r__2)); + emax = f2cmax(r__3,r__4); + } + remax = 1.f / emax; +/* else if ISCOMPLEX(K).EQ.-1 */ +/* second eigenvector of conjugate pair */ +/* reuse same REMAX as previous K */ + } + sscal_(n, &remax, &work[(nb + k) * *n + 1], &c__1); + } + i__2 = nb - iv + 1; + slacpy_("F", n, &i__2, &work[(nb + iv) * *n + 1], n, &vr[ + ki2 * vr_dim1 + 1], ldvr); + iv = nb; + } else { + --iv; + } + } + +/* blocked back-transform */ + --is; + if (ip != 0) { + --is; + } +L140: + ; + } + } + if (leftv) { + +/* ============================================================ */ +/* Compute left eigenvectors. */ + +/* IV is index of column in current block. */ +/* For complex left vector, uses IV for real part and IV+1 for complex part. */ +/* Non-blocked version always uses IV=1; */ +/* blocked version starts with IV=1, goes up to NB-1 or NB. */ +/* (Note the "0-th" column is used for 1-norms computed above.) */ + iv = 1; + ip = 0; + is = 1; + i__2 = *n; + for (ki = 1; ki <= i__2; ++ki) { + if (ip == 1) { +/* previous iteration (ki-1) was first of conjugate pair, */ +/* so this ki is second of conjugate pair; skip to end of loop */ + ip = -1; + goto L260; + } else if (ki == *n) { +/* last column, so this ki must be real eigenvalue */ + ip = 0; + } else if (t[ki + 1 + ki * t_dim1] == 0.f) { +/* zero on sub-diagonal, so this ki is real eigenvalue */ + ip = 0; + } else { +/* non-zero on sub-diagonal, so this ki is first of conjugate pair */ + ip = 1; + } + + if (somev) { + if (! select[ki]) { + goto L260; + } + } + +/* Compute the KI-th eigenvalue (WR,WI). */ + + wr = t[ki + ki * t_dim1]; + wi = 0.f; + if (ip != 0) { + wi = sqrt((r__1 = t[ki + (ki + 1) * t_dim1], abs(r__1))) * + sqrt((r__2 = t[ki + 1 + ki * t_dim1], abs(r__2))); + } +/* Computing MAX */ + r__1 = ulp * (abs(wr) + abs(wi)); + smin = f2cmax(r__1,smlnum); + + if (ip == 0) { + +/* -------------------------------------------------------- */ +/* Real left eigenvector */ + + work[ki + iv * *n] = 1.f; + +/* Form right-hand side. */ + + i__3 = *n; + for (k = ki + 1; k <= i__3; ++k) { + work[k + iv * *n] = -t[ki + k * t_dim1]; +/* L160: */ + } + +/* Solve transposed quasi-triangular system: */ +/* [ T(KI+1:N,KI+1:N) - WR ]**T * X = SCALE*WORK */ + + vmax = 1.f; + vcrit = bignum; + + jnxt = ki + 1; + i__3 = *n; + for (j = ki + 1; j <= i__3; ++j) { + if (j < jnxt) { + goto L170; + } + j1 = j; + j2 = j; + jnxt = j + 1; + if (j < *n) { + if (t[j + 1 + j * t_dim1] != 0.f) { + j2 = j + 1; + jnxt = j + 2; + } + } + + if (j1 == j2) { + +/* 1-by-1 diagonal block */ + +/* Scale if necessary to avoid overflow when forming */ +/* the right-hand side. */ + + if (work[j] > vcrit) { + rec = 1.f / vmax; + i__4 = *n - ki + 1; + sscal_(&i__4, &rec, &work[ki + iv * *n], &c__1); + vmax = 1.f; + vcrit = bignum; + } + + i__4 = j - ki - 1; + work[j + iv * *n] -= sdot_(&i__4, &t[ki + 1 + j * + t_dim1], &c__1, &work[ki + 1 + iv * *n], & + c__1); + +/* Solve [ T(J,J) - WR ]**T * X = WORK */ + + slaln2_(&c_false, &c__1, &c__1, &smin, &c_b29, &t[j + + j * t_dim1], ldt, &c_b29, &c_b29, &work[j + + iv * *n], n, &wr, &c_b17, x, &c__2, &scale, & + xnorm, &ierr); + +/* Scale if necessary */ + + if (scale != 1.f) { + i__4 = *n - ki + 1; + sscal_(&i__4, &scale, &work[ki + iv * *n], &c__1); + } + work[j + iv * *n] = x[0]; +/* Computing MAX */ + r__2 = (r__1 = work[j + iv * *n], abs(r__1)); + vmax = f2cmax(r__2,vmax); + vcrit = bignum / vmax; + + } else { + +/* 2-by-2 diagonal block */ + +/* Scale if necessary to avoid overflow when forming */ +/* the right-hand side. */ + +/* Computing MAX */ + r__1 = work[j], r__2 = work[j + 1]; + beta = f2cmax(r__1,r__2); + if (beta > vcrit) { + rec = 1.f / vmax; + i__4 = *n - ki + 1; + sscal_(&i__4, &rec, &work[ki + iv * *n], &c__1); + vmax = 1.f; + vcrit = bignum; + } + + i__4 = j - ki - 1; + work[j + iv * *n] -= sdot_(&i__4, &t[ki + 1 + j * + t_dim1], &c__1, &work[ki + 1 + iv * *n], & + c__1); + + i__4 = j - ki - 1; + work[j + 1 + iv * *n] -= sdot_(&i__4, &t[ki + 1 + (j + + 1) * t_dim1], &c__1, &work[ki + 1 + iv * *n] + , &c__1); + +/* Solve */ +/* [ T(J,J)-WR T(J,J+1) ]**T * X = SCALE*( WORK1 ) */ +/* [ T(J+1,J) T(J+1,J+1)-WR ] ( WORK2 ) */ + + slaln2_(&c_true, &c__2, &c__1, &smin, &c_b29, &t[j + + j * t_dim1], ldt, &c_b29, &c_b29, &work[j + + iv * *n], n, &wr, &c_b17, x, &c__2, &scale, & + xnorm, &ierr); + +/* Scale if necessary */ + + if (scale != 1.f) { + i__4 = *n - ki + 1; + sscal_(&i__4, &scale, &work[ki + iv * *n], &c__1); + } + work[j + iv * *n] = x[0]; + work[j + 1 + iv * *n] = x[1]; + +/* Computing MAX */ + r__3 = (r__1 = work[j + iv * *n], abs(r__1)), r__4 = ( + r__2 = work[j + 1 + iv * *n], abs(r__2)), + r__3 = f2cmax(r__3,r__4); + vmax = f2cmax(r__3,vmax); + vcrit = bignum / vmax; + + } +L170: + ; + } + +/* Copy the vector x or Q*x to VL and normalize. */ + + if (! over) { +/* ------------------------------ */ +/* no back-transform: copy x to VL and normalize. */ + i__3 = *n - ki + 1; + scopy_(&i__3, &work[ki + iv * *n], &c__1, &vl[ki + is * + vl_dim1], &c__1); + + i__3 = *n - ki + 1; + ii = isamax_(&i__3, &vl[ki + is * vl_dim1], &c__1) + ki - + 1; + remax = 1.f / (r__1 = vl[ii + is * vl_dim1], abs(r__1)); + i__3 = *n - ki + 1; + sscal_(&i__3, &remax, &vl[ki + is * vl_dim1], &c__1); + + i__3 = ki - 1; + for (k = 1; k <= i__3; ++k) { + vl[k + is * vl_dim1] = 0.f; +/* L180: */ + } + + } else if (nb == 1) { +/* ------------------------------ */ +/* version 1: back-transform each vector with GEMV, Q*x. */ + if (ki < *n) { + i__3 = *n - ki; + sgemv_("N", n, &i__3, &c_b29, &vl[(ki + 1) * vl_dim1 + + 1], ldvl, &work[ki + 1 + iv * *n], &c__1, & + work[ki + iv * *n], &vl[ki * vl_dim1 + 1], & + c__1); + } + + ii = isamax_(n, &vl[ki * vl_dim1 + 1], &c__1); + remax = 1.f / (r__1 = vl[ii + ki * vl_dim1], abs(r__1)); + sscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1); + + } else { +/* ------------------------------ */ +/* version 2: back-transform block of vectors with GEMM */ +/* zero out above vector */ +/* could go from KI-NV+1 to KI-1 */ + i__3 = ki - 1; + for (k = 1; k <= i__3; ++k) { + work[k + iv * *n] = 0.f; + } + iscomplex[iv - 1] = ip; +/* back-transform and normalization is done below */ + } + } else { + +/* -------------------------------------------------------- */ +/* Complex left eigenvector. */ + +/* Initial solve: */ +/* [ ( T(KI,KI) T(KI,KI+1) )**T - (WR - I* WI) ]*X = 0. */ +/* [ ( T(KI+1,KI) T(KI+1,KI+1) ) ] */ + + if ((r__1 = t[ki + (ki + 1) * t_dim1], abs(r__1)) >= (r__2 = + t[ki + 1 + ki * t_dim1], abs(r__2))) { + work[ki + iv * *n] = wi / t[ki + (ki + 1) * t_dim1]; + work[ki + 1 + (iv + 1) * *n] = 1.f; + } else { + work[ki + iv * *n] = 1.f; + work[ki + 1 + (iv + 1) * *n] = -wi / t[ki + 1 + ki * + t_dim1]; + } + work[ki + 1 + iv * *n] = 0.f; + work[ki + (iv + 1) * *n] = 0.f; + +/* Form right-hand side. */ + + i__3 = *n; + for (k = ki + 2; k <= i__3; ++k) { + work[k + iv * *n] = -work[ki + iv * *n] * t[ki + k * + t_dim1]; + work[k + (iv + 1) * *n] = -work[ki + 1 + (iv + 1) * *n] * + t[ki + 1 + k * t_dim1]; +/* L190: */ + } + +/* Solve transposed quasi-triangular system: */ +/* [ T(KI+2:N,KI+2:N)**T - (WR-i*WI) ]*X = WORK1+i*WORK2 */ + + vmax = 1.f; + vcrit = bignum; + + jnxt = ki + 2; + i__3 = *n; + for (j = ki + 2; j <= i__3; ++j) { + if (j < jnxt) { + goto L200; + } + j1 = j; + j2 = j; + jnxt = j + 1; + if (j < *n) { + if (t[j + 1 + j * t_dim1] != 0.f) { + j2 = j + 1; + jnxt = j + 2; + } + } + + if (j1 == j2) { + +/* 1-by-1 diagonal block */ + +/* Scale if necessary to avoid overflow when */ +/* forming the right-hand side elements. */ + + if (work[j] > vcrit) { + rec = 1.f / vmax; + i__4 = *n - ki + 1; + sscal_(&i__4, &rec, &work[ki + iv * *n], &c__1); + i__4 = *n - ki + 1; + sscal_(&i__4, &rec, &work[ki + (iv + 1) * *n], & + c__1); + vmax = 1.f; + vcrit = bignum; + } + + i__4 = j - ki - 2; + work[j + iv * *n] -= sdot_(&i__4, &t[ki + 2 + j * + t_dim1], &c__1, &work[ki + 2 + iv * *n], & + c__1); + i__4 = j - ki - 2; + work[j + (iv + 1) * *n] -= sdot_(&i__4, &t[ki + 2 + j + * t_dim1], &c__1, &work[ki + 2 + (iv + 1) * * + n], &c__1); + +/* Solve [ T(J,J)-(WR-i*WI) ]*(X11+i*X12)= WK+I*WK2 */ + + r__1 = -wi; + slaln2_(&c_false, &c__1, &c__2, &smin, &c_b29, &t[j + + j * t_dim1], ldt, &c_b29, &c_b29, &work[j + + iv * *n], n, &wr, &r__1, x, &c__2, &scale, & + xnorm, &ierr); + +/* Scale if necessary */ + + if (scale != 1.f) { + i__4 = *n - ki + 1; + sscal_(&i__4, &scale, &work[ki + iv * *n], &c__1); + i__4 = *n - ki + 1; + sscal_(&i__4, &scale, &work[ki + (iv + 1) * *n], & + c__1); + } + work[j + iv * *n] = x[0]; + work[j + (iv + 1) * *n] = x[2]; +/* Computing MAX */ + r__3 = (r__1 = work[j + iv * *n], abs(r__1)), r__4 = ( + r__2 = work[j + (iv + 1) * *n], abs(r__2)), + r__3 = f2cmax(r__3,r__4); + vmax = f2cmax(r__3,vmax); + vcrit = bignum / vmax; + + } else { + +/* 2-by-2 diagonal block */ + +/* Scale if necessary to avoid overflow when forming */ +/* the right-hand side elements. */ + +/* Computing MAX */ + r__1 = work[j], r__2 = work[j + 1]; + beta = f2cmax(r__1,r__2); + if (beta > vcrit) { + rec = 1.f / vmax; + i__4 = *n - ki + 1; + sscal_(&i__4, &rec, &work[ki + iv * *n], &c__1); + i__4 = *n - ki + 1; + sscal_(&i__4, &rec, &work[ki + (iv + 1) * *n], & + c__1); + vmax = 1.f; + vcrit = bignum; + } + + i__4 = j - ki - 2; + work[j + iv * *n] -= sdot_(&i__4, &t[ki + 2 + j * + t_dim1], &c__1, &work[ki + 2 + iv * *n], & + c__1); + + i__4 = j - ki - 2; + work[j + (iv + 1) * *n] -= sdot_(&i__4, &t[ki + 2 + j + * t_dim1], &c__1, &work[ki + 2 + (iv + 1) * * + n], &c__1); + + i__4 = j - ki - 2; + work[j + 1 + iv * *n] -= sdot_(&i__4, &t[ki + 2 + (j + + 1) * t_dim1], &c__1, &work[ki + 2 + iv * *n] + , &c__1); + + i__4 = j - ki - 2; + work[j + 1 + (iv + 1) * *n] -= sdot_(&i__4, &t[ki + 2 + + (j + 1) * t_dim1], &c__1, &work[ki + 2 + ( + iv + 1) * *n], &c__1); + +/* Solve 2-by-2 complex linear equation */ +/* [ (T(j,j) T(j,j+1) )**T - (wr-i*wi)*I ]*X = SCALE*B */ +/* [ (T(j+1,j) T(j+1,j+1)) ] */ + + r__1 = -wi; + slaln2_(&c_true, &c__2, &c__2, &smin, &c_b29, &t[j + + j * t_dim1], ldt, &c_b29, &c_b29, &work[j + + iv * *n], n, &wr, &r__1, x, &c__2, &scale, & + xnorm, &ierr); + +/* Scale if necessary */ + + if (scale != 1.f) { + i__4 = *n - ki + 1; + sscal_(&i__4, &scale, &work[ki + iv * *n], &c__1); + i__4 = *n - ki + 1; + sscal_(&i__4, &scale, &work[ki + (iv + 1) * *n], & + c__1); + } + work[j + iv * *n] = x[0]; + work[j + (iv + 1) * *n] = x[2]; + work[j + 1 + iv * *n] = x[1]; + work[j + 1 + (iv + 1) * *n] = x[3]; +/* Computing MAX */ + r__1 = abs(x[0]), r__2 = abs(x[2]), r__1 = f2cmax(r__1, + r__2), r__2 = abs(x[1]), r__1 = f2cmax(r__1,r__2) + , r__2 = abs(x[3]), r__1 = f2cmax(r__1,r__2); + vmax = f2cmax(r__1,vmax); + vcrit = bignum / vmax; + + } +L200: + ; + } + +/* Copy the vector x or Q*x to VL and normalize. */ + + if (! over) { +/* ------------------------------ */ +/* no back-transform: copy x to VL and normalize. */ + i__3 = *n - ki + 1; + scopy_(&i__3, &work[ki + iv * *n], &c__1, &vl[ki + is * + vl_dim1], &c__1); + i__3 = *n - ki + 1; + scopy_(&i__3, &work[ki + (iv + 1) * *n], &c__1, &vl[ki + ( + is + 1) * vl_dim1], &c__1); + + emax = 0.f; + i__3 = *n; + for (k = ki; k <= i__3; ++k) { +/* Computing MAX */ + r__3 = emax, r__4 = (r__1 = vl[k + is * vl_dim1], abs( + r__1)) + (r__2 = vl[k + (is + 1) * vl_dim1], + abs(r__2)); + emax = f2cmax(r__3,r__4); +/* L220: */ + } + remax = 1.f / emax; + i__3 = *n - ki + 1; + sscal_(&i__3, &remax, &vl[ki + is * vl_dim1], &c__1); + i__3 = *n - ki + 1; + sscal_(&i__3, &remax, &vl[ki + (is + 1) * vl_dim1], &c__1) + ; + + i__3 = ki - 1; + for (k = 1; k <= i__3; ++k) { + vl[k + is * vl_dim1] = 0.f; + vl[k + (is + 1) * vl_dim1] = 0.f; +/* L230: */ + } + + } else if (nb == 1) { +/* ------------------------------ */ +/* version 1: back-transform each vector with GEMV, Q*x. */ + if (ki < *n - 1) { + i__3 = *n - ki - 1; + sgemv_("N", n, &i__3, &c_b29, &vl[(ki + 2) * vl_dim1 + + 1], ldvl, &work[ki + 2 + iv * *n], &c__1, & + work[ki + iv * *n], &vl[ki * vl_dim1 + 1], & + c__1); + i__3 = *n - ki - 1; + sgemv_("N", n, &i__3, &c_b29, &vl[(ki + 2) * vl_dim1 + + 1], ldvl, &work[ki + 2 + (iv + 1) * *n], & + c__1, &work[ki + 1 + (iv + 1) * *n], &vl[(ki + + 1) * vl_dim1 + 1], &c__1); + } else { + sscal_(n, &work[ki + iv * *n], &vl[ki * vl_dim1 + 1], + &c__1); + sscal_(n, &work[ki + 1 + (iv + 1) * *n], &vl[(ki + 1) + * vl_dim1 + 1], &c__1); + } + + emax = 0.f; + i__3 = *n; + for (k = 1; k <= i__3; ++k) { +/* Computing MAX */ + r__3 = emax, r__4 = (r__1 = vl[k + ki * vl_dim1], abs( + r__1)) + (r__2 = vl[k + (ki + 1) * vl_dim1], + abs(r__2)); + emax = f2cmax(r__3,r__4); +/* L240: */ + } + remax = 1.f / emax; + sscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1); + sscal_(n, &remax, &vl[(ki + 1) * vl_dim1 + 1], &c__1); + + } else { +/* ------------------------------ */ +/* version 2: back-transform block of vectors with GEMM */ +/* zero out above vector */ +/* could go from KI-NV+1 to KI-1 */ + i__3 = ki - 1; + for (k = 1; k <= i__3; ++k) { + work[k + iv * *n] = 0.f; + work[k + (iv + 1) * *n] = 0.f; + } + iscomplex[iv - 1] = ip; + iscomplex[iv] = -ip; + ++iv; +/* back-transform and normalization is done below */ + } + } + if (nb > 1) { +/* -------------------------------------------------------- */ +/* Blocked version of back-transform */ +/* For complex case, KI2 includes both vectors (KI and KI+1) */ + if (ip == 0) { + ki2 = ki; + } else { + ki2 = ki + 1; + } +/* Columns 1:IV of work are valid vectors. */ +/* When the number of vectors stored reaches NB-1 or NB, */ +/* or if this was last vector, do the GEMM */ + if (iv >= nb - 1 || ki2 == *n) { + i__3 = *n - ki2 + iv; + sgemm_("N", "N", n, &iv, &i__3, &c_b29, &vl[(ki2 - iv + 1) + * vl_dim1 + 1], ldvl, &work[ki2 - iv + 1 + *n], + n, &c_b17, &work[(nb + 1) * *n + 1], n); +/* normalize vectors */ + i__3 = iv; + for (k = 1; k <= i__3; ++k) { + if (iscomplex[k - 1] == 0) { +/* real eigenvector */ + ii = isamax_(n, &work[(nb + k) * *n + 1], &c__1); + remax = 1.f / (r__1 = work[ii + (nb + k) * *n], + abs(r__1)); + } else if (iscomplex[k - 1] == 1) { +/* first eigenvector of conjugate pair */ + emax = 0.f; + i__4 = *n; + for (ii = 1; ii <= i__4; ++ii) { +/* Computing MAX */ + r__3 = emax, r__4 = (r__1 = work[ii + (nb + k) + * *n], abs(r__1)) + (r__2 = work[ii + + (nb + k + 1) * *n], abs(r__2)); + emax = f2cmax(r__3,r__4); + } + remax = 1.f / emax; +/* else if ISCOMPLEX(K).EQ.-1 */ +/* second eigenvector of conjugate pair */ +/* reuse same REMAX as previous K */ + } + sscal_(n, &remax, &work[(nb + k) * *n + 1], &c__1); + } + slacpy_("F", n, &iv, &work[(nb + 1) * *n + 1], n, &vl[( + ki2 - iv + 1) * vl_dim1 + 1], ldvl); + iv = 1; + } else { + ++iv; + } + } + +/* blocked back-transform */ + ++is; + if (ip != 0) { + ++is; + } +L260: + ; + } + } + + return 0; + +/* End of STREVC3 */ + +} /* strevc3_ */ + diff --git a/lapack-netlib/SRC/strexc.c b/lapack-netlib/SRC/strexc.c new file mode 100644 index 000000000..93285a11f --- /dev/null +++ b/lapack-netlib/SRC/strexc.c @@ -0,0 +1,844 @@ +/* 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 STREXC */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STREXC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, */ +/* INFO ) */ + +/* CHARACTER COMPQ */ +/* INTEGER IFST, ILST, INFO, LDQ, LDT, N */ +/* REAL Q( LDQ, * ), T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STREXC reorders the real Schur factorization of a real matrix */ +/* > A = Q*T*Q**T, so that the diagonal block of T with row index IFST is */ +/* > moved to row ILST. */ +/* > */ +/* > The real Schur form T is reordered by an orthogonal similarity */ +/* > transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors */ +/* > is updated by postmultiplying it with Z. */ +/* > */ +/* > T must be in Schur canonical form (as returned by SHSEQR), that is, */ +/* > block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */ +/* > 2-by-2 diagonal block has its diagonal elements equal and its */ +/* > off-diagonal elements of opposite sign. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] COMPQ */ +/* > \verbatim */ +/* > COMPQ is CHARACTER*1 */ +/* > = 'V': update the matrix Q of Schur vectors; */ +/* > = 'N': do not update Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix T. N >= 0. */ +/* > If N == 0 arguments ILST and IFST may be any value. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] T */ +/* > \verbatim */ +/* > T is REAL array, dimension (LDT,N) */ +/* > On entry, the upper quasi-triangular matrix T, in Schur */ +/* > Schur canonical form. */ +/* > On exit, the reordered upper quasi-triangular matrix, again */ +/* > in Schur canonical form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is REAL array, dimension (LDQ,N) */ +/* > On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */ +/* > On exit, if COMPQ = 'V', Q has been postmultiplied by the */ +/* > orthogonal transformation matrix Z which reorders T. */ +/* > If COMPQ = 'N', Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= 1, and if */ +/* > COMPQ = 'V', LDQ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] IFST */ +/* > \verbatim */ +/* > IFST is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ILST */ +/* > \verbatim */ +/* > ILST is INTEGER */ +/* > */ +/* > Specify the reordering of the diagonal blocks of T. */ +/* > The block with row index IFST is moved to row ILST, by a */ +/* > sequence of transpositions between adjacent blocks. */ +/* > On exit, if IFST pointed on entry to the second row of a */ +/* > 2-by-2 block, it is changed to point to the first row; ILST */ +/* > always points to the first row of the block in its final */ +/* > position (which may differ from its input value by +1 or -1). */ +/* > 1 <= IFST <= N; 1 <= ILST <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > = 1: two adjacent blocks were too close to swap (the problem */ +/* > is very ill-conditioned); T may have been partially */ +/* > reordered, and ILST points to the first row of the */ +/* > current position of the block being moved. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int strexc_(char *compq, integer *n, real *t, integer *ldt, + real *q, integer *ldq, integer *ifst, integer *ilst, real *work, + integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, t_dim1, t_offset, i__1; + + /* Local variables */ + integer here; + extern logical lsame_(char *, char *); + logical wantq; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slaexc_( + logical *, integer *, real *, integer *, real *, integer *, + integer *, integer *, integer *, real *, integer *); + integer nbnext, nbf, nbl; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and test the input arguments. */ + + /* Parameter adjustments */ + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --work; + + /* Function Body */ + *info = 0; + wantq = lsame_(compq, "V"); + if (! wantq && ! lsame_(compq, "N")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldt < f2cmax(1,*n)) { + *info = -4; + } else if (*ldq < 1 || wantq && *ldq < f2cmax(1,*n)) { + *info = -6; + } else if ((*ifst < 1 || *ifst > *n) && *n > 0) { + *info = -7; + } else if ((*ilst < 1 || *ilst > *n) && *n > 0) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STREXC", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 1) { + return 0; + } + +/* Determine the first row of specified block */ +/* and find out it is 1 by 1 or 2 by 2. */ + + if (*ifst > 1) { + if (t[*ifst + (*ifst - 1) * t_dim1] != 0.f) { + --(*ifst); + } + } + nbf = 1; + if (*ifst < *n) { + if (t[*ifst + 1 + *ifst * t_dim1] != 0.f) { + nbf = 2; + } + } + +/* Determine the first row of the final block */ +/* and find out it is 1 by 1 or 2 by 2. */ + + if (*ilst > 1) { + if (t[*ilst + (*ilst - 1) * t_dim1] != 0.f) { + --(*ilst); + } + } + nbl = 1; + if (*ilst < *n) { + if (t[*ilst + 1 + *ilst * t_dim1] != 0.f) { + nbl = 2; + } + } + + if (*ifst == *ilst) { + return 0; + } + + if (*ifst < *ilst) { + +/* Update ILST */ + + if (nbf == 2 && nbl == 1) { + --(*ilst); + } + if (nbf == 1 && nbl == 2) { + ++(*ilst); + } + + here = *ifst; + +L10: + +/* Swap block with next one below */ + + if (nbf == 1 || nbf == 2) { + +/* Current block either 1 by 1 or 2 by 2 */ + + nbnext = 1; + if (here + nbf + 1 <= *n) { + if (t[here + nbf + 1 + (here + nbf) * t_dim1] != 0.f) { + nbnext = 2; + } + } + slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &here, & + nbf, &nbnext, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + here += nbnext; + +/* Test if 2 by 2 block breaks into two 1 by 1 blocks */ + + if (nbf == 2) { + if (t[here + 1 + here * t_dim1] == 0.f) { + nbf = 3; + } + } + + } else { + +/* Current block consists of two 1 by 1 blocks each of which */ +/* must be swapped individually */ + + nbnext = 1; + if (here + 3 <= *n) { + if (t[here + 3 + (here + 2) * t_dim1] != 0.f) { + nbnext = 2; + } + } + i__1 = here + 1; + slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, & + c__1, &nbnext, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + if (nbnext == 1) { + +/* Swap two 1 by 1 blocks, no problems possible */ + + slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + here, &c__1, &nbnext, &work[1], info); + ++here; + } else { + +/* Recompute NBNEXT in case 2 by 2 split */ + + if (t[here + 2 + (here + 1) * t_dim1] == 0.f) { + nbnext = 1; + } + if (nbnext == 2) { + +/* 2 by 2 Block did not split */ + + slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + here, &c__1, &nbnext, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + here += 2; + } else { + +/* 2 by 2 Block did split */ + + slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + here, &c__1, &c__1, &work[1], info); + i__1 = here + 1; + slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + i__1, &c__1, &c__1, &work[1], info); + here += 2; + } + } + } + if (here < *ilst) { + goto L10; + } + + } else { + + here = *ifst; +L20: + +/* Swap block with next one above */ + + if (nbf == 1 || nbf == 2) { + +/* Current block either 1 by 1 or 2 by 2 */ + + nbnext = 1; + if (here >= 3) { + if (t[here - 1 + (here - 2) * t_dim1] != 0.f) { + nbnext = 2; + } + } + i__1 = here - nbnext; + slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, & + nbnext, &nbf, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + here -= nbnext; + +/* Test if 2 by 2 block breaks into two 1 by 1 blocks */ + + if (nbf == 2) { + if (t[here + 1 + here * t_dim1] == 0.f) { + nbf = 3; + } + } + + } else { + +/* Current block consists of two 1 by 1 blocks each of which */ +/* must be swapped individually */ + + nbnext = 1; + if (here >= 3) { + if (t[here - 1 + (here - 2) * t_dim1] != 0.f) { + nbnext = 2; + } + } + i__1 = here - nbnext; + slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, & + nbnext, &c__1, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + if (nbnext == 1) { + +/* Swap two 1 by 1 blocks, no problems possible */ + + slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + here, &nbnext, &c__1, &work[1], info); + --here; + } else { + +/* Recompute NBNEXT in case 2 by 2 split */ + + if (t[here + (here - 1) * t_dim1] == 0.f) { + nbnext = 1; + } + if (nbnext == 2) { + +/* 2 by 2 Block did not split */ + + i__1 = here - 1; + slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + i__1, &c__2, &c__1, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + here += -2; + } else { + +/* 2 by 2 Block did split */ + + slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + here, &c__1, &c__1, &work[1], info); + i__1 = here - 1; + slaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + i__1, &c__1, &c__1, &work[1], info); + here += -2; + } + } + } + if (here > *ilst) { + goto L20; + } + } + *ilst = here; + + return 0; + +/* End of STREXC */ + +} /* strexc_ */ + diff --git a/lapack-netlib/SRC/strrfs.c b/lapack-netlib/SRC/strrfs.c new file mode 100644 index 000000000..1d0a1897f --- /dev/null +++ b/lapack-netlib/SRC/strrfs.c @@ -0,0 +1,945 @@ +/* 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 STRRFS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STRRFS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, */ +/* LDX, FERR, BERR, WORK, IWORK, INFO ) */ + +/* CHARACTER DIAG, TRANS, UPLO */ +/* INTEGER INFO, LDA, LDB, LDX, N, NRHS */ +/* INTEGER IWORK( * ) */ +/* REAL A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ), */ +/* $ WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STRRFS provides error bounds and backward error estimates for the */ +/* > solution to a system of linear equations with a triangular */ +/* > coefficient matrix. */ +/* > */ +/* > The solution matrix X must be computed by STRTRS or some other */ +/* > means before entering this routine. STRRFS does not do iterative */ +/* > refinement because doing so cannot improve the backward error. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > The triangular matrix A. If UPLO = 'U', the leading N-by-N */ +/* > upper triangular part of the array A contains the upper */ +/* > triangular matrix, and the strictly lower triangular part of */ +/* > A is not referenced. If UPLO = 'L', the leading N-by-N lower */ +/* > triangular part of the array A contains the lower triangular */ +/* > matrix, and the strictly upper triangular part of A is not */ +/* > referenced. If DIAG = 'U', the diagonal elements of A are */ +/* > also not referenced and are assumed to be 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,NRHS) */ +/* > The right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (LDX,NRHS) */ +/* > The solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is REAL array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is REAL array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int strrfs_(char *uplo, char *trans, char *diag, integer *n, + integer *nrhs, real *a, integer *lda, real *b, integer *ldb, real *x, + integer *ldx, real *ferr, real *berr, real *work, integer *iwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, + i__3; + real r__1, r__2, r__3; + + /* Local variables */ + integer kase; + real safe1, safe2; + integer i__, j, k; + real s; + extern logical lsame_(char *, char *); + integer isave[3]; + logical upper; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *), saxpy_(integer *, real *, real *, integer *, real *, + integer *), strmv_(char *, char *, char *, integer *, real *, + integer *, real *, integer *), strsv_( + char *, char *, char *, integer *, real *, integer *, real *, + integer *), slacn2_(integer *, real *, + real *, integer *, real *, integer *, integer *); + real xk; + extern real slamch_(char *); + integer nz; + real safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical notran; + char transt[1]; + logical nounit; + real lstres, eps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + notran = lsame_(trans, "N"); + nounit = lsame_(diag, "N"); + + 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 (*n < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*lda < f2cmax(1,*n)) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } else if (*ldx < f2cmax(1,*n)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STRRFS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.f; + berr[j] = 0.f; +/* L10: */ + } + return 0; + } + + if (notran) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = *n + 1; + eps = slamch_("Epsilon"); + safmin = slamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Compute residual R = B - op(A) * X, */ +/* where op(A) = A or A**T, depending on TRANS. */ + + scopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1); + strmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1], &c__1); + saxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* f2cmax(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] = (r__1 = b[i__ + j * b_dim1], abs(r__1)); +/* L20: */ + } + + if (notran) { + +/* Compute abs(A)*abs(X) + abs(B). */ + + if (upper) { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (r__1 = x[k + j * x_dim1], abs(r__1)); + i__3 = k; + for (i__ = 1; i__ <= i__3; ++i__) { + work[i__] += (r__1 = a[i__ + k * a_dim1], abs( + r__1)) * xk; +/* L30: */ + } +/* L40: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (r__1 = x[k + j * x_dim1], abs(r__1)); + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + work[i__] += (r__1 = a[i__ + k * a_dim1], abs( + r__1)) * xk; +/* L50: */ + } + work[k] += xk; +/* L60: */ + } + } + } else { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (r__1 = x[k + j * x_dim1], abs(r__1)); + i__3 = *n; + for (i__ = k; i__ <= i__3; ++i__) { + work[i__] += (r__1 = a[i__ + k * a_dim1], abs( + r__1)) * xk; +/* L70: */ + } +/* L80: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (r__1 = x[k + j * x_dim1], abs(r__1)); + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + work[i__] += (r__1 = a[i__ + k * a_dim1], abs( + r__1)) * xk; +/* L90: */ + } + work[k] += xk; +/* L100: */ + } + } + } + } else { + +/* Compute abs(A**T)*abs(X) + abs(B). */ + + if (upper) { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; + i__3 = k; + for (i__ = 1; i__ <= i__3; ++i__) { + s += (r__1 = a[i__ + k * a_dim1], abs(r__1)) * ( + r__2 = x[i__ + j * x_dim1], abs(r__2)); +/* L110: */ + } + work[k] += s; +/* L120: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = (r__1 = x[k + j * x_dim1], abs(r__1)); + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + s += (r__1 = a[i__ + k * a_dim1], abs(r__1)) * ( + r__2 = x[i__ + j * x_dim1], abs(r__2)); +/* L130: */ + } + work[k] += s; +/* L140: */ + } + } + } else { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; + i__3 = *n; + for (i__ = k; i__ <= i__3; ++i__) { + s += (r__1 = a[i__ + k * a_dim1], abs(r__1)) * ( + r__2 = x[i__ + j * x_dim1], abs(r__2)); +/* L150: */ + } + work[k] += s; +/* L160: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = (r__1 = x[k + j * x_dim1], abs(r__1)); + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + s += (r__1 = a[i__ + k * a_dim1], abs(r__1)) * ( + r__2 = x[i__ + j * x_dim1], abs(r__2)); +/* L170: */ + } + work[k] += s; +/* L180: */ + } + } + } + } + s = 0.f; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + r__2 = s, r__3 = (r__1 = work[*n + i__], abs(r__1)) / work[ + i__]; + s = f2cmax(r__2,r__3); + } else { +/* Computing MAX */ + r__2 = s, r__3 = ((r__1 = work[*n + i__], abs(r__1)) + safe1) + / (work[i__] + safe1); + s = f2cmax(r__2,r__3); + } +/* L190: */ + } + berr[j] = s; + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(op(A)))* */ +/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(op(A)) is the inverse of op(A) */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ + +/* Use SLACN2 to estimate the infinity-norm of the matrix */ +/* inv(op(A)) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { + work[i__] = (r__1 = work[*n + i__], abs(r__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (r__1 = work[*n + i__], abs(r__1)) + nz * eps * + work[i__] + safe1; + } +/* L200: */ + } + + kase = 0; +L210: + slacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & + kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(op(A)**T). */ + + strsv_(uplo, transt, diag, n, &a[a_offset], lda, &work[*n + 1] + , &c__1); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L220: */ + } + } else { + +/* Multiply by inv(op(A))*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L230: */ + } + strsv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1], + &c__1); + } + goto L210; + } + +/* Normalize error. */ + + lstres = 0.f; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], abs(r__1)); + lstres = f2cmax(r__2,r__3); +/* L240: */ + } + if (lstres != 0.f) { + ferr[j] /= lstres; + } + +/* L250: */ + } + + return 0; + +/* End of STRRFS */ + +} /* strrfs_ */ + diff --git a/lapack-netlib/SRC/strsen.c b/lapack-netlib/SRC/strsen.c new file mode 100644 index 000000000..a27dff38f --- /dev/null +++ b/lapack-netlib/SRC/strsen.c @@ -0,0 +1,995 @@ +/* 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 STRSEN */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STRSEN + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, */ +/* M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO ) */ + +/* CHARACTER COMPQ, JOB */ +/* INTEGER INFO, LDQ, LDT, LIWORK, LWORK, M, N */ +/* REAL S, SEP */ +/* LOGICAL SELECT( * ) */ +/* INTEGER IWORK( * ) */ +/* REAL Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ), */ +/* $ WR( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STRSEN reorders the real Schur factorization of a real matrix */ +/* > A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in */ +/* > the leading diagonal blocks of the upper quasi-triangular matrix T, */ +/* > and the leading columns of Q form an orthonormal basis of the */ +/* > corresponding right invariant subspace. */ +/* > */ +/* > Optionally the routine computes the reciprocal condition numbers of */ +/* > the cluster of eigenvalues and/or the invariant subspace. */ +/* > */ +/* > T must be in Schur canonical form (as returned by SHSEQR), that is, */ +/* > block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */ +/* > 2-by-2 diagonal block has its diagonal elements equal and its */ +/* > off-diagonal elements of opposite sign. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOB */ +/* > \verbatim */ +/* > JOB is CHARACTER*1 */ +/* > Specifies whether condition numbers are required for the */ +/* > cluster of eigenvalues (S) or the invariant subspace (SEP): */ +/* > = 'N': none; */ +/* > = 'E': for eigenvalues only (S); */ +/* > = 'V': for invariant subspace only (SEP); */ +/* > = 'B': for both eigenvalues and invariant subspace (S and */ +/* > SEP). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COMPQ */ +/* > \verbatim */ +/* > COMPQ is CHARACTER*1 */ +/* > = 'V': update the matrix Q of Schur vectors; */ +/* > = 'N': do not update Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > SELECT specifies the eigenvalues in the selected cluster. To */ +/* > select a real eigenvalue w(j), SELECT(j) must be set to */ +/* > .TRUE.. To select a complex conjugate pair of eigenvalues */ +/* > w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, */ +/* > either SELECT(j) or SELECT(j+1) or both must be set to */ +/* > .TRUE.; a complex conjugate pair of eigenvalues must be */ +/* > either both included in the cluster or both excluded. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix T. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] T */ +/* > \verbatim */ +/* > T is REAL array, dimension (LDT,N) */ +/* > On entry, the upper quasi-triangular matrix T, in Schur */ +/* > canonical form. */ +/* > On exit, T is overwritten by the reordered matrix T, again in */ +/* > Schur canonical form, with the selected eigenvalues in the */ +/* > leading diagonal blocks. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is REAL array, dimension (LDQ,N) */ +/* > On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */ +/* > On exit, if COMPQ = 'V', Q has been postmultiplied by the */ +/* > orthogonal transformation matrix which reorders T; the */ +/* > leading M columns of Q form an orthonormal basis for the */ +/* > specified invariant subspace. */ +/* > If COMPQ = 'N', Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. */ +/* > LDQ >= 1; and if COMPQ = 'V', LDQ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WR */ +/* > \verbatim */ +/* > WR is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WI */ +/* > \verbatim */ +/* > WI is REAL array, dimension (N) */ +/* > */ +/* > The real and imaginary parts, respectively, of the reordered */ +/* > eigenvalues of T. The eigenvalues are stored in the same */ +/* > order as on the diagonal of T, with WR(i) = T(i,i) and, if */ +/* > T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and */ +/* > WI(i+1) = -WI(i). Note that if a complex eigenvalue is */ +/* > sufficiently ill-conditioned, then its value may differ */ +/* > significantly from its value before reordering. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The dimension of the specified invariant subspace. */ +/* > 0 < = M <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is REAL */ +/* > If JOB = 'E' or 'B', S is a lower bound on the reciprocal */ +/* > condition number for the selected cluster of eigenvalues. */ +/* > S cannot underestimate the true reciprocal condition number */ +/* > by more than a factor of sqrt(N). If M = 0 or N, S = 1. */ +/* > If JOB = 'N' or 'V', S is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SEP */ +/* > \verbatim */ +/* > SEP is REAL */ +/* > If JOB = 'V' or 'B', SEP is the estimated reciprocal */ +/* > condition number of the specified invariant subspace. If */ +/* > M = 0 or N, SEP = norm(T). */ +/* > If JOB = 'N' or 'E', SEP is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > If JOB = 'N', LWORK >= f2cmax(1,N); */ +/* > if JOB = 'E', LWORK >= f2cmax(1,M*(N-M)); */ +/* > if JOB = 'V' or 'B', LWORK >= f2cmax(1,2*M*(N-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] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */ +/* > On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the array IWORK. */ +/* > If JOB = 'N' or 'E', LIWORK >= 1; */ +/* > if JOB = 'V' or 'B', LIWORK >= f2cmax(1,M*(N-M)). */ +/* > */ +/* > If LIWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal size of the IWORK array, */ +/* > returns this value as the first entry of the IWORK array, and */ +/* > no error message related to LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > = 1: reordering of T failed because some eigenvalues are too */ +/* > close to separate (the problem is very ill-conditioned); */ +/* > T may have been partially reordered, and WR and WI */ +/* > contain the eigenvalues in the same order as in T; S and */ +/* > SEP (if requested) are set to zero. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STRSEN first collects the selected eigenvalues by computing an */ +/* > orthogonal transformation Z to move them to the top left corner of T. */ +/* > In other words, the selected eigenvalues are the eigenvalues of T11 */ +/* > in: */ +/* > */ +/* > Z**T * T * Z = ( T11 T12 ) n1 */ +/* > ( 0 T22 ) n2 */ +/* > n1 n2 */ +/* > */ +/* > where N = n1+n2 and Z**T means the transpose of Z. The first n1 columns */ +/* > of Z span the specified invariant subspace of T. */ +/* > */ +/* > If T has been obtained from the real Schur factorization of a matrix */ +/* > A = Q*T*Q**T, then the reordered real Schur factorization of A is given */ +/* > by A = (Q*Z)*(Z**T*T*Z)*(Q*Z)**T, and the first n1 columns of Q*Z span */ +/* > the corresponding invariant subspace of A. */ +/* > */ +/* > The reciprocal condition number of the average of the eigenvalues of */ +/* > T11 may be returned in S. S lies between 0 (very badly conditioned) */ +/* > and 1 (very well conditioned). It is computed as follows. First we */ +/* > compute R so that */ +/* > */ +/* > P = ( I R ) n1 */ +/* > ( 0 0 ) n2 */ +/* > n1 n2 */ +/* > */ +/* > is the projector on the invariant subspace associated with T11. */ +/* > R is the solution of the Sylvester equation: */ +/* > */ +/* > T11*R - R*T22 = T12. */ +/* > */ +/* > Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote */ +/* > the two-norm of M. Then S is computed as the lower bound */ +/* > */ +/* > (1 + F-norm(R)**2)**(-1/2) */ +/* > */ +/* > on the reciprocal of 2-norm(P), the true reciprocal condition number. */ +/* > S cannot underestimate 1 / 2-norm(P) by more than a factor of */ +/* > sqrt(N). */ +/* > */ +/* > An approximate error bound for the computed average of the */ +/* > eigenvalues of T11 is */ +/* > */ +/* > EPS * norm(T) / S */ +/* > */ +/* > where EPS is the machine precision. */ +/* > */ +/* > The reciprocal condition number of the right invariant subspace */ +/* > spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. */ +/* > SEP is defined as the separation of T11 and T22: */ +/* > */ +/* > sep( T11, T22 ) = sigma-f2cmin( C ) */ +/* > */ +/* > where sigma-f2cmin(C) is the smallest singular value of the */ +/* > n1*n2-by-n1*n2 matrix */ +/* > */ +/* > C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) */ +/* > */ +/* > I(m) is an m by m identity matrix, and kprod denotes the Kronecker */ +/* > product. We estimate sigma-f2cmin(C) by the reciprocal of an estimate of */ +/* > the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) */ +/* > cannot differ from sigma-f2cmin(C) by more than a factor of sqrt(n1*n2). */ +/* > */ +/* > When SEP is small, small changes in T can cause large changes in */ +/* > the invariant subspace. An approximate bound on the maximum angular */ +/* > error in the computed right invariant subspace is */ +/* > */ +/* > EPS * norm(T) / SEP */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int strsen_(char *job, char *compq, logical *select, integer + *n, real *t, integer *ldt, real *q, integer *ldq, real *wr, real *wi, + integer *m, real *s, real *sep, real *work, integer *lwork, integer * + iwork, integer *liwork, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2; + real r__1, r__2; + + /* Local variables */ + integer kase; + logical pair; + integer ierr; + logical swap; + integer k; + real scale; + extern logical lsame_(char *, char *); + integer isave[3], lwmin; + logical wantq, wants; + real rnorm; + integer n1, n2; + extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *, + real *, integer *, integer *); + integer kk, nn, ks; + extern real slange_(char *, integer *, integer *, real *, integer *, real + *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical wantbh; + extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, + integer *, real *, integer *); + integer liwmin; + extern /* Subroutine */ int strexc_(char *, integer *, real *, integer *, + real *, integer *, integer *, integer *, real *, integer *); + logical wantsp, lquery; + extern /* Subroutine */ int strsyl_(char *, char *, integer *, integer *, + integer *, real *, integer *, real *, integer *, real *, integer * + , real *, integer *); + real est; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + --select; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --wr; + --wi; + --work; + --iwork; + + /* Function Body */ + wantbh = lsame_(job, "B"); + wants = lsame_(job, "E") || wantbh; + wantsp = lsame_(job, "V") || wantbh; + wantq = lsame_(compq, "V"); + + *info = 0; + lquery = *lwork == -1; + if (! lsame_(job, "N") && ! wants && ! wantsp) { + *info = -1; + } else if (! lsame_(compq, "N") && ! wantq) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*ldt < f2cmax(1,*n)) { + *info = -6; + } else if (*ldq < 1 || wantq && *ldq < *n) { + *info = -8; + } else { + +/* Set M to the dimension of the specified invariant subspace, */ +/* and test LWORK and LIWORK. */ + + *m = 0; + pair = FALSE_; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = FALSE_; + } else { + if (k < *n) { + if (t[k + 1 + k * t_dim1] == 0.f) { + if (select[k]) { + ++(*m); + } + } else { + pair = TRUE_; + if (select[k] || select[k + 1]) { + *m += 2; + } + } + } else { + if (select[*n]) { + ++(*m); + } + } + } +/* L10: */ + } + + n1 = *m; + n2 = *n - *m; + nn = n1 * n2; + + if (wantsp) { +/* Computing MAX */ + i__1 = 1, i__2 = nn << 1; + lwmin = f2cmax(i__1,i__2); + liwmin = f2cmax(1,nn); + } else if (lsame_(job, "N")) { + lwmin = f2cmax(1,*n); + liwmin = 1; + } else if (lsame_(job, "E")) { + lwmin = f2cmax(1,nn); + liwmin = 1; + } + + if (*lwork < lwmin && ! lquery) { + *info = -15; + } else if (*liwork < liwmin && ! lquery) { + *info = -17; + } + } + + if (*info == 0) { + work[1] = (real) lwmin; + iwork[1] = liwmin; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("STRSEN", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible. */ + + if (*m == *n || *m == 0) { + if (wants) { + *s = 1.f; + } + if (wantsp) { + *sep = slange_("1", n, n, &t[t_offset], ldt, &work[1]); + } + goto L40; + } + +/* Collect the selected blocks at the top-left corner of T. */ + + ks = 0; + pair = FALSE_; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = FALSE_; + } else { + swap = select[k]; + if (k < *n) { + if (t[k + 1 + k * t_dim1] != 0.f) { + pair = TRUE_; + swap = swap || select[k + 1]; + } + } + if (swap) { + ++ks; + +/* Swap the K-th block to position KS. */ + + ierr = 0; + kk = k; + if (k != ks) { + strexc_(compq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + kk, &ks, &work[1], &ierr); + } + if (ierr == 1 || ierr == 2) { + +/* Blocks too close to swap: exit. */ + + *info = 1; + if (wants) { + *s = 0.f; + } + if (wantsp) { + *sep = 0.f; + } + goto L40; + } + if (pair) { + ++ks; + } + } + } +/* L20: */ + } + + if (wants) { + +/* Solve Sylvester equation for R: */ + +/* T11*R - R*T22 = scale*T12 */ + + slacpy_("F", &n1, &n2, &t[(n1 + 1) * t_dim1 + 1], ldt, &work[1], &n1); + strsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1 + + 1) * t_dim1], ldt, &work[1], &n1, &scale, &ierr); + +/* Estimate the reciprocal of the condition number of the cluster */ +/* of eigenvalues. */ + + rnorm = slange_("F", &n1, &n2, &work[1], &n1, &work[1]); + if (rnorm == 0.f) { + *s = 1.f; + } else { + *s = scale / (sqrt(scale * scale / rnorm + rnorm) * sqrt(rnorm)); + } + } + + if (wantsp) { + +/* Estimate sep(T11,T22). */ + + est = 0.f; + kase = 0; +L30: + slacn2_(&nn, &work[nn + 1], &work[1], &iwork[1], &est, &kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Solve T11*R - R*T22 = scale*X. */ + + strsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + + 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, & + ierr); + } else { + +/* Solve T11**T*R - R*T22**T = scale*X. */ + + strsyl_("T", "T", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + + 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, & + ierr); + } + goto L30; + } + + *sep = scale / est; + } + +L40: + +/* Store the output eigenvalues in WR and WI. */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + wr[k] = t[k + k * t_dim1]; + wi[k] = 0.f; +/* L50: */ + } + i__1 = *n - 1; + for (k = 1; k <= i__1; ++k) { + if (t[k + 1 + k * t_dim1] != 0.f) { + wi[k] = sqrt((r__1 = t[k + (k + 1) * t_dim1], abs(r__1))) * sqrt(( + r__2 = t[k + 1 + k * t_dim1], abs(r__2))); + wi[k + 1] = -wi[k]; + } +/* L60: */ + } + + work[1] = (real) lwmin; + iwork[1] = liwmin; + + return 0; + +/* End of STRSEN */ + +} /* strsen_ */ + diff --git a/lapack-netlib/SRC/strsna.c b/lapack-netlib/SRC/strsna.c new file mode 100644 index 000000000..1f8ef2b6b --- /dev/null +++ b/lapack-netlib/SRC/strsna.c @@ -0,0 +1,1066 @@ +/* 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 STRSNA */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STRSNA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, */ +/* LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, */ +/* INFO ) */ + +/* CHARACTER HOWMNY, JOB */ +/* INTEGER INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N */ +/* LOGICAL SELECT( * ) */ +/* INTEGER IWORK( * ) */ +/* REAL S( * ), SEP( * ), T( LDT, * ), VL( LDVL, * ), */ +/* $ VR( LDVR, * ), WORK( LDWORK, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STRSNA estimates reciprocal condition numbers for specified */ +/* > eigenvalues and/or right eigenvectors of a real upper */ +/* > quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q */ +/* > orthogonal). */ +/* > */ +/* > T must be in Schur canonical form (as returned by SHSEQR), that is, */ +/* > block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */ +/* > 2-by-2 diagonal block has its diagonal elements equal and its */ +/* > off-diagonal elements of opposite sign. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOB */ +/* > \verbatim */ +/* > JOB is CHARACTER*1 */ +/* > Specifies whether condition numbers are required for */ +/* > eigenvalues (S) or eigenvectors (SEP): */ +/* > = 'E': for eigenvalues only (S); */ +/* > = 'V': for eigenvectors only (SEP); */ +/* > = 'B': for both eigenvalues and eigenvectors (S and SEP). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] HOWMNY */ +/* > \verbatim */ +/* > HOWMNY is CHARACTER*1 */ +/* > = 'A': compute condition numbers for all eigenpairs; */ +/* > = 'S': compute condition numbers for selected eigenpairs */ +/* > specified by the array SELECT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > If HOWMNY = 'S', SELECT specifies the eigenpairs for which */ +/* > condition numbers are required. To select condition numbers */ +/* > for the eigenpair corresponding to a real eigenvalue w(j), */ +/* > SELECT(j) must be set to .TRUE.. To select condition numbers */ +/* > corresponding to a complex conjugate pair of eigenvalues w(j) */ +/* > and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be */ +/* > set to .TRUE.. */ +/* > If HOWMNY = 'A', SELECT is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix T. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is REAL array, dimension (LDT,N) */ +/* > The upper quasi-triangular matrix T, in Schur canonical form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VL */ +/* > \verbatim */ +/* > VL is REAL array, dimension (LDVL,M) */ +/* > If JOB = 'E' or 'B', VL must contain left eigenvectors of T */ +/* > (or of any Q*T*Q**T with Q orthogonal), corresponding to the */ +/* > eigenpairs specified by HOWMNY and SELECT. The eigenvectors */ +/* > must be stored in consecutive columns of VL, as returned by */ +/* > SHSEIN or STREVC. */ +/* > If JOB = 'V', VL is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the array VL. */ +/* > LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VR */ +/* > \verbatim */ +/* > VR is REAL array, dimension (LDVR,M) */ +/* > If JOB = 'E' or 'B', VR must contain right eigenvectors of T */ +/* > (or of any Q*T*Q**T with Q orthogonal), corresponding to the */ +/* > eigenpairs specified by HOWMNY and SELECT. The eigenvectors */ +/* > must be stored in consecutive columns of VR, as returned by */ +/* > SHSEIN or STREVC. */ +/* > If JOB = 'V', VR is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the array VR. */ +/* > LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (MM) */ +/* > If JOB = 'E' or 'B', the reciprocal condition numbers of the */ +/* > selected eigenvalues, stored in consecutive elements of the */ +/* > array. For a complex conjugate pair of eigenvalues two */ +/* > consecutive elements of S are set to the same value. Thus */ +/* > S(j), SEP(j), and the j-th columns of VL and VR all */ +/* > correspond to the same eigenpair (but not in general the */ +/* > j-th eigenpair, unless all eigenpairs are selected). */ +/* > If JOB = 'V', S is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SEP */ +/* > \verbatim */ +/* > SEP is REAL array, dimension (MM) */ +/* > If JOB = 'V' or 'B', the estimated reciprocal condition */ +/* > numbers of the selected eigenvectors, stored in consecutive */ +/* > elements of the array. For a complex eigenvector two */ +/* > consecutive elements of SEP are set to the same value. If */ +/* > the eigenvalues cannot be reordered to compute SEP(j), SEP(j) */ +/* > is set to 0; this can only occur when the true value would be */ +/* > very small anyway. */ +/* > If JOB = 'E', SEP is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MM */ +/* > \verbatim */ +/* > MM is INTEGER */ +/* > The number of elements in the arrays S (if JOB = 'E' or 'B') */ +/* > and/or SEP (if JOB = 'V' or 'B'). MM >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of elements of the arrays S and/or SEP actually */ +/* > used to store the estimated condition numbers. */ +/* > If HOWMNY = 'A', M is set to N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (LDWORK,N+6) */ +/* > If JOB = 'E', WORK is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDWORK */ +/* > \verbatim */ +/* > LDWORK is INTEGER */ +/* > The leading dimension of the array WORK. */ +/* > LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (2*(N-1)) */ +/* > If JOB = 'E', IWORK is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The reciprocal of the condition number of an eigenvalue lambda is */ +/* > defined as */ +/* > */ +/* > S(lambda) = |v**T*u| / (norm(u)*norm(v)) */ +/* > */ +/* > where u and v are the right and left eigenvectors of T corresponding */ +/* > to lambda; v**T denotes the transpose of v, and norm(u) */ +/* > denotes the Euclidean norm. These reciprocal condition numbers always */ +/* > lie between zero (very badly conditioned) and one (very well */ +/* > conditioned). If n = 1, S(lambda) is defined to be 1. */ +/* > */ +/* > An approximate error bound for a computed eigenvalue W(i) is given by */ +/* > */ +/* > EPS * norm(T) / S(i) */ +/* > */ +/* > where EPS is the machine precision. */ +/* > */ +/* > The reciprocal of the condition number of the right eigenvector u */ +/* > corresponding to lambda is defined as follows. Suppose */ +/* > */ +/* > T = ( lambda c ) */ +/* > ( 0 T22 ) */ +/* > */ +/* > Then the reciprocal condition number is */ +/* > */ +/* > SEP( lambda, T22 ) = sigma-f2cmin( T22 - lambda*I ) */ +/* > */ +/* > where sigma-f2cmin denotes the smallest singular value. We approximate */ +/* > the smallest singular value by the reciprocal of an estimate of the */ +/* > one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is */ +/* > defined to be abs(T(1,1)). */ +/* > */ +/* > An approximate error bound for a computed right eigenvector VR(i) */ +/* > is given by */ +/* > */ +/* > EPS * norm(T) / SEP(i) */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int strsna_(char *job, char *howmny, logical *select, + integer *n, real *t, integer *ldt, real *vl, integer *ldvl, real *vr, + integer *ldvr, real *s, real *sep, integer *mm, integer *m, real * + work, integer *ldwork, integer *iwork, integer *info) +{ + /* System generated locals */ + integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, + work_dim1, work_offset, i__1, i__2; + real r__1, r__2; + + /* Local variables */ + integer kase; + real cond; + logical pair; + integer ierr; + real dumm, prod; + integer ifst; + real lnrm; + extern real sdot_(integer *, real *, integer *, real *, integer *); + integer ilst; + real rnrm, prod1, prod2; + extern real snrm2_(integer *, real *, integer *); + integer i__, j, k; + real scale, delta; + extern logical lsame_(char *, char *); + integer isave[3]; + logical wants; + real dummy[1]; + integer n2; + extern /* Subroutine */ int slacn2_(integer *, real *, real *, integer *, + real *, integer *, integer *); + extern real slapy2_(real *, real *); + real cs; + extern /* Subroutine */ int slabad_(real *, real *); + integer nn, ks; + real sn, mu; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real bignum; + logical wantbh; + extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, + integer *, real *, integer *); + logical somcon; + extern /* Subroutine */ int slaqtr_(logical *, logical *, integer *, real + *, integer *, real *, real *, real *, real *, real *, integer *), + strexc_(char *, integer *, real *, integer *, real *, integer *, + integer *, integer *, real *, integer *); + real smlnum; + logical wantsp; + real eps, est; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + --select; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --s; + --sep; + work_dim1 = *ldwork; + work_offset = 1 + work_dim1 * 1; + work -= work_offset; + --iwork; + + /* Function Body */ + wantbh = lsame_(job, "B"); + wants = lsame_(job, "E") || wantbh; + wantsp = lsame_(job, "V") || wantbh; + + somcon = lsame_(howmny, "S"); + + *info = 0; + if (! wants && ! wantsp) { + *info = -1; + } else if (! lsame_(howmny, "A") && ! somcon) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*ldt < f2cmax(1,*n)) { + *info = -6; + } else if (*ldvl < 1 || wants && *ldvl < *n) { + *info = -8; + } else if (*ldvr < 1 || wants && *ldvr < *n) { + *info = -10; + } else { + +/* Set M to the number of eigenpairs for which condition numbers */ +/* are required, and test MM. */ + + if (somcon) { + *m = 0; + pair = FALSE_; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = FALSE_; + } else { + if (k < *n) { + if (t[k + 1 + k * t_dim1] == 0.f) { + if (select[k]) { + ++(*m); + } + } else { + pair = TRUE_; + if (select[k] || select[k + 1]) { + *m += 2; + } + } + } else { + if (select[*n]) { + ++(*m); + } + } + } +/* L10: */ + } + } else { + *m = *n; + } + + if (*mm < *m) { + *info = -13; + } else if (*ldwork < 1 || wantsp && *ldwork < *n) { + *info = -16; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STRSNA", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (somcon) { + if (! select[1]) { + return 0; + } + } + if (wants) { + s[1] = 1.f; + } + if (wantsp) { + sep[1] = (r__1 = t[t_dim1 + 1], abs(r__1)); + } + return 0; + } + +/* Get machine constants */ + + eps = slamch_("P"); + smlnum = slamch_("S") / eps; + bignum = 1.f / smlnum; + slabad_(&smlnum, &bignum); + + ks = 0; + pair = FALSE_; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + +/* Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block. */ + + if (pair) { + pair = FALSE_; + goto L60; + } else { + if (k < *n) { + pair = t[k + 1 + k * t_dim1] != 0.f; + } + } + +/* Determine whether condition numbers are required for the k-th */ +/* eigenpair. */ + + if (somcon) { + if (pair) { + if (! select[k] && ! select[k + 1]) { + goto L60; + } + } else { + if (! select[k]) { + goto L60; + } + } + } + + ++ks; + + if (wants) { + +/* Compute the reciprocal condition number of the k-th */ +/* eigenvalue. */ + + if (! pair) { + +/* Real eigenvalue. */ + + prod = sdot_(n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks * + vl_dim1 + 1], &c__1); + rnrm = snrm2_(n, &vr[ks * vr_dim1 + 1], &c__1); + lnrm = snrm2_(n, &vl[ks * vl_dim1 + 1], &c__1); + s[ks] = abs(prod) / (rnrm * lnrm); + } else { + +/* Complex eigenvalue. */ + + prod1 = sdot_(n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks * + vl_dim1 + 1], &c__1); + prod1 += sdot_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1, &vl[(ks + + 1) * vl_dim1 + 1], &c__1); + prod2 = sdot_(n, &vl[ks * vl_dim1 + 1], &c__1, &vr[(ks + 1) * + vr_dim1 + 1], &c__1); + prod2 -= sdot_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1, &vr[ks * + vr_dim1 + 1], &c__1); + r__1 = snrm2_(n, &vr[ks * vr_dim1 + 1], &c__1); + r__2 = snrm2_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1); + rnrm = slapy2_(&r__1, &r__2); + r__1 = snrm2_(n, &vl[ks * vl_dim1 + 1], &c__1); + r__2 = snrm2_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1); + lnrm = slapy2_(&r__1, &r__2); + cond = slapy2_(&prod1, &prod2) / (rnrm * lnrm); + s[ks] = cond; + s[ks + 1] = cond; + } + } + + if (wantsp) { + +/* Estimate the reciprocal condition number of the k-th */ +/* eigenvector. */ + +/* Copy the matrix T to the array WORK and swap the diagonal */ +/* block beginning at T(k,k) to the (1,1) position. */ + + slacpy_("Full", n, n, &t[t_offset], ldt, &work[work_offset], + ldwork); + ifst = k; + ilst = 1; + strexc_("No Q", n, &work[work_offset], ldwork, dummy, &c__1, & + ifst, &ilst, &work[(*n + 1) * work_dim1 + 1], &ierr); + + if (ierr == 1 || ierr == 2) { + +/* Could not swap because blocks not well separated */ + + scale = 1.f; + est = bignum; + } else { + +/* Reordering successful */ + + if (work[work_dim1 + 2] == 0.f) { + +/* Form C = T22 - lambda*I in WORK(2:N,2:N). */ + + i__2 = *n; + for (i__ = 2; i__ <= i__2; ++i__) { + work[i__ + i__ * work_dim1] -= work[work_dim1 + 1]; +/* L20: */ + } + n2 = 1; + nn = *n - 1; + } else { + +/* Triangularize the 2 by 2 block by unitary */ +/* transformation U = [ cs i*ss ] */ +/* [ i*ss cs ]. */ +/* such that the (1,1) position of WORK is complex */ +/* eigenvalue lambda with positive imaginary part. (2,2) */ +/* position of WORK is the complex eigenvalue lambda */ +/* with negative imaginary part. */ + + mu = sqrt((r__1 = work[(work_dim1 << 1) + 1], abs(r__1))) + * sqrt((r__2 = work[work_dim1 + 2], abs(r__2))); + delta = slapy2_(&mu, &work[work_dim1 + 2]); + cs = mu / delta; + sn = -work[work_dim1 + 2] / delta; + +/* Form */ + +/* C**T = WORK(2:N,2:N) + i*[rwork(1) ..... rwork(n-1) ] */ +/* [ mu ] */ +/* [ .. ] */ +/* [ .. ] */ +/* [ mu ] */ +/* where C**T is transpose of matrix C, */ +/* and RWORK is stored starting in the N+1-st column of */ +/* WORK. */ + + i__2 = *n; + for (j = 3; j <= i__2; ++j) { + work[j * work_dim1 + 2] = cs * work[j * work_dim1 + 2] + ; + work[j + j * work_dim1] -= work[work_dim1 + 1]; +/* L30: */ + } + work[(work_dim1 << 1) + 2] = 0.f; + + work[(*n + 1) * work_dim1 + 1] = mu * 2.f; + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + work[i__ + (*n + 1) * work_dim1] = sn * work[(i__ + 1) + * work_dim1 + 1]; +/* L40: */ + } + n2 = 2; + nn = *n - 1 << 1; + } + +/* Estimate norm(inv(C**T)) */ + + est = 0.f; + kase = 0; +L50: + slacn2_(&nn, &work[(*n + 2) * work_dim1 + 1], &work[(*n + 4) * + work_dim1 + 1], &iwork[1], &est, &kase, isave); + if (kase != 0) { + if (kase == 1) { + if (n2 == 1) { + +/* Real eigenvalue: solve C**T*x = scale*c. */ + + i__2 = *n - 1; + slaqtr_(&c_true, &c_true, &i__2, &work[(work_dim1 + << 1) + 2], ldwork, dummy, &dumm, &scale, + &work[(*n + 4) * work_dim1 + 1], &work[(* + n + 6) * work_dim1 + 1], &ierr); + } else { + +/* Complex eigenvalue: solve */ +/* C**T*(p+iq) = scale*(c+id) in real arithmetic. */ + + i__2 = *n - 1; + slaqtr_(&c_true, &c_false, &i__2, &work[( + work_dim1 << 1) + 2], ldwork, &work[(*n + + 1) * work_dim1 + 1], &mu, &scale, &work[(* + n + 4) * work_dim1 + 1], &work[(*n + 6) * + work_dim1 + 1], &ierr); + } + } else { + if (n2 == 1) { + +/* Real eigenvalue: solve C*x = scale*c. */ + + i__2 = *n - 1; + slaqtr_(&c_false, &c_true, &i__2, &work[( + work_dim1 << 1) + 2], ldwork, dummy, & + dumm, &scale, &work[(*n + 4) * work_dim1 + + 1], &work[(*n + 6) * work_dim1 + 1], & + ierr); + } else { + +/* Complex eigenvalue: solve */ +/* C*(p+iq) = scale*(c+id) in real arithmetic. */ + + i__2 = *n - 1; + slaqtr_(&c_false, &c_false, &i__2, &work[( + work_dim1 << 1) + 2], ldwork, &work[(*n + + 1) * work_dim1 + 1], &mu, &scale, &work[(* + n + 4) * work_dim1 + 1], &work[(*n + 6) * + work_dim1 + 1], &ierr); + + } + } + + goto L50; + } + } + + sep[ks] = scale / f2cmax(est,smlnum); + if (pair) { + sep[ks + 1] = sep[ks]; + } + } + + if (pair) { + ++ks; + } + +L60: + ; + } + return 0; + +/* End of STRSNA */ + +} /* strsna_ */ + diff --git a/lapack-netlib/SRC/strsyl.c b/lapack-netlib/SRC/strsyl.c new file mode 100644 index 000000000..97f647ece --- /dev/null +++ b/lapack-netlib/SRC/strsyl.c @@ -0,0 +1,1760 @@ +/* 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 STRSYL */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STRSYL + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, */ +/* LDC, SCALE, INFO ) */ + +/* CHARACTER TRANA, TRANB */ +/* INTEGER INFO, ISGN, LDA, LDB, LDC, M, N */ +/* REAL SCALE */ +/* REAL A( LDA, * ), B( LDB, * ), C( LDC, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STRSYL solves the real Sylvester matrix equation: */ +/* > */ +/* > op(A)*X + X*op(B) = scale*C or */ +/* > op(A)*X - X*op(B) = scale*C, */ +/* > */ +/* > where op(A) = A or A**T, and A and B are both upper quasi- */ +/* > triangular. A is M-by-M and B is N-by-N; the right hand side C and */ +/* > the solution X are M-by-N; and scale is an output scale factor, set */ +/* > <= 1 to avoid overflow in X. */ +/* > */ +/* > A and B must be in Schur canonical form (as returned by SHSEQR), that */ +/* > is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; */ +/* > each 2-by-2 diagonal block has its diagonal elements equal and its */ +/* > off-diagonal elements of opposite sign. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANA */ +/* > \verbatim */ +/* > TRANA is CHARACTER*1 */ +/* > Specifies the option op(A): */ +/* > = 'N': op(A) = A (No transpose) */ +/* > = 'T': op(A) = A**T (Transpose) */ +/* > = 'C': op(A) = A**H (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANB */ +/* > \verbatim */ +/* > TRANB is CHARACTER*1 */ +/* > Specifies the option op(B): */ +/* > = 'N': op(B) = B (No transpose) */ +/* > = 'T': op(B) = B**T (Transpose) */ +/* > = 'C': op(B) = B**H (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ISGN */ +/* > \verbatim */ +/* > ISGN is INTEGER */ +/* > Specifies the sign in the equation: */ +/* > = +1: solve op(A)*X + X*op(B) = scale*C */ +/* > = -1: solve op(A)*X - X*op(B) = scale*C */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The order of the matrix A, and the number of rows in the */ +/* > matrices X and C. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix B, and the number of columns in the */ +/* > matrices X and C. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,M) */ +/* > The upper quasi-triangular matrix A, in Schur canonical form. */ +/* > \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 REAL array, dimension (LDB,N) */ +/* > The upper quasi-triangular matrix B, in Schur canonical form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (LDC,N) */ +/* > On entry, the M-by-N right hand side matrix C. */ +/* > On exit, C is overwritten by the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE */ +/* > \verbatim */ +/* > SCALE is REAL */ +/* > The scale factor, scale, set <= 1 to avoid overflow in X. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > = 1: A and B have common or very close eigenvalues; perturbed */ +/* > values were used to solve the equation (but the matrices */ +/* > A and B are unchanged). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int strsyl_(char *trana, char *tranb, integer *isgn, integer + *m, integer *n, real *a, integer *lda, real *b, integer *ldb, real * + c__, integer *ldc, real *scale, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4; + real r__1, r__2; + + /* Local variables */ + integer ierr; + real smin; + extern real sdot_(integer *, real *, integer *, real *, integer *); + real suml, sumr; + integer j, k, l; + real x[4] /* was [2][2] */; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + integer knext, lnext, k1, k2, l1, l2; + real xnorm; + extern /* Subroutine */ int slaln2_(logical *, integer *, integer *, real + *, real *, real *, integer *, real *, real *, real *, integer *, + real *, real *, real *, integer *, real *, real *, integer *); + real a11, db; + extern /* Subroutine */ int slasy2_(logical *, logical *, integer *, + integer *, integer *, real *, integer *, real *, integer *, real * + , integer *, real *, real *, integer *, real *, integer *), + slabad_(real *, real *); + real scaloc; + extern real slamch_(char *), slange_(char *, integer *, integer *, + real *, integer *, real *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real bignum; + logical notrna, notrnb; + real smlnum, da11, vec[4] /* was [2][2] */, dum[1], eps, sgn; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and Test input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + + /* Function Body */ + notrna = lsame_(trana, "N"); + notrnb = lsame_(tranb, "N"); + + *info = 0; + if (! notrna && ! lsame_(trana, "T") && ! lsame_( + trana, "C")) { + *info = -1; + } else if (! notrnb && ! lsame_(tranb, "T") && ! + lsame_(tranb, "C")) { + *info = -2; + } else if (*isgn != 1 && *isgn != -1) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < f2cmax(1,*m)) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } else if (*ldc < f2cmax(1,*m)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STRSYL", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + *scale = 1.f; + if (*m == 0 || *n == 0) { + return 0; + } + +/* Set constants to control overflow */ + + eps = slamch_("P"); + smlnum = slamch_("S"); + bignum = 1.f / smlnum; + slabad_(&smlnum, &bignum); + smlnum = smlnum * (real) (*m * *n) / eps; + bignum = 1.f / smlnum; + +/* Computing MAX */ + r__1 = smlnum, r__2 = eps * slange_("M", m, m, &a[a_offset], lda, dum), r__1 = f2cmax(r__1,r__2), r__2 = eps * slange_("M", n, n, + &b[b_offset], ldb, dum); + smin = f2cmax(r__1,r__2); + + sgn = (real) (*isgn); + + if (notrna && notrnb) { + +/* Solve A*X + ISGN*X*B = scale*C. */ + +/* The (K,L)th block of X is determined starting from */ +/* bottom-left corner column by column by */ + +/* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */ + +/* Where */ +/* M L-1 */ +/* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]. */ +/* I=K+1 J=1 */ + +/* Start column loop (index = L) */ +/* L1 (L2) : column index of the first (first) row of X(K,L). */ + + lnext = 1; + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + if (l < lnext) { + goto L70; + } + if (l == *n) { + l1 = l; + l2 = l; + } else { + if (b[l + 1 + l * b_dim1] != 0.f) { + l1 = l; + l2 = l + 1; + lnext = l + 2; + } else { + l1 = l; + l2 = l; + lnext = l + 1; + } + } + +/* Start row loop (index = K) */ +/* K1 (K2): row index of the first (last) row of X(K,L). */ + + knext = *m; + for (k = *m; k >= 1; --k) { + if (k > knext) { + goto L60; + } + if (k == 1) { + k1 = k; + k2 = k; + } else { + if (a[k + (k - 1) * a_dim1] != 0.f) { + k1 = k - 1; + k2 = k; + knext = k - 2; + } else { + k1 = k; + k2 = k; + knext = k - 1; + } + } + + if (l1 == l2 && k1 == k2) { + i__2 = *m - k1; +/* Computing MIN */ + i__3 = k1 + 1; +/* Computing MIN */ + i__4 = k1 + 1; + suml = sdot_(&i__2, &a[k1 + f2cmin(i__3,*m) * a_dim1], lda, & + c__[f2cmin(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = sdot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + scaloc = 1.f; + + a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; + da11 = abs(a11); + if (da11 <= smin) { + a11 = smin; + da11 = smin; + *info = 1; + } + db = abs(vec[0]); + if (da11 < 1.f && db > 1.f) { + if (db > bignum * da11) { + scaloc = 1.f / db; + } + } + x[0] = vec[0] * scaloc / a11; + + if (scaloc != 1.f) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L10: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + + } else if (l1 == l2 && k1 != k2) { + + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = sdot_(&i__2, &a[k1 + f2cmin(i__3,*m) * a_dim1], lda, & + c__[f2cmin(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = sdot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = sdot_(&i__2, &a[k2 + f2cmin(i__3,*m) * a_dim1], lda, & + c__[f2cmin(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = sdot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + r__1 = -sgn * b[l1 + l1 * b_dim1]; + slaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 + * a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &r__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.f) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L20: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k2 + l1 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 == k2) { + + i__2 = *m - k1; +/* Computing MIN */ + i__3 = k1 + 1; +/* Computing MIN */ + i__4 = k1 + 1; + suml = sdot_(&i__2, &a[k1 + f2cmin(i__3,*m) * a_dim1], lda, & + c__[f2cmin(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = sdot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * + sumr)); + + i__2 = *m - k1; +/* Computing MIN */ + i__3 = k1 + 1; +/* Computing MIN */ + i__4 = k1 + 1; + suml = sdot_(&i__2, &a[k1 + f2cmin(i__3,*m) * a_dim1], lda, & + c__[f2cmin(i__4,*m) + l2 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = sdot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * + sumr)); + + r__1 = -sgn * a[k1 + k1 * a_dim1]; + slaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 * + b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &r__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.f) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L40: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 != k2) { + + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = sdot_(&i__2, &a[k1 + f2cmin(i__3,*m) * a_dim1], lda, & + c__[f2cmin(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = sdot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = sdot_(&i__2, &a[k1 + f2cmin(i__3,*m) * a_dim1], lda, & + c__[f2cmin(i__4,*m) + l2 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = sdot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); + + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = sdot_(&i__2, &a[k2 + f2cmin(i__3,*m) * a_dim1], lda, & + c__[f2cmin(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = sdot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = sdot_(&i__2, &a[k2 + f2cmin(i__3,*m) * a_dim1], lda, & + c__[f2cmin(i__4,*m) + l2 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = sdot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); + + slasy2_(&c_false, &c_false, isgn, &c__2, &c__2, &a[k1 + + k1 * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, + &c__2, &scaloc, x, &c__2, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.f) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L50: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[2]; + c__[k2 + l1 * c_dim1] = x[1]; + c__[k2 + l2 * c_dim1] = x[3]; + } + +L60: + ; + } + +L70: + ; + } + + } else if (! notrna && notrnb) { + +/* Solve A**T *X + ISGN*X*B = scale*C. */ + +/* The (K,L)th block of X is determined starting from */ +/* upper-left corner column by column by */ + +/* A(K,K)**T*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */ + +/* Where */ +/* K-1 L-1 */ +/* R(K,L) = SUM [A(I,K)**T*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)] */ +/* I=1 J=1 */ + +/* Start column loop (index = L) */ +/* L1 (L2): column index of the first (last) row of X(K,L) */ + + lnext = 1; + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + if (l < lnext) { + goto L130; + } + if (l == *n) { + l1 = l; + l2 = l; + } else { + if (b[l + 1 + l * b_dim1] != 0.f) { + l1 = l; + l2 = l + 1; + lnext = l + 2; + } else { + l1 = l; + l2 = l; + lnext = l + 1; + } + } + +/* Start row loop (index = K) */ +/* K1 (K2): row index of the first (last) row of X(K,L) */ + + knext = 1; + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + if (k < knext) { + goto L120; + } + if (k == *m) { + k1 = k; + k2 = k; + } else { + if (a[k + 1 + k * a_dim1] != 0.f) { + k1 = k; + k2 = k + 1; + knext = k + 2; + } else { + k1 = k; + k2 = k; + knext = k + 1; + } + } + + if (l1 == l2 && k1 == k2) { + i__3 = k1 - 1; + suml = sdot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = sdot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + scaloc = 1.f; + + a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; + da11 = abs(a11); + if (da11 <= smin) { + a11 = smin; + da11 = smin; + *info = 1; + } + db = abs(vec[0]); + if (da11 < 1.f && db > 1.f) { + if (db > bignum * da11) { + scaloc = 1.f / db; + } + } + x[0] = vec[0] * scaloc / a11; + + if (scaloc != 1.f) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L80: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + + } else if (l1 == l2 && k1 != k2) { + + i__3 = k1 - 1; + suml = sdot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = sdot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__3 = k1 - 1; + suml = sdot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = sdot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + r__1 = -sgn * b[l1 + l1 * b_dim1]; + slaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 * + a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &r__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.f) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L90: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k2 + l1 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 == k2) { + + i__3 = k1 - 1; + suml = sdot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = sdot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * + sumr)); + + i__3 = k1 - 1; + suml = sdot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = sdot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * + sumr)); + + r__1 = -sgn * a[k1 + k1 * a_dim1]; + slaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 * + b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &r__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.f) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L100: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 != k2) { + + i__3 = k1 - 1; + suml = sdot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = sdot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__3 = k1 - 1; + suml = sdot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = sdot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); + + i__3 = k1 - 1; + suml = sdot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = sdot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + i__3 = k1 - 1; + suml = sdot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = sdot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); + + slasy2_(&c_true, &c_false, isgn, &c__2, &c__2, &a[k1 + k1 + * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, & + c__2, &scaloc, x, &c__2, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.f) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L110: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[2]; + c__[k2 + l1 * c_dim1] = x[1]; + c__[k2 + l2 * c_dim1] = x[3]; + } + +L120: + ; + } +L130: + ; + } + + } else if (! notrna && ! notrnb) { + +/* Solve A**T*X + ISGN*X*B**T = scale*C. */ + +/* The (K,L)th block of X is determined starting from */ +/* top-right corner column by column by */ + +/* A(K,K)**T*X(K,L) + ISGN*X(K,L)*B(L,L)**T = C(K,L) - R(K,L) */ + +/* Where */ +/* K-1 N */ +/* R(K,L) = SUM [A(I,K)**T*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)**T]. */ +/* I=1 J=L+1 */ + +/* Start column loop (index = L) */ +/* L1 (L2): column index of the first (last) row of X(K,L) */ + + lnext = *n; + for (l = *n; l >= 1; --l) { + if (l > lnext) { + goto L190; + } + if (l == 1) { + l1 = l; + l2 = l; + } else { + if (b[l + (l - 1) * b_dim1] != 0.f) { + l1 = l - 1; + l2 = l; + lnext = l - 2; + } else { + l1 = l; + l2 = l; + lnext = l - 1; + } + } + +/* Start row loop (index = K) */ +/* K1 (K2): row index of the first (last) row of X(K,L) */ + + knext = 1; + i__1 = *m; + for (k = 1; k <= i__1; ++k) { + if (k < knext) { + goto L180; + } + if (k == *m) { + k1 = k; + k2 = k; + } else { + if (a[k + 1 + k * a_dim1] != 0.f) { + k1 = k; + k2 = k + 1; + knext = k + 2; + } else { + k1 = k; + k2 = k; + knext = k + 1; + } + } + + if (l1 == l2 && k1 == k2) { + i__2 = k1 - 1; + suml = sdot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l1; +/* Computing MIN */ + i__3 = l1 + 1; +/* Computing MIN */ + i__4 = l1 + 1; + sumr = sdot_(&i__2, &c__[k1 + f2cmin(i__3,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__4,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + scaloc = 1.f; + + a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; + da11 = abs(a11); + if (da11 <= smin) { + a11 = smin; + da11 = smin; + *info = 1; + } + db = abs(vec[0]); + if (da11 < 1.f && db > 1.f) { + if (db > bignum * da11) { + scaloc = 1.f / db; + } + } + x[0] = vec[0] * scaloc / a11; + + if (scaloc != 1.f) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L140: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + + } else if (l1 == l2 && k1 != k2) { + + i__2 = k1 - 1; + suml = sdot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = sdot_(&i__2, &c__[k1 + f2cmin(i__3,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__4,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__2 = k1 - 1; + suml = sdot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = sdot_(&i__2, &c__[k2 + f2cmin(i__3,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__4,*n) * b_dim1], ldb); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + r__1 = -sgn * b[l1 + l1 * b_dim1]; + slaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 * + a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &r__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.f) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L150: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k2 + l1 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 == k2) { + + i__2 = k1 - 1; + suml = sdot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = sdot_(&i__2, &c__[k1 + f2cmin(i__3,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__4,*n) * b_dim1], ldb); + vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * + sumr)); + + i__2 = k1 - 1; + suml = sdot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = sdot_(&i__2, &c__[k1 + f2cmin(i__3,*n) * c_dim1], ldc, + &b[l2 + f2cmin(i__4,*n) * b_dim1], ldb); + vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * + sumr)); + + r__1 = -sgn * a[k1 + k1 * a_dim1]; + slaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 + * b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &r__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.f) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L160: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 != k2) { + + i__2 = k1 - 1; + suml = sdot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = sdot_(&i__2, &c__[k1 + f2cmin(i__3,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__4,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__2 = k1 - 1; + suml = sdot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = sdot_(&i__2, &c__[k1 + f2cmin(i__3,*n) * c_dim1], ldc, + &b[l2 + f2cmin(i__4,*n) * b_dim1], ldb); + vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); + + i__2 = k1 - 1; + suml = sdot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = sdot_(&i__2, &c__[k2 + f2cmin(i__3,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__4,*n) * b_dim1], ldb); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + i__2 = k1 - 1; + suml = sdot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = sdot_(&i__2, &c__[k2 + f2cmin(i__3,*n) * c_dim1], ldc, + &b[l2 + f2cmin(i__4,*n) * b_dim1], ldb); + vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); + + slasy2_(&c_true, &c_true, isgn, &c__2, &c__2, &a[k1 + k1 * + a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, & + c__2, &scaloc, x, &c__2, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.f) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L170: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[2]; + c__[k2 + l1 * c_dim1] = x[1]; + c__[k2 + l2 * c_dim1] = x[3]; + } + +L180: + ; + } +L190: + ; + } + + } else if (notrna && ! notrnb) { + +/* Solve A*X + ISGN*X*B**T = scale*C. */ + +/* The (K,L)th block of X is determined starting from */ +/* bottom-right corner column by column by */ + +/* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L)**T = C(K,L) - R(K,L) */ + +/* Where */ +/* M N */ +/* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)**T]. */ +/* I=K+1 J=L+1 */ + +/* Start column loop (index = L) */ +/* L1 (L2): column index of the first (last) row of X(K,L) */ + + lnext = *n; + for (l = *n; l >= 1; --l) { + if (l > lnext) { + goto L250; + } + if (l == 1) { + l1 = l; + l2 = l; + } else { + if (b[l + (l - 1) * b_dim1] != 0.f) { + l1 = l - 1; + l2 = l; + lnext = l - 2; + } else { + l1 = l; + l2 = l; + lnext = l - 1; + } + } + +/* Start row loop (index = K) */ +/* K1 (K2): row index of the first (last) row of X(K,L) */ + + knext = *m; + for (k = *m; k >= 1; --k) { + if (k > knext) { + goto L240; + } + if (k == 1) { + k1 = k; + k2 = k; + } else { + if (a[k + (k - 1) * a_dim1] != 0.f) { + k1 = k - 1; + k2 = k; + knext = k - 2; + } else { + k1 = k; + k2 = k; + knext = k - 1; + } + } + + if (l1 == l2 && k1 == k2) { + i__1 = *m - k1; +/* Computing MIN */ + i__2 = k1 + 1; +/* Computing MIN */ + i__3 = k1 + 1; + suml = sdot_(&i__1, &a[k1 + f2cmin(i__2,*m) * a_dim1], lda, & + c__[f2cmin(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l1; +/* Computing MIN */ + i__2 = l1 + 1; +/* Computing MIN */ + i__3 = l1 + 1; + sumr = sdot_(&i__1, &c__[k1 + f2cmin(i__2,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__3,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + scaloc = 1.f; + + a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; + da11 = abs(a11); + if (da11 <= smin) { + a11 = smin; + da11 = smin; + *info = 1; + } + db = abs(vec[0]); + if (da11 < 1.f && db > 1.f) { + if (db > bignum * da11) { + scaloc = 1.f / db; + } + } + x[0] = vec[0] * scaloc / a11; + + if (scaloc != 1.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L200: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + + } else if (l1 == l2 && k1 != k2) { + + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = sdot_(&i__1, &a[k1 + f2cmin(i__2,*m) * a_dim1], lda, & + c__[f2cmin(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = sdot_(&i__1, &c__[k1 + f2cmin(i__2,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__3,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = sdot_(&i__1, &a[k2 + f2cmin(i__2,*m) * a_dim1], lda, & + c__[f2cmin(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = sdot_(&i__1, &c__[k2 + f2cmin(i__2,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__3,*n) * b_dim1], ldb); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + r__1 = -sgn * b[l1 + l1 * b_dim1]; + slaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 + * a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &r__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L210: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k2 + l1 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 == k2) { + + i__1 = *m - k1; +/* Computing MIN */ + i__2 = k1 + 1; +/* Computing MIN */ + i__3 = k1 + 1; + suml = sdot_(&i__1, &a[k1 + f2cmin(i__2,*m) * a_dim1], lda, & + c__[f2cmin(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = sdot_(&i__1, &c__[k1 + f2cmin(i__2,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__3,*n) * b_dim1], ldb); + vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * + sumr)); + + i__1 = *m - k1; +/* Computing MIN */ + i__2 = k1 + 1; +/* Computing MIN */ + i__3 = k1 + 1; + suml = sdot_(&i__1, &a[k1 + f2cmin(i__2,*m) * a_dim1], lda, & + c__[f2cmin(i__3,*m) + l2 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = sdot_(&i__1, &c__[k1 + f2cmin(i__2,*n) * c_dim1], ldc, + &b[l2 + f2cmin(i__3,*n) * b_dim1], ldb); + vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * + sumr)); + + r__1 = -sgn * a[k1 + k1 * a_dim1]; + slaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 + * b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &r__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L220: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 != k2) { + + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = sdot_(&i__1, &a[k1 + f2cmin(i__2,*m) * a_dim1], lda, & + c__[f2cmin(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = sdot_(&i__1, &c__[k1 + f2cmin(i__2,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__3,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = sdot_(&i__1, &a[k1 + f2cmin(i__2,*m) * a_dim1], lda, & + c__[f2cmin(i__3,*m) + l2 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = sdot_(&i__1, &c__[k1 + f2cmin(i__2,*n) * c_dim1], ldc, + &b[l2 + f2cmin(i__3,*n) * b_dim1], ldb); + vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); + + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = sdot_(&i__1, &a[k2 + f2cmin(i__2,*m) * a_dim1], lda, & + c__[f2cmin(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = sdot_(&i__1, &c__[k2 + f2cmin(i__2,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__3,*n) * b_dim1], ldb); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = sdot_(&i__1, &a[k2 + f2cmin(i__2,*m) * a_dim1], lda, & + c__[f2cmin(i__3,*m) + l2 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = sdot_(&i__1, &c__[k2 + f2cmin(i__2,*n) * c_dim1], ldc, + &b[l2 + f2cmin(i__3,*n) * b_dim1], ldb); + vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); + + slasy2_(&c_false, &c_true, isgn, &c__2, &c__2, &a[k1 + k1 + * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, & + c__2, &scaloc, x, &c__2, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.f) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L230: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[2]; + c__[k2 + l1 * c_dim1] = x[1]; + c__[k2 + l2 * c_dim1] = x[3]; + } + +L240: + ; + } +L250: + ; + } + + } + + return 0; + +/* End of STRSYL */ + +} /* strsyl_ */ + diff --git a/lapack-netlib/SRC/strti2.c b/lapack-netlib/SRC/strti2.c new file mode 100644 index 000000000..cbc00389f --- /dev/null +++ b/lapack-netlib/SRC/strti2.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 STRTI2 computes the inverse of a triangular matrix (unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STRTI2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STRTI2( UPLO, DIAG, N, A, LDA, INFO ) */ + +/* CHARACTER DIAG, UPLO */ +/* INTEGER INFO, LDA, N */ +/* REAL A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STRTI2 computes the inverse of a real upper or lower triangular */ +/* > matrix. */ +/* > */ +/* > This is the Level 2 BLAS version of the algorithm. */ +/* > \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] 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. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the triangular matrix A. If UPLO = 'U', the */ +/* > leading n by n upper triangular part of the array A contains */ +/* > the upper triangular matrix, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading n by n lower triangular part of the array A contains */ +/* > the lower triangular matrix, and the strictly upper */ +/* > triangular part of A is not referenced. If DIAG = 'U', the */ +/* > diagonal elements of A are also not referenced and are */ +/* > assumed to be 1. */ +/* > */ +/* > On exit, the (triangular) inverse of the original matrix, in */ +/* > the same storage format. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= 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 */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int strti2_(char *uplo, char *diag, integer *n, real *a, + integer *lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + logical upper; + extern /* Subroutine */ int strmv_(char *, char *, char *, integer *, + real *, integer *, real *, integer *), + xerbla_(char *, integer *, ftnlen); + logical nounit; + real ajj; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + nounit = lsame_(diag, "N"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STRTI2", &i__1, (ftnlen)6); + return 0; + } + + if (upper) { + +/* Compute inverse of upper triangular matrix. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (nounit) { + a[j + j * a_dim1] = 1.f / a[j + j * a_dim1]; + ajj = -a[j + j * a_dim1]; + } else { + ajj = -1.f; + } + +/* Compute elements 1:j-1 of j-th column. */ + + i__2 = j - 1; + strmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, & + a[j * a_dim1 + 1], &c__1); + i__2 = j - 1; + sscal_(&i__2, &ajj, &a[j * a_dim1 + 1], &c__1); +/* L10: */ + } + } else { + +/* Compute inverse of lower triangular matrix. */ + + for (j = *n; j >= 1; --j) { + if (nounit) { + a[j + j * a_dim1] = 1.f / a[j + j * a_dim1]; + ajj = -a[j + j * a_dim1]; + } else { + ajj = -1.f; + } + if (j < *n) { + +/* Compute elements j+1:n of j-th column. */ + + i__1 = *n - j; + strmv_("Lower", "No transpose", diag, &i__1, &a[j + 1 + (j + + 1) * a_dim1], lda, &a[j + 1 + j * a_dim1], &c__1); + i__1 = *n - j; + sscal_(&i__1, &ajj, &a[j + 1 + j * a_dim1], &c__1); + } +/* L20: */ + } + } + + return 0; + +/* End of STRTI2 */ + +} /* strti2_ */ + diff --git a/lapack-netlib/SRC/strtri.c b/lapack-netlib/SRC/strtri.c new file mode 100644 index 000000000..404c6914c --- /dev/null +++ b/lapack-netlib/SRC/strtri.c @@ -0,0 +1,666 @@ +/* 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 STRTRI */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STRTRI + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STRTRI( UPLO, DIAG, N, A, LDA, INFO ) */ + +/* CHARACTER DIAG, UPLO */ +/* INTEGER INFO, LDA, N */ +/* REAL A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STRTRI computes the inverse of a real upper or lower triangular */ +/* > matrix A. */ +/* > */ +/* > This is the Level 3 BLAS version of the algorithm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the triangular matrix A. If UPLO = 'U', the */ +/* > leading N-by-N upper triangular part of the array A contains */ +/* > the upper triangular matrix, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of the array A contains */ +/* > the lower triangular matrix, and the strictly upper */ +/* > triangular part of A is not referenced. If DIAG = 'U', the */ +/* > diagonal elements of A are also not referenced and are */ +/* > assumed to be 1. */ +/* > On exit, the (triangular) inverse of the original matrix, in */ +/* > the same storage format. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, A(i,i) is exactly zero. The triangular */ +/* > matrix is singular and its inverse can not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int strtri_(char *uplo, char *diag, integer *n, real *a, + integer *lda, integer *info) +{ + /* System generated locals */ + address a__1[2]; + integer a_dim1, a_offset, i__1, i__2[2], i__3, i__4, i__5; + char ch__1[2]; + + /* Local variables */ + integer j; + extern logical lsame_(char *, char *); + logical upper; + extern /* Subroutine */ int strmm_(char *, char *, char *, char *, + integer *, integer *, real *, real *, integer *, real *, integer * + ), strsm_(char *, char *, char *, + char *, integer *, integer *, real *, real *, integer *, real *, + integer *); + integer jb, nb; + extern /* Subroutine */ int strti2_(char *, char *, integer *, real *, + integer *, integer *); + integer nn; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + logical nounit; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + nounit = lsame_(diag, "N"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STRTRI", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check for singularity if non-unit. */ + + if (nounit) { + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (a[*info + *info * a_dim1] == 0.f) { + return 0; + } +/* L10: */ + } + *info = 0; + } + +/* Determine the block size for this environment. */ + +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = uplo; + i__2[1] = 1, a__1[1] = diag; + s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2); + nb = ilaenv_(&c__1, "STRTRI", ch__1, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)2); + if (nb <= 1 || nb >= *n) { + +/* Use unblocked code */ + + strti2_(uplo, diag, n, &a[a_offset], lda, info); + } else { + +/* Use blocked code */ + + if (upper) { + +/* Compute inverse of upper triangular matrix */ + + i__1 = *n; + i__3 = nb; + for (j = 1; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) { +/* Computing MIN */ + i__4 = nb, i__5 = *n - j + 1; + jb = f2cmin(i__4,i__5); + +/* Compute rows 1:j-1 of current block column */ + + i__4 = j - 1; + strmm_("Left", "Upper", "No transpose", diag, &i__4, &jb, & + c_b18, &a[a_offset], lda, &a[j * a_dim1 + 1], lda); + i__4 = j - 1; + strsm_("Right", "Upper", "No transpose", diag, &i__4, &jb, & + c_b22, &a[j + j * a_dim1], lda, &a[j * a_dim1 + 1], + lda); + +/* Compute inverse of current diagonal block */ + + strti2_("Upper", diag, &jb, &a[j + j * a_dim1], lda, info); +/* L20: */ + } + } else { + +/* Compute inverse of lower triangular matrix */ + + nn = (*n - 1) / nb * nb + 1; + i__3 = -nb; + for (j = nn; i__3 < 0 ? j >= 1 : j <= 1; j += i__3) { +/* Computing MIN */ + i__1 = nb, i__4 = *n - j + 1; + jb = f2cmin(i__1,i__4); + if (j + jb <= *n) { + +/* Compute rows j+jb:n of current block column */ + + i__1 = *n - j - jb + 1; + strmm_("Left", "Lower", "No transpose", diag, &i__1, &jb, + &c_b18, &a[j + jb + (j + jb) * a_dim1], lda, &a[j + + jb + j * a_dim1], lda); + i__1 = *n - j - jb + 1; + strsm_("Right", "Lower", "No transpose", diag, &i__1, &jb, + &c_b22, &a[j + j * a_dim1], lda, &a[j + jb + j * + a_dim1], lda); + } + +/* Compute inverse of current diagonal block */ + + strti2_("Lower", diag, &jb, &a[j + j * a_dim1], lda, info); +/* L30: */ + } + } + } + + return 0; + +/* End of STRTRI */ + +} /* strtri_ */ + diff --git a/lapack-netlib/SRC/strtrs.c b/lapack-netlib/SRC/strtrs.c new file mode 100644 index 000000000..a1535d9f0 --- /dev/null +++ b/lapack-netlib/SRC/strtrs.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 STRTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STRTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, */ +/* INFO ) */ + +/* CHARACTER DIAG, TRANS, UPLO */ +/* INTEGER INFO, LDA, LDB, N, NRHS */ +/* REAL A( LDA, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STRTRS solves a triangular system of the form */ +/* > */ +/* > A * X = B or A**T * X = B, */ +/* > */ +/* > where A is a triangular matrix of order N, and B is an N-by-NRHS */ +/* > matrix. A check is made to verify that A is nonsingular. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > The triangular matrix A. If UPLO = 'U', the leading N-by-N */ +/* > upper triangular part of the array A contains the upper */ +/* > triangular matrix, and the strictly lower triangular part of */ +/* > A is not referenced. If UPLO = 'L', the leading N-by-N lower */ +/* > triangular part of the array A contains the lower triangular */ +/* > matrix, and the strictly upper triangular part of A is not */ +/* > referenced. If DIAG = 'U', the diagonal elements of A are */ +/* > also not referenced and are assumed to be 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, if INFO = 0, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the i-th diagonal element of A is zero, */ +/* > indicating that the matrix is singular and the solutions */ +/* > X have not been computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int strtrs_(char *uplo, char *trans, char *diag, integer *n, + integer *nrhs, real *a, integer *lda, real *b, integer *ldb, integer * + info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + extern logical lsame_(char *, char *); + extern /* Subroutine */ int strsm_(char *, char *, char *, char *, + integer *, integer *, real *, real *, integer *, real *, integer * + ), xerbla_(char *, integer *, ftnlen); + logical nounit; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + nounit = lsame_(diag, "N"); + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*lda < f2cmax(1,*n)) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STRTRS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check for singularity. */ + + if (nounit) { + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (a[*info + *info * a_dim1] == 0.f) { + return 0; + } +/* L10: */ + } + } + *info = 0; + +/* Solve A * x = b or A**T * x = b. */ + + strsm_("Left", uplo, trans, diag, n, nrhs, &c_b12, &a[a_offset], lda, &b[ + b_offset], ldb); + + return 0; + +/* End of STRTRS */ + +} /* strtrs_ */ + diff --git a/lapack-netlib/SRC/strttf.c b/lapack-netlib/SRC/strttf.c new file mode 100644 index 000000000..27897ef7c --- /dev/null +++ b/lapack-netlib/SRC/strttf.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 STRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full pa +cked format (TF). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STRTTF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO ) */ + +/* CHARACTER TRANSR, UPLO */ +/* INTEGER INFO, N, LDA */ +/* REAL A( 0: LDA-1, 0: * ), ARF( 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STRTTF copies a triangular matrix A from standard full format (TR) */ +/* > to rectangular full packed format (TF) . */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER*1 */ +/* > = 'N': ARF in Normal form is wanted; */ +/* > = 'T': ARF in Transpose form is wanted. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N). */ +/* > On entry, the triangular matrix A. If UPLO = 'U', the */ +/* > leading N-by-N upper triangular part of the array A contains */ +/* > the upper triangular matrix, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of the array A contains */ +/* > the lower triangular matrix, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the matrix A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ARF */ +/* > \verbatim */ +/* > ARF is REAL array, dimension (NT). */ +/* > NT=N*(N+1)/2. On exit, the triangular matrix A in RFP format. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > We first consider Rectangular Full Packed (RFP) 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 */ +/* > the 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 */ +/* > the transpose of the last three columns of AP lower. */ +/* > 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 = 'T'. RFP A in both UPLO cases is just the */ +/* > 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 then consider Rectangular Full Packed (RFP) 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 */ +/* > the 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 */ +/* > the transpose of the last two columns of AP lower. */ +/* > 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 = 'T'. RFP A in both UPLO cases is just the */ +/* > 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 */ + +/* ===================================================================== */ +/* Subroutine */ int strttf_(char *transr, char *uplo, integer *n, real *a, + integer *lda, real *arf, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer np1x2, i__, j, k, l; + logical normaltransr; + extern logical lsame_(char *, char *); + logical lower; + integer n1, n2, ij, nt; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical nisodd; + integer nx2; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda - 1 - 0 + 1; + a_offset = 0 + a_dim1 * 0; + a -= a_offset; + + /* Function Body */ + *info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + if (! normaltransr && ! lsame_(transr, "T")) { + *info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STRTTF", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 1) { + if (*n == 1) { + arf[0] = a[0]; + } + return 0; + } + +/* Size of array ARF(0:nt-1) */ + + nt = *n * (*n + 1) / 2; + +/* Set N1 and N2 depending on LOWER: for N even N1=N2=K */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + +/* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. */ +/* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is */ +/* N--by--(N+1)/2. */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = FALSE_; + if (! lower) { + np1x2 = *n + *n + 2; + } + } else { + nisodd = TRUE_; + if (! lower) { + nx2 = *n + *n; + } + } + + if (nisodd) { + +/* N is odd */ + + if (normaltransr) { + +/* N is odd and TRANSR = 'N' */ + + if (lower) { + +/* N is odd, TRANSR = 'N', and UPLO = 'L' */ + + ij = 0; + i__1 = n2; + for (j = 0; j <= i__1; ++j) { + i__2 = n2 + j; + for (i__ = n1; i__ <= i__2; ++i__) { + arf[ij] = a[n2 + j + i__ * a_dim1]; + ++ij; + } + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + } + + } else { + +/* N is odd, TRANSR = 'N', and UPLO = 'U' */ + + ij = nt - *n; + i__1 = n1; + for (j = *n - 1; j >= i__1; --j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + i__2 = n1 - 1; + for (l = j - n1; l <= i__2; ++l) { + arf[ij] = a[j - n1 + l * a_dim1]; + ++ij; + } + ij -= nx2; + } + + } + + } else { + +/* N is odd and TRANSR = 'T' */ + + if (lower) { + +/* N is odd, TRANSR = 'T', and UPLO = 'L' */ + + ij = 0; + i__1 = n2 - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[j + i__ * a_dim1]; + ++ij; + } + i__2 = *n - 1; + for (i__ = n1 + j; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + (n1 + j) * a_dim1]; + ++ij; + } + } + i__1 = *n - 1; + for (j = n2; j <= i__1; ++j) { + i__2 = n1 - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[j + i__ * a_dim1]; + ++ij; + } + } + + } else { + +/* N is odd, TRANSR = 'T', and UPLO = 'U' */ + + ij = 0; + i__1 = n1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = n1; i__ <= i__2; ++i__) { + arf[ij] = a[j + i__ * a_dim1]; + ++ij; + } + } + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + i__2 = *n - 1; + for (l = n2 + j; l <= i__2; ++l) { + arf[ij] = a[n2 + j + l * a_dim1]; + ++ij; + } + } + + } + + } + + } else { + +/* N is even */ + + if (normaltransr) { + +/* N is even and TRANSR = 'N' */ + + if (lower) { + +/* N is even, TRANSR = 'N', and UPLO = 'L' */ + + ij = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = k + j; + for (i__ = k; i__ <= i__2; ++i__) { + arf[ij] = a[k + j + i__ * a_dim1]; + ++ij; + } + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + } + + } else { + +/* N is even, TRANSR = 'N', and UPLO = 'U' */ + + ij = nt - *n - 1; + i__1 = k; + for (j = *n - 1; j >= i__1; --j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + i__2 = k - 1; + for (l = j - k; l <= i__2; ++l) { + arf[ij] = a[j - k + l * a_dim1]; + ++ij; + } + ij -= np1x2; + } + + } + + } else { + +/* N is even and TRANSR = 'T' */ + + if (lower) { + +/* N is even, TRANSR = 'T', and UPLO = 'L' */ + + ij = 0; + j = k; + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[j + i__ * a_dim1]; + ++ij; + } + i__2 = *n - 1; + for (i__ = k + 1 + j; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + (k + 1 + j) * a_dim1]; + ++ij; + } + } + i__1 = *n - 1; + for (j = k - 1; j <= i__1; ++j) { + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[j + i__ * a_dim1]; + ++ij; + } + } + + } else { + +/* N is even, TRANSR = 'T', and UPLO = 'U' */ + + ij = 0; + i__1 = k; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = k; i__ <= i__2; ++i__) { + arf[ij] = a[j + i__ * a_dim1]; + ++ij; + } + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + i__2 = *n - 1; + for (l = k + 1 + j; l <= i__2; ++l) { + arf[ij] = a[k + 1 + j + l * a_dim1]; + ++ij; + } + } +/* Note that here, on exit of the loop, J = K-1 */ + i__1 = j; + for (i__ = 0; i__ <= i__1; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + + } + + } + + } + + return 0; + +/* End of STRTTF */ + +} /* strttf_ */ + diff --git a/lapack-netlib/SRC/strttp.c b/lapack-netlib/SRC/strttp.c new file mode 100644 index 000000000..79aa67e45 --- /dev/null +++ b/lapack-netlib/SRC/strttp.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 STRTTP copies a triangular matrix from the standard full format (TR) to the standard packed for +mat (TP). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STRTTP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STRTTP( UPLO, N, A, LDA, AP, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N, LDA */ +/* REAL A( LDA, * ), AP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STRTTP copies a triangular matrix A from full format (TR) to standard */ +/* > packed format (TP). */ +/* > \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 order of the matrices AP and A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On exit, the triangular matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] AP */ +/* > \verbatim */ +/* > AP is REAL array, dimension (N*(N+1)/2) */ +/* > On exit, 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. */ +/* > \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 realOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int strttp_(char *uplo, integer *n, real *a, integer *lda, + real *ap, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, k; + extern logical lsame_(char *, char *); + logical lower; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ap; + + /* Function Body */ + *info = 0; + lower = lsame_(uplo, "L"); + if (! lower && ! lsame_(uplo, "U")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("STRTTP", &i__1, (ftnlen)6); + return 0; + } + + if (lower) { + k = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + ++k; + ap[k] = a[i__ + j * a_dim1]; + } + } + } else { + k = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ++k; + ap[k] = a[i__ + j * a_dim1]; + } + } + } + + return 0; + +/* End of STRTTP */ + +} /* strttp_ */ + diff --git a/lapack-netlib/SRC/stzrzf.c b/lapack-netlib/SRC/stzrzf.c new file mode 100644 index 000000000..9f97012e6 --- /dev/null +++ b/lapack-netlib/SRC/stzrzf.c @@ -0,0 +1,739 @@ +/* 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 STZRZF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download STZRZF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE STZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) */ + +/* INTEGER INFO, LDA, LWORK, M, N */ +/* REAL A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > STZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A */ +/* > to upper triangular form by means of orthogonal transformations. */ +/* > */ +/* > The upper trapezoidal matrix A is factored as */ +/* > */ +/* > A = ( R 0 ) * Z, */ +/* > */ +/* > where Z is an N-by-N orthogonal matrix and R is an M-by-M upper */ +/* > triangular matrix. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the leading M-by-N upper trapezoidal part of the */ +/* > array A must contain the matrix to be factorized. */ +/* > On exit, the leading M-by-M upper triangular part of A */ +/* > contains the upper triangular matrix R, and elements M+1 to */ +/* > N of the first M rows of A, with the array TAU, represent the */ +/* > orthogonal matrix Z as a product of M elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is REAL array, dimension (M) */ +/* > The scalar factors of the elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,M). */ +/* > For optimum performance LWORK >= M*NB, where NB is */ +/* > the optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The N-by-N matrix Z can be computed by */ +/* > */ +/* > Z = Z(1)*Z(2)* ... *Z(M) */ +/* > */ +/* > where each N-by-N Z(k) is given by */ +/* > */ +/* > Z(k) = I - tau(k)*v(k)*v(k)**T */ +/* > */ +/* > with v(k) is the kth row vector of the M-by-N matrix */ +/* > */ +/* > V = ( I A(:,M+1:N) ) */ +/* > */ +/* > I is the M-by-M identity matrix, A(:,M+1:N) */ +/* > is the output stored in A on exit from DTZRZF, */ +/* > and tau(k) is the kth element of the array TAU. */ +/* > */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int stzrzf_(integer *m, integer *n, real *a, integer *lda, + real *tau, real *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + + /* Local variables */ + integer i__, nbmin, m1, ib, nb, ki, kk, mu, nx; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int slarzb_(char *, char *, char *, char *, + integer *, integer *, integer *, integer *, real *, integer *, + real *, integer *, real *, integer *, real *, integer *); + integer lwkmin, ldwork, lwkopt; + logical lquery; + extern /* Subroutine */ int slarzt_(char *, char *, integer *, integer *, + real *, integer *, real *, real *, integer *), + slatrz_(integer *, integer *, integer *, real *, integer *, real * + , real *); + integer iws; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < *m) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + + if (*info == 0) { + if (*m == 0 || *m == *n) { + lwkopt = 1; + lwkmin = 1; + } else { + +/* Determine the block size. */ + + nb = ilaenv_(&c__1, "SGERQF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); + lwkopt = *m * nb; + lwkmin = f2cmax(1,*m); + } + work[1] = (real) lwkopt; + + if (*lwork < lwkmin && ! lquery) { + *info = -7; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("STZRZF", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0) { + return 0; + } else if (*m == *n) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tau[i__] = 0.f; +/* L10: */ + } + return 0; + } + + nbmin = 2; + nx = 1; + iws = *m; + if (nb > 1 && nb < *m) { + +/* Determine when to cross over from blocked to unblocked code. */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "SGERQF", " ", m, n, &c_n1, &c_n1, ( + ftnlen)6, (ftnlen)1); + nx = f2cmax(i__1,i__2); + if (nx < *m) { + +/* Determine if workspace is large enough for blocked code. */ + + ldwork = *m; + iws = ldwork * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: reduce NB and */ +/* determine the minimum value of NB. */ + + nb = *lwork / ldwork; +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "SGERQF", " ", m, n, &c_n1, & + c_n1, (ftnlen)6, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + } + } + } + + if (nb >= nbmin && nb < *m && nx < *m) { + +/* Use blocked code initially. */ +/* The last kk rows are handled by the block method. */ + +/* Computing MIN */ + i__1 = *m + 1; + m1 = f2cmin(i__1,*n); + ki = (*m - nx - 1) / nb * nb; +/* Computing MIN */ + i__1 = *m, i__2 = ki + nb; + kk = f2cmin(i__1,i__2); + + i__1 = *m - kk + 1; + i__2 = -nb; + for (i__ = *m - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; + i__ += i__2) { +/* Computing MIN */ + i__3 = *m - i__ + 1; + ib = f2cmin(i__3,nb); + +/* Compute the TZ factorization of the current block */ +/* A(i:i+ib-1,i:n) */ + + i__3 = *n - i__ + 1; + i__4 = *n - *m; + slatrz_(&ib, &i__3, &i__4, &a[i__ + i__ * a_dim1], lda, &tau[i__], + &work[1]); + if (i__ > 1) { + +/* Form the triangular factor of the block reflector */ +/* H = H(i+ib-1) . . . H(i+1) H(i) */ + + i__3 = *n - *m; + slarzt_("Backward", "Rowwise", &i__3, &ib, &a[i__ + m1 * + a_dim1], lda, &tau[i__], &work[1], &ldwork); + +/* Apply H to A(1:i-1,i:n) from the right */ + + i__3 = i__ - 1; + i__4 = *n - i__ + 1; + i__5 = *n - *m; + slarzb_("Right", "No transpose", "Backward", "Rowwise", &i__3, + &i__4, &ib, &i__5, &a[i__ + m1 * a_dim1], lda, &work[ + 1], &ldwork, &a[i__ * a_dim1 + 1], lda, &work[ib + 1], + &ldwork) + ; + } +/* L20: */ + } + mu = i__ + nb - 1; + } else { + mu = *m; + } + +/* Use unblocked code to factor the last or only block */ + + if (mu > 0) { + i__2 = *n - *m; + slatrz_(&mu, n, &i__2, &a[a_offset], lda, &tau[1], &work[1]); + } + + work[1] = (real) lwkopt; + + return 0; + +/* End of STZRZF */ + +} /* stzrzf_ */ + diff --git a/lapack-netlib/SRC/xerbla.c b/lapack-netlib/SRC/xerbla.c new file mode 100644 index 000000000..fffab8a3a --- /dev/null +++ b/lapack-netlib/SRC/xerbla.c @@ -0,0 +1,389 @@ +/* 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 +#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_len(s, n) strlen(s) +#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 XERBLA_ARRAY */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download XERBLA_ARRAY + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE XERBLA_ARRAY( SRNAME_ARRAY, SRNAME_LEN, INFO) */ + +/* INTEGER SRNAME_LEN, INFO */ +/* CHARACTER SRNAME_ARRAY(SRNAME_LEN) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > XERBLA_ARRAY assists other languages in calling XERBLA, the LAPACK */ +/* > and BLAS error handler. Rather than taking a Fortran string argument */ +/* > as the function's name, XERBLA_ARRAY takes an array of single */ +/* > characters along with the array's length. XERBLA_ARRAY then copies */ +/* > up to 32 characters of that array into a Fortran string and passes */ +/* > that to XERBLA. If called with a non-positive SRNAME_LEN, */ +/* > XERBLA_ARRAY will call XERBLA with a string of all blank characters. */ +/* > */ +/* > Say some macro or other device makes XERBLA_ARRAY available to C99 */ +/* > by a name lapack_xerbla and with a common Fortran calling convention. */ +/* > Then a C99 program could invoke XERBLA via: */ +/* > { */ +/* > int flen = strlen(__func__); */ +/* > lapack_xerbla(__func__, &flen, &info); */ +/* > } */ +/* > */ +/* > Providing XERBLA_ARRAY is not necessary for intercepting LAPACK */ +/* > errors. XERBLA_ARRAY calls XERBLA. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SRNAME_ARRAY */ +/* > \verbatim */ +/* > SRNAME_ARRAY is CHARACTER array, dimension (SRNAME_LEN) */ +/* > The name of the routine which called XERBLA_ARRAY. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SRNAME_LEN */ +/* > \verbatim */ +/* > SRNAME_LEN is INTEGER */ +/* > The length of the name in SRNAME_ARRAY. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > The position of the invalid parameter in the parameter list */ +/* > of the calling routine. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int xerbla_array_(char *srname_array__, integer * + srname_len__, integer *info, integer srname_array_len) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + + /* Local variables */ + integer i__; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + char srname[32]; + + +/* -- 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 */ + +/* CHARACTER SRNAME_ARRAY(SRNAME_LEN) */ + +/* ===================================================================== */ + + /* Parameter adjustments */ + --srname_array__; + + /* Function Body */ + s_copy(srname, "", (ftnlen)32, (ftnlen)0); +/* Computing MIN */ + i__2 = *srname_len__, i__3 = i_len(srname, (ftnlen)32); + i__1 = f2cmin(i__2,i__3); + for (i__ = 1; i__ <= i__1; ++i__) { + *(unsigned char *)&srname[i__ - 1] = *(unsigned char *)& + srname_array__[i__]; + } +fprintf(stderr,"xerbla_array calling xerbla with srname #%s#\n",srname); + xerbla_(srname, info, (ftnlen)strlen(srname)); + return 0; +} /* xerbla_array__ */ + diff --git a/lapack-netlib/SRC/zbbcsd.c b/lapack-netlib/SRC/zbbcsd.c new file mode 100644 index 000000000..0a8a2a5d5 --- /dev/null +++ b/lapack-netlib/SRC/zbbcsd.c @@ -0,0 +1,1680 @@ +/* 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 ZBBCSD */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZBBCSD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, */ +/* THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, */ +/* V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, */ +/* B22D, B22E, RWORK, LRWORK, INFO ) */ + +/* CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS */ +/* INTEGER INFO, LDU1, LDU2, LDV1T, LDV2T, LRWORK, M, P, Q */ +/* DOUBLE PRECISION B11D( * ), B11E( * ), B12D( * ), B12E( * ), */ +/* $ B21D( * ), B21E( * ), B22D( * ), B22E( * ), */ +/* $ PHI( * ), THETA( * ), RWORK( * ) */ +/* COMPLEX*16 U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), */ +/* $ V2T( LDV2T, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZBBCSD computes the CS decomposition of a unitary matrix in */ +/* > bidiagonal-block form, */ +/* > */ +/* > */ +/* > [ B11 | B12 0 0 ] */ +/* > [ 0 | 0 -I 0 ] */ +/* > X = [----------------] */ +/* > [ B21 | B22 0 0 ] */ +/* > [ 0 | 0 0 I ] */ +/* > */ +/* > [ C | -S 0 0 ] */ +/* > [ U1 | ] [ 0 | 0 -I 0 ] [ V1 | ]**H */ +/* > = [---------] [---------------] [---------] . */ +/* > [ | U2 ] [ S | C 0 0 ] [ | V2 ] */ +/* > [ 0 | 0 0 I ] */ +/* > */ +/* > X is M-by-M, its top-left block is P-by-Q, and Q must be no larger */ +/* > than P, M-P, or M-Q. (If Q is not the smallest index, then X must be */ +/* > transposed and/or permuted. This can be done in constant time using */ +/* > the TRANS and SIGNS options. See ZUNCSD for details.) */ +/* > */ +/* > The bidiagonal matrices B11, B12, B21, and B22 are represented */ +/* > implicitly by angles THETA(1:Q) and PHI(1:Q-1). */ +/* > */ +/* > The unitary matrices U1, U2, V1T, and V2T are input/output. */ +/* > The input matrices are pre- or post-multiplied by the appropriate */ +/* > singular vector matrices. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBU1 */ +/* > \verbatim */ +/* > JOBU1 is CHARACTER */ +/* > = 'Y': U1 is updated; */ +/* > otherwise: U1 is not updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBU2 */ +/* > \verbatim */ +/* > JOBU2 is CHARACTER */ +/* > = 'Y': U2 is updated; */ +/* > otherwise: U2 is not updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBV1T */ +/* > \verbatim */ +/* > JOBV1T is CHARACTER */ +/* > = 'Y': V1T is updated; */ +/* > otherwise: V1T is not updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBV2T */ +/* > \verbatim */ +/* > JOBV2T is CHARACTER */ +/* > = 'Y': V2T is updated; */ +/* > otherwise: V2T is not updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER */ +/* > = 'T': X, U1, U2, V1T, and V2T are stored in row-major */ +/* > order; */ +/* > otherwise: X, U1, U2, V1T, and V2T are stored in column- */ +/* > major order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows and columns in X, the unitary matrix in */ +/* > bidiagonal-block form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows in the top-left block of X. 0 <= P <= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Q */ +/* > \verbatim */ +/* > Q is INTEGER */ +/* > The number of columns in the top-left block of X. */ +/* > 0 <= Q <= MIN(P,M-P,M-Q). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] THETA */ +/* > \verbatim */ +/* > THETA is DOUBLE PRECISION array, dimension (Q) */ +/* > On entry, the angles THETA(1),...,THETA(Q) that, along with */ +/* > PHI(1), ...,PHI(Q-1), define the matrix in bidiagonal-block */ +/* > form. On exit, the angles whose cosines and sines define the */ +/* > diagonal blocks in the CS decomposition. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] PHI */ +/* > \verbatim */ +/* > PHI is DOUBLE PRECISION array, dimension (Q-1) */ +/* > The angles PHI(1),...,PHI(Q-1) that, along with THETA(1),..., */ +/* > THETA(Q), define the matrix in bidiagonal-block form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] U1 */ +/* > \verbatim */ +/* > U1 is COMPLEX*16 array, dimension (LDU1,P) */ +/* > On entry, a P-by-P matrix. On exit, U1 is postmultiplied */ +/* > by the left singular vector matrix common to [ B11 ; 0 ] and */ +/* > [ B12 0 0 ; 0 -I 0 0 ]. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU1 */ +/* > \verbatim */ +/* > LDU1 is INTEGER */ +/* > The leading dimension of the array U1, LDU1 >= MAX(1,P). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] U2 */ +/* > \verbatim */ +/* > U2 is COMPLEX*16 array, dimension (LDU2,M-P) */ +/* > On entry, an (M-P)-by-(M-P) matrix. On exit, U2 is */ +/* > postmultiplied by the left singular vector matrix common to */ +/* > [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ]. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU2 */ +/* > \verbatim */ +/* > LDU2 is INTEGER */ +/* > The leading dimension of the array U2, LDU2 >= MAX(1,M-P). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] V1T */ +/* > \verbatim */ +/* > V1T is COMPLEX*16 array, dimension (LDV1T,Q) */ +/* > On entry, a Q-by-Q matrix. On exit, V1T is premultiplied */ +/* > by the conjugate transpose of the right singular vector */ +/* > matrix common to [ B11 ; 0 ] and [ B21 ; 0 ]. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV1T */ +/* > \verbatim */ +/* > LDV1T is INTEGER */ +/* > The leading dimension of the array V1T, LDV1T >= MAX(1,Q). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] V2T */ +/* > \verbatim */ +/* > V2T is COMPLEX*16 array, dimension (LDV2T,M-Q) */ +/* > On entry, an (M-Q)-by-(M-Q) matrix. On exit, V2T is */ +/* > premultiplied by the conjugate transpose of the right */ +/* > singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and */ +/* > [ B22 0 0 ; 0 0 I ]. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV2T */ +/* > \verbatim */ +/* > LDV2T is INTEGER */ +/* > The leading dimension of the array V2T, LDV2T >= MAX(1,M-Q). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B11D */ +/* > \verbatim */ +/* > B11D is DOUBLE PRECISION array, dimension (Q) */ +/* > When ZBBCSD converges, B11D contains the cosines of THETA(1), */ +/* > ..., THETA(Q). If ZBBCSD fails to converge, then B11D */ +/* > contains the diagonal of the partially reduced top-left */ +/* > block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B11E */ +/* > \verbatim */ +/* > B11E is DOUBLE PRECISION array, dimension (Q-1) */ +/* > When ZBBCSD converges, B11E contains zeros. If ZBBCSD fails */ +/* > to converge, then B11E contains the superdiagonal of the */ +/* > partially reduced top-left block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B12D */ +/* > \verbatim */ +/* > B12D is DOUBLE PRECISION array, dimension (Q) */ +/* > When ZBBCSD converges, B12D contains the negative sines of */ +/* > THETA(1), ..., THETA(Q). If ZBBCSD fails to converge, then */ +/* > B12D contains the diagonal of the partially reduced top-right */ +/* > block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B12E */ +/* > \verbatim */ +/* > B12E is DOUBLE PRECISION array, dimension (Q-1) */ +/* > When ZBBCSD converges, B12E contains zeros. If ZBBCSD fails */ +/* > to converge, then B12E contains the subdiagonal of the */ +/* > partially reduced top-right block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B21D */ +/* > \verbatim */ +/* > B21D is DOUBLE PRECISION array, dimension (Q) */ +/* > When ZBBCSD converges, B21D contains the negative sines of */ +/* > THETA(1), ..., THETA(Q). If ZBBCSD fails to converge, then */ +/* > B21D contains the diagonal of the partially reduced bottom-left */ +/* > block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B21E */ +/* > \verbatim */ +/* > B21E is DOUBLE PRECISION array, dimension (Q-1) */ +/* > When ZBBCSD converges, B21E contains zeros. If ZBBCSD fails */ +/* > to converge, then B21E contains the subdiagonal of the */ +/* > partially reduced bottom-left block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B22D */ +/* > \verbatim */ +/* > B22D is DOUBLE PRECISION array, dimension (Q) */ +/* > When ZBBCSD converges, B22D contains the negative sines of */ +/* > THETA(1), ..., THETA(Q). If ZBBCSD fails to converge, then */ +/* > B22D contains the diagonal of the partially reduced bottom-right */ +/* > block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B22E */ +/* > \verbatim */ +/* > B22E is DOUBLE PRECISION array, dimension (Q-1) */ +/* > When ZBBCSD converges, B22E contains zeros. If ZBBCSD fails */ +/* > to converge, then B22E contains the subdiagonal of the */ +/* > partially reduced bottom-right block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK)) */ +/* > On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LRWORK */ +/* > \verbatim */ +/* > LRWORK is INTEGER */ +/* > The dimension of the array RWORK. LRWORK >= MAX(1,8*Q). */ +/* > */ +/* > If LRWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal size of the RWORK array, */ +/* > returns this value as the first entry of the work array, and */ +/* > no error message related to LRWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: if ZBBCSD did not converge, INFO specifies the number */ +/* > of nonzero entries in PHI, and B11D, B11E, etc., */ +/* > contain the partially reduced matrix. */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > TOLMUL DOUBLE PRECISION, default = MAX(10,MIN(100,EPS**(-1/8))) */ +/* > TOLMUL controls the convergence criterion of the QR loop. */ +/* > Angles THETA(i), PHI(i) are rounded to 0 or PI/2 when they */ +/* > are within TOLMUL*EPS of either bound. */ +/* > \endverbatim */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. */ +/* > Algorithms, 50(1):33-65, 2009. */ + +/* 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 zbbcsd_(char *jobu1, char *jobu2, char *jobv1t, char * + jobv2t, char *trans, integer *m, integer *p, integer *q, doublereal * + theta, doublereal *phi, doublecomplex *u1, integer *ldu1, + doublecomplex *u2, integer *ldu2, doublecomplex *v1t, integer *ldv1t, + doublecomplex *v2t, integer *ldv2t, doublereal *b11d, doublereal * + b11e, doublereal *b12d, doublereal *b12e, doublereal *b21d, + doublereal *b21e, doublereal *b22d, doublereal *b22e, doublereal * + rwork, integer *lrwork, integer *info) +{ + /* System generated locals */ + integer u1_dim1, u1_offset, u2_dim1, u2_offset, v1t_dim1, v1t_offset, + v2t_dim1, v2t_offset, i__1, i__2; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + integer imin, mini, imax, iter; + doublereal unfl, temp; + logical colmajor; + doublereal thetamin, thetamax; + logical restart11, restart12, restart21, restart22; + extern /* Subroutine */ int dlas2_(doublereal *, doublereal *, doublereal + *, doublereal *, doublereal *); + integer iu1cs, iu2cs, iu1sn, iu2sn, i__, j; + doublereal r__; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *); + integer maxit; + doublereal dummy; + extern /* Subroutine */ int zlasr_(char *, char *, char *, integer *, + integer *, doublereal *, doublereal *, doublecomplex *, integer *), zswap_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *); + doublereal x1, x2, y1, y2; + integer lrworkmin, iv1tcs, iv2tcs; + logical wantu1, wantu2; + integer lrworkopt, iv1tsn, iv2tsn; + extern doublereal dlamch_(char *); + doublereal mu, nu, sigma11, sigma21; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal thresh, tolmul; + extern /* Subroutine */ int mecago_(); + logical lquery; + doublereal b11bulge; + logical wantv1t, wantv2t; + doublereal b12bulge, b21bulge, b22bulge, eps, tol; + extern /* Subroutine */ int dlartgp_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *), dlartgs_(doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *); + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* =================================================================== */ + + + +/* Test input arguments */ + + /* Parameter adjustments */ + --theta; + --phi; + u1_dim1 = *ldu1; + u1_offset = 1 + u1_dim1 * 1; + u1 -= u1_offset; + u2_dim1 = *ldu2; + u2_offset = 1 + u2_dim1 * 1; + u2 -= u2_offset; + v1t_dim1 = *ldv1t; + v1t_offset = 1 + v1t_dim1 * 1; + v1t -= v1t_offset; + v2t_dim1 = *ldv2t; + v2t_offset = 1 + v2t_dim1 * 1; + v2t -= v2t_offset; + --b11d; + --b11e; + --b12d; + --b12e; + --b21d; + --b21e; + --b22d; + --b22e; + --rwork; + + /* Function Body */ + *info = 0; + lquery = *lrwork == -1; + wantu1 = lsame_(jobu1, "Y"); + wantu2 = lsame_(jobu2, "Y"); + wantv1t = lsame_(jobv1t, "Y"); + wantv2t = lsame_(jobv2t, "Y"); + colmajor = ! lsame_(trans, "T"); + + if (*m < 0) { + *info = -6; + } else if (*p < 0 || *p > *m) { + *info = -7; + } else if (*q < 0 || *q > *m) { + *info = -8; + } else if (*q > *p || *q > *m - *p || *q > *m - *q) { + *info = -8; + } else if (wantu1 && *ldu1 < *p) { + *info = -12; + } else if (wantu2 && *ldu2 < *m - *p) { + *info = -14; + } else if (wantv1t && *ldv1t < *q) { + *info = -16; + } else if (wantv2t && *ldv2t < *m - *q) { + *info = -18; + } + +/* Quick return if Q = 0 */ + + if (*info == 0 && *q == 0) { + lrworkmin = 1; + rwork[1] = (doublereal) lrworkmin; + return 0; + } + +/* Compute workspace */ + + if (*info == 0) { + iu1cs = 1; + iu1sn = iu1cs + *q; + iu2cs = iu1sn + *q; + iu2sn = iu2cs + *q; + iv1tcs = iu2sn + *q; + iv1tsn = iv1tcs + *q; + iv2tcs = iv1tsn + *q; + iv2tsn = iv2tcs + *q; + lrworkopt = iv2tsn + *q - 1; + lrworkmin = lrworkopt; + rwork[1] = (doublereal) lrworkopt; + if (*lrwork < lrworkmin && ! lquery) { + *info = -28; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZBBCSD", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("Epsilon"); + unfl = dlamch_("Safe minimum"); +/* Computing MAX */ +/* Computing MIN */ + d__3 = 100., d__4 = pow_dd(&eps, &c_b11); + d__1 = 10., d__2 = f2cmin(d__3,d__4); + tolmul = f2cmax(d__1,d__2); + tol = tolmul * eps; +/* Computing MAX */ + d__1 = tol, d__2 = *q * 6 * *q * unfl; + thresh = f2cmax(d__1,d__2); + +/* Test for negligible sines or cosines */ + + i__1 = *q; + for (i__ = 1; i__ <= i__1; ++i__) { + if (theta[i__] < thresh) { + theta[i__] = 0.; + } else if (theta[i__] > 1.57079632679489662 - thresh) { + theta[i__] = 1.57079632679489662; + } + } + i__1 = *q - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + if (phi[i__] < thresh) { + phi[i__] = 0.; + } else if (phi[i__] > 1.57079632679489662 - thresh) { + phi[i__] = 1.57079632679489662; + } + } + +/* Initial deflation */ + + imax = *q; + while(imax > 1) { + if (phi[imax - 1] != 0.) { + myexit_(); + } + --imax; + } + imin = imax - 1; + if (imin > 1) { + while(phi[imin - 1] != 0.) { + --imin; + if (imin <= 1) { + myexit_(); + } + } + } + +/* Initialize iteration counter */ + + maxit = *q * 6 * *q; + iter = 0; + +/* Begin main iteration loop */ + + while(imax > 1) { + +/* Compute the matrix entries */ + + b11d[imin] = cos(theta[imin]); + b21d[imin] = -sin(theta[imin]); + i__1 = imax - 1; + for (i__ = imin; i__ <= i__1; ++i__) { + b11e[i__] = -sin(theta[i__]) * sin(phi[i__]); + b11d[i__ + 1] = cos(theta[i__ + 1]) * cos(phi[i__]); + b12d[i__] = sin(theta[i__]) * cos(phi[i__]); + b12e[i__] = cos(theta[i__ + 1]) * sin(phi[i__]); + b21e[i__] = -cos(theta[i__]) * sin(phi[i__]); + b21d[i__ + 1] = -sin(theta[i__ + 1]) * cos(phi[i__]); + b22d[i__] = cos(theta[i__]) * cos(phi[i__]); + b22e[i__] = -sin(theta[i__ + 1]) * sin(phi[i__]); + } + b12d[imax] = sin(theta[imax]); + b22d[imax] = cos(theta[imax]); + +/* Abort if not converging; otherwise, increment ITER */ + + if (iter > maxit) { + *info = 0; + i__1 = *q; + for (i__ = 1; i__ <= i__1; ++i__) { + if (phi[i__] != 0.) { + ++(*info); + } + } + return 0; + } + + iter = iter + imax - imin; + +/* Compute shifts */ + + thetamax = theta[imin]; + thetamin = theta[imin]; + i__1 = imax; + for (i__ = imin + 1; i__ <= i__1; ++i__) { + if (theta[i__] > thetamax) { + thetamax = theta[i__]; + } + if (theta[i__] < thetamin) { + thetamin = theta[i__]; + } + } + + if (thetamax > 1.57079632679489662 - thresh) { + +/* Zero on diagonals of B11 and B22; induce deflation with a */ +/* zero shift */ + + mu = 0.; + nu = 1.; + + } else if (thetamin < thresh) { + +/* Zero on diagonals of B12 and B22; induce deflation with a */ +/* zero shift */ + + mu = 1.; + nu = 0.; + + } else { + +/* Compute shifts for B11 and B21 and use the lesser */ + + dlas2_(&b11d[imax - 1], &b11e[imax - 1], &b11d[imax], &sigma11, & + dummy); + dlas2_(&b21d[imax - 1], &b21e[imax - 1], &b21d[imax], &sigma21, & + dummy); + + if (sigma11 <= sigma21) { + mu = sigma11; +/* Computing 2nd power */ + d__1 = mu; + nu = sqrt(1. - d__1 * d__1); + if (mu < thresh) { + mu = 0.; + nu = 1.; + } + } else { + nu = sigma21; +/* Computing 2nd power */ + d__1 = nu; + mu = sqrt(1.f - d__1 * d__1); + if (nu < thresh) { + mu = 1.; + nu = 0.; + } + } + } + +/* Rotate to produce bulges in B11 and B21 */ + + if (mu <= nu) { + dlartgs_(&b11d[imin], &b11e[imin], &mu, &rwork[iv1tcs + imin - 1], + &rwork[iv1tsn + imin - 1]); + } else { + dlartgs_(&b21d[imin], &b21e[imin], &nu, &rwork[iv1tcs + imin - 1], + &rwork[iv1tsn + imin - 1]); + } + + temp = rwork[iv1tcs + imin - 1] * b11d[imin] + rwork[iv1tsn + imin - + 1] * b11e[imin]; + b11e[imin] = rwork[iv1tcs + imin - 1] * b11e[imin] - rwork[iv1tsn + + imin - 1] * b11d[imin]; + b11d[imin] = temp; + b11bulge = rwork[iv1tsn + imin - 1] * b11d[imin + 1]; + b11d[imin + 1] = rwork[iv1tcs + imin - 1] * b11d[imin + 1]; + temp = rwork[iv1tcs + imin - 1] * b21d[imin] + rwork[iv1tsn + imin - + 1] * b21e[imin]; + b21e[imin] = rwork[iv1tcs + imin - 1] * b21e[imin] - rwork[iv1tsn + + imin - 1] * b21d[imin]; + b21d[imin] = temp; + b21bulge = rwork[iv1tsn + imin - 1] * b21d[imin + 1]; + b21d[imin + 1] = rwork[iv1tcs + imin - 1] * b21d[imin + 1]; + +/* Compute THETA(IMIN) */ + +/* Computing 2nd power */ + d__1 = b21d[imin]; +/* Computing 2nd power */ + d__2 = b21bulge; +/* Computing 2nd power */ + d__3 = b11d[imin]; +/* Computing 2nd power */ + d__4 = b11bulge; + theta[imin] = atan2(sqrt(d__1 * d__1 + d__2 * d__2), sqrt(d__3 * d__3 + + d__4 * d__4)); + +/* Chase the bulges in B11(IMIN+1,IMIN) and B21(IMIN+1,IMIN) */ + +/* Computing 2nd power */ + d__1 = b11d[imin]; +/* Computing 2nd power */ + d__2 = b11bulge; +/* Computing 2nd power */ + d__3 = thresh; + if (d__1 * d__1 + d__2 * d__2 > d__3 * d__3) { + dlartgp_(&b11bulge, &b11d[imin], &rwork[iu1sn + imin - 1], &rwork[ + iu1cs + imin - 1], &r__); + } else if (mu <= nu) { + dlartgs_(&b11e[imin], &b11d[imin + 1], &mu, &rwork[iu1cs + imin - + 1], &rwork[iu1sn + imin - 1]); + } else { + dlartgs_(&b12d[imin], &b12e[imin], &nu, &rwork[iu1cs + imin - 1], + &rwork[iu1sn + imin - 1]); + } +/* Computing 2nd power */ + d__1 = b21d[imin]; +/* Computing 2nd power */ + d__2 = b21bulge; +/* Computing 2nd power */ + d__3 = thresh; + if (d__1 * d__1 + d__2 * d__2 > d__3 * d__3) { + dlartgp_(&b21bulge, &b21d[imin], &rwork[iu2sn + imin - 1], &rwork[ + iu2cs + imin - 1], &r__); + } else if (nu < mu) { + dlartgs_(&b21e[imin], &b21d[imin + 1], &nu, &rwork[iu2cs + imin - + 1], &rwork[iu2sn + imin - 1]); + } else { + dlartgs_(&b22d[imin], &b22e[imin], &mu, &rwork[iu2cs + imin - 1], + &rwork[iu2sn + imin - 1]); + } + rwork[iu2cs + imin - 1] = -rwork[iu2cs + imin - 1]; + rwork[iu2sn + imin - 1] = -rwork[iu2sn + imin - 1]; + + temp = rwork[iu1cs + imin - 1] * b11e[imin] + rwork[iu1sn + imin - 1] + * b11d[imin + 1]; + b11d[imin + 1] = rwork[iu1cs + imin - 1] * b11d[imin + 1] - rwork[ + iu1sn + imin - 1] * b11e[imin]; + b11e[imin] = temp; + if (imax > imin + 1) { + b11bulge = rwork[iu1sn + imin - 1] * b11e[imin + 1]; + b11e[imin + 1] = rwork[iu1cs + imin - 1] * b11e[imin + 1]; + } + temp = rwork[iu1cs + imin - 1] * b12d[imin] + rwork[iu1sn + imin - 1] + * b12e[imin]; + b12e[imin] = rwork[iu1cs + imin - 1] * b12e[imin] - rwork[iu1sn + + imin - 1] * b12d[imin]; + b12d[imin] = temp; + b12bulge = rwork[iu1sn + imin - 1] * b12d[imin + 1]; + b12d[imin + 1] = rwork[iu1cs + imin - 1] * b12d[imin + 1]; + temp = rwork[iu2cs + imin - 1] * b21e[imin] + rwork[iu2sn + imin - 1] + * b21d[imin + 1]; + b21d[imin + 1] = rwork[iu2cs + imin - 1] * b21d[imin + 1] - rwork[ + iu2sn + imin - 1] * b21e[imin]; + b21e[imin] = temp; + if (imax > imin + 1) { + b21bulge = rwork[iu2sn + imin - 1] * b21e[imin + 1]; + b21e[imin + 1] = rwork[iu2cs + imin - 1] * b21e[imin + 1]; + } + temp = rwork[iu2cs + imin - 1] * b22d[imin] + rwork[iu2sn + imin - 1] + * b22e[imin]; + b22e[imin] = rwork[iu2cs + imin - 1] * b22e[imin] - rwork[iu2sn + + imin - 1] * b22d[imin]; + b22d[imin] = temp; + b22bulge = rwork[iu2sn + imin - 1] * b22d[imin + 1]; + b22d[imin + 1] = rwork[iu2cs + imin - 1] * b22d[imin + 1]; + +/* Inner loop: chase bulges from B11(IMIN,IMIN+2), */ +/* B12(IMIN,IMIN+1), B21(IMIN,IMIN+2), and B22(IMIN,IMIN+1) to */ +/* bottom-right */ + + i__1 = imax - 1; + for (i__ = imin + 1; i__ <= i__1; ++i__) { + +/* Compute PHI(I-1) */ + + x1 = sin(theta[i__ - 1]) * b11e[i__ - 1] + cos(theta[i__ - 1]) * + b21e[i__ - 1]; + x2 = sin(theta[i__ - 1]) * b11bulge + cos(theta[i__ - 1]) * + b21bulge; + y1 = sin(theta[i__ - 1]) * b12d[i__ - 1] + cos(theta[i__ - 1]) * + b22d[i__ - 1]; + y2 = sin(theta[i__ - 1]) * b12bulge + cos(theta[i__ - 1]) * + b22bulge; + +/* Computing 2nd power */ + d__1 = x1; +/* Computing 2nd power */ + d__2 = x2; +/* Computing 2nd power */ + d__3 = y1; +/* Computing 2nd power */ + d__4 = y2; + phi[i__ - 1] = atan2(sqrt(d__1 * d__1 + d__2 * d__2), sqrt(d__3 * + d__3 + d__4 * d__4)); + +/* Determine if there are bulges to chase or if a new direct */ +/* summand has been reached */ + +/* Computing 2nd power */ + d__1 = b11e[i__ - 1]; +/* Computing 2nd power */ + d__2 = b11bulge; +/* Computing 2nd power */ + d__3 = thresh; + restart11 = d__1 * d__1 + d__2 * d__2 <= d__3 * d__3; +/* Computing 2nd power */ + d__1 = b21e[i__ - 1]; +/* Computing 2nd power */ + d__2 = b21bulge; +/* Computing 2nd power */ + d__3 = thresh; + restart21 = d__1 * d__1 + d__2 * d__2 <= d__3 * d__3; +/* Computing 2nd power */ + d__1 = b12d[i__ - 1]; +/* Computing 2nd power */ + d__2 = b12bulge; +/* Computing 2nd power */ + d__3 = thresh; + restart12 = d__1 * d__1 + d__2 * d__2 <= d__3 * d__3; +/* Computing 2nd power */ + d__1 = b22d[i__ - 1]; +/* Computing 2nd power */ + d__2 = b22bulge; +/* Computing 2nd power */ + d__3 = thresh; + restart22 = d__1 * d__1 + d__2 * d__2 <= d__3 * d__3; + +/* If possible, chase bulges from B11(I-1,I+1), B12(I-1,I), */ +/* B21(I-1,I+1), and B22(I-1,I). If necessary, restart bulge- */ +/* chasing by applying the original shift again. */ + + if (! restart11 && ! restart21) { + dlartgp_(&x2, &x1, &rwork[iv1tsn + i__ - 1], &rwork[iv1tcs + + i__ - 1], &r__); + } else if (! restart11 && restart21) { + dlartgp_(&b11bulge, &b11e[i__ - 1], &rwork[iv1tsn + i__ - 1], + &rwork[iv1tcs + i__ - 1], &r__); + } else if (restart11 && ! restart21) { + dlartgp_(&b21bulge, &b21e[i__ - 1], &rwork[iv1tsn + i__ - 1], + &rwork[iv1tcs + i__ - 1], &r__); + } else if (mu <= nu) { + dlartgs_(&b11d[i__], &b11e[i__], &mu, &rwork[iv1tcs + i__ - 1] + , &rwork[iv1tsn + i__ - 1]); + } else { + dlartgs_(&b21d[i__], &b21e[i__], &nu, &rwork[iv1tcs + i__ - 1] + , &rwork[iv1tsn + i__ - 1]); + } + rwork[iv1tcs + i__ - 1] = -rwork[iv1tcs + i__ - 1]; + rwork[iv1tsn + i__ - 1] = -rwork[iv1tsn + i__ - 1]; + if (! restart12 && ! restart22) { + dlartgp_(&y2, &y1, &rwork[iv2tsn + i__ - 2], &rwork[iv2tcs + + i__ - 2], &r__); + } else if (! restart12 && restart22) { + dlartgp_(&b12bulge, &b12d[i__ - 1], &rwork[iv2tsn + i__ - 2], + &rwork[iv2tcs + i__ - 2], &r__); + } else if (restart12 && ! restart22) { + dlartgp_(&b22bulge, &b22d[i__ - 1], &rwork[iv2tsn + i__ - 2], + &rwork[iv2tcs + i__ - 2], &r__); + } else if (nu < mu) { + dlartgs_(&b12e[i__ - 1], &b12d[i__], &nu, &rwork[iv2tcs + i__ + - 2], &rwork[iv2tsn + i__ - 2]); + } else { + dlartgs_(&b22e[i__ - 1], &b22d[i__], &mu, &rwork[iv2tcs + i__ + - 2], &rwork[iv2tsn + i__ - 2]); + } + + temp = rwork[iv1tcs + i__ - 1] * b11d[i__] + rwork[iv1tsn + i__ - + 1] * b11e[i__]; + b11e[i__] = rwork[iv1tcs + i__ - 1] * b11e[i__] - rwork[iv1tsn + + i__ - 1] * b11d[i__]; + b11d[i__] = temp; + b11bulge = rwork[iv1tsn + i__ - 1] * b11d[i__ + 1]; + b11d[i__ + 1] = rwork[iv1tcs + i__ - 1] * b11d[i__ + 1]; + temp = rwork[iv1tcs + i__ - 1] * b21d[i__] + rwork[iv1tsn + i__ - + 1] * b21e[i__]; + b21e[i__] = rwork[iv1tcs + i__ - 1] * b21e[i__] - rwork[iv1tsn + + i__ - 1] * b21d[i__]; + b21d[i__] = temp; + b21bulge = rwork[iv1tsn + i__ - 1] * b21d[i__ + 1]; + b21d[i__ + 1] = rwork[iv1tcs + i__ - 1] * b21d[i__ + 1]; + temp = rwork[iv2tcs + i__ - 2] * b12e[i__ - 1] + rwork[iv2tsn + + i__ - 2] * b12d[i__]; + b12d[i__] = rwork[iv2tcs + i__ - 2] * b12d[i__] - rwork[iv2tsn + + i__ - 2] * b12e[i__ - 1]; + b12e[i__ - 1] = temp; + b12bulge = rwork[iv2tsn + i__ - 2] * b12e[i__]; + b12e[i__] = rwork[iv2tcs + i__ - 2] * b12e[i__]; + temp = rwork[iv2tcs + i__ - 2] * b22e[i__ - 1] + rwork[iv2tsn + + i__ - 2] * b22d[i__]; + b22d[i__] = rwork[iv2tcs + i__ - 2] * b22d[i__] - rwork[iv2tsn + + i__ - 2] * b22e[i__ - 1]; + b22e[i__ - 1] = temp; + b22bulge = rwork[iv2tsn + i__ - 2] * b22e[i__]; + b22e[i__] = rwork[iv2tcs + i__ - 2] * b22e[i__]; + +/* Compute THETA(I) */ + + x1 = cos(phi[i__ - 1]) * b11d[i__] + sin(phi[i__ - 1]) * b12e[i__ + - 1]; + x2 = cos(phi[i__ - 1]) * b11bulge + sin(phi[i__ - 1]) * b12bulge; + y1 = cos(phi[i__ - 1]) * b21d[i__] + sin(phi[i__ - 1]) * b22e[i__ + - 1]; + y2 = cos(phi[i__ - 1]) * b21bulge + sin(phi[i__ - 1]) * b22bulge; + +/* Computing 2nd power */ + d__1 = y1; +/* Computing 2nd power */ + d__2 = y2; +/* Computing 2nd power */ + d__3 = x1; +/* Computing 2nd power */ + d__4 = x2; + theta[i__] = atan2(sqrt(d__1 * d__1 + d__2 * d__2), sqrt(d__3 * + d__3 + d__4 * d__4)); + +/* Determine if there are bulges to chase or if a new direct */ +/* summand has been reached */ + +/* Computing 2nd power */ + d__1 = b11d[i__]; +/* Computing 2nd power */ + d__2 = b11bulge; +/* Computing 2nd power */ + d__3 = thresh; + restart11 = d__1 * d__1 + d__2 * d__2 <= d__3 * d__3; +/* Computing 2nd power */ + d__1 = b12e[i__ - 1]; +/* Computing 2nd power */ + d__2 = b12bulge; +/* Computing 2nd power */ + d__3 = thresh; + restart12 = d__1 * d__1 + d__2 * d__2 <= d__3 * d__3; +/* Computing 2nd power */ + d__1 = b21d[i__]; +/* Computing 2nd power */ + d__2 = b21bulge; +/* Computing 2nd power */ + d__3 = thresh; + restart21 = d__1 * d__1 + d__2 * d__2 <= d__3 * d__3; +/* Computing 2nd power */ + d__1 = b22e[i__ - 1]; +/* Computing 2nd power */ + d__2 = b22bulge; +/* Computing 2nd power */ + d__3 = thresh; + restart22 = d__1 * d__1 + d__2 * d__2 <= d__3 * d__3; + +/* If possible, chase bulges from B11(I+1,I), B12(I+1,I-1), */ +/* B21(I+1,I), and B22(I+1,I-1). If necessary, restart bulge- */ +/* chasing by applying the original shift again. */ + + if (! restart11 && ! restart12) { + dlartgp_(&x2, &x1, &rwork[iu1sn + i__ - 1], &rwork[iu1cs + + i__ - 1], &r__); + } else if (! restart11 && restart12) { + dlartgp_(&b11bulge, &b11d[i__], &rwork[iu1sn + i__ - 1], & + rwork[iu1cs + i__ - 1], &r__); + } else if (restart11 && ! restart12) { + dlartgp_(&b12bulge, &b12e[i__ - 1], &rwork[iu1sn + i__ - 1], & + rwork[iu1cs + i__ - 1], &r__); + } else if (mu <= nu) { + dlartgs_(&b11e[i__], &b11d[i__ + 1], &mu, &rwork[iu1cs + i__ + - 1], &rwork[iu1sn + i__ - 1]); + } else { + dlartgs_(&b12d[i__], &b12e[i__], &nu, &rwork[iu1cs + i__ - 1], + &rwork[iu1sn + i__ - 1]); + } + if (! restart21 && ! restart22) { + dlartgp_(&y2, &y1, &rwork[iu2sn + i__ - 1], &rwork[iu2cs + + i__ - 1], &r__); + } else if (! restart21 && restart22) { + dlartgp_(&b21bulge, &b21d[i__], &rwork[iu2sn + i__ - 1], & + rwork[iu2cs + i__ - 1], &r__); + } else if (restart21 && ! restart22) { + dlartgp_(&b22bulge, &b22e[i__ - 1], &rwork[iu2sn + i__ - 1], & + rwork[iu2cs + i__ - 1], &r__); + } else if (nu < mu) { + dlartgs_(&b21e[i__], &b21e[i__ + 1], &nu, &rwork[iu2cs + i__ + - 1], &rwork[iu2sn + i__ - 1]); + } else { + dlartgs_(&b22d[i__], &b22e[i__], &mu, &rwork[iu2cs + i__ - 1], + &rwork[iu2sn + i__ - 1]); + } + rwork[iu2cs + i__ - 1] = -rwork[iu2cs + i__ - 1]; + rwork[iu2sn + i__ - 1] = -rwork[iu2sn + i__ - 1]; + + temp = rwork[iu1cs + i__ - 1] * b11e[i__] + rwork[iu1sn + i__ - 1] + * b11d[i__ + 1]; + b11d[i__ + 1] = rwork[iu1cs + i__ - 1] * b11d[i__ + 1] - rwork[ + iu1sn + i__ - 1] * b11e[i__]; + b11e[i__] = temp; + if (i__ < imax - 1) { + b11bulge = rwork[iu1sn + i__ - 1] * b11e[i__ + 1]; + b11e[i__ + 1] = rwork[iu1cs + i__ - 1] * b11e[i__ + 1]; + } + temp = rwork[iu2cs + i__ - 1] * b21e[i__] + rwork[iu2sn + i__ - 1] + * b21d[i__ + 1]; + b21d[i__ + 1] = rwork[iu2cs + i__ - 1] * b21d[i__ + 1] - rwork[ + iu2sn + i__ - 1] * b21e[i__]; + b21e[i__] = temp; + if (i__ < imax - 1) { + b21bulge = rwork[iu2sn + i__ - 1] * b21e[i__ + 1]; + b21e[i__ + 1] = rwork[iu2cs + i__ - 1] * b21e[i__ + 1]; + } + temp = rwork[iu1cs + i__ - 1] * b12d[i__] + rwork[iu1sn + i__ - 1] + * b12e[i__]; + b12e[i__] = rwork[iu1cs + i__ - 1] * b12e[i__] - rwork[iu1sn + + i__ - 1] * b12d[i__]; + b12d[i__] = temp; + b12bulge = rwork[iu1sn + i__ - 1] * b12d[i__ + 1]; + b12d[i__ + 1] = rwork[iu1cs + i__ - 1] * b12d[i__ + 1]; + temp = rwork[iu2cs + i__ - 1] * b22d[i__] + rwork[iu2sn + i__ - 1] + * b22e[i__]; + b22e[i__] = rwork[iu2cs + i__ - 1] * b22e[i__] - rwork[iu2sn + + i__ - 1] * b22d[i__]; + b22d[i__] = temp; + b22bulge = rwork[iu2sn + i__ - 1] * b22d[i__ + 1]; + b22d[i__ + 1] = rwork[iu2cs + i__ - 1] * b22d[i__ + 1]; + + } + +/* Compute PHI(IMAX-1) */ + + x1 = sin(theta[imax - 1]) * b11e[imax - 1] + cos(theta[imax - 1]) * + b21e[imax - 1]; + y1 = sin(theta[imax - 1]) * b12d[imax - 1] + cos(theta[imax - 1]) * + b22d[imax - 1]; + y2 = sin(theta[imax - 1]) * b12bulge + cos(theta[imax - 1]) * + b22bulge; + +/* Computing 2nd power */ + d__1 = y1; +/* Computing 2nd power */ + d__2 = y2; + phi[imax - 1] = atan2((abs(x1)), sqrt(d__1 * d__1 + d__2 * d__2)); + +/* Chase bulges from B12(IMAX-1,IMAX) and B22(IMAX-1,IMAX) */ + +/* Computing 2nd power */ + d__1 = b12d[imax - 1]; +/* Computing 2nd power */ + d__2 = b12bulge; +/* Computing 2nd power */ + d__3 = thresh; + restart12 = d__1 * d__1 + d__2 * d__2 <= d__3 * d__3; +/* Computing 2nd power */ + d__1 = b22d[imax - 1]; +/* Computing 2nd power */ + d__2 = b22bulge; +/* Computing 2nd power */ + d__3 = thresh; + restart22 = d__1 * d__1 + d__2 * d__2 <= d__3 * d__3; + + if (! restart12 && ! restart22) { + dlartgp_(&y2, &y1, &rwork[iv2tsn + imax - 2], &rwork[iv2tcs + + imax - 2], &r__); + } else if (! restart12 && restart22) { + dlartgp_(&b12bulge, &b12d[imax - 1], &rwork[iv2tsn + imax - 2], & + rwork[iv2tcs + imax - 2], &r__); + } else if (restart12 && ! restart22) { + dlartgp_(&b22bulge, &b22d[imax - 1], &rwork[iv2tsn + imax - 2], & + rwork[iv2tcs + imax - 2], &r__); + } else if (nu < mu) { + dlartgs_(&b12e[imax - 1], &b12d[imax], &nu, &rwork[iv2tcs + imax + - 2], &rwork[iv2tsn + imax - 2]); + } else { + dlartgs_(&b22e[imax - 1], &b22d[imax], &mu, &rwork[iv2tcs + imax + - 2], &rwork[iv2tsn + imax - 2]); + } + + temp = rwork[iv2tcs + imax - 2] * b12e[imax - 1] + rwork[iv2tsn + + imax - 2] * b12d[imax]; + b12d[imax] = rwork[iv2tcs + imax - 2] * b12d[imax] - rwork[iv2tsn + + imax - 2] * b12e[imax - 1]; + b12e[imax - 1] = temp; + temp = rwork[iv2tcs + imax - 2] * b22e[imax - 1] + rwork[iv2tsn + + imax - 2] * b22d[imax]; + b22d[imax] = rwork[iv2tcs + imax - 2] * b22d[imax] - rwork[iv2tsn + + imax - 2] * b22e[imax - 1]; + b22e[imax - 1] = temp; + +/* Update singular vectors */ + + if (wantu1) { + if (colmajor) { + i__1 = imax - imin + 1; + zlasr_("R", "V", "F", p, &i__1, &rwork[iu1cs + imin - 1], & + rwork[iu1sn + imin - 1], &u1[imin * u1_dim1 + 1], + ldu1); + } else { + i__1 = imax - imin + 1; + zlasr_("L", "V", "F", &i__1, p, &rwork[iu1cs + imin - 1], & + rwork[iu1sn + imin - 1], &u1[imin + u1_dim1], ldu1); + } + } + if (wantu2) { + if (colmajor) { + i__1 = *m - *p; + i__2 = imax - imin + 1; + zlasr_("R", "V", "F", &i__1, &i__2, &rwork[iu2cs + imin - 1], + &rwork[iu2sn + imin - 1], &u2[imin * u2_dim1 + 1], + ldu2); + } else { + i__1 = imax - imin + 1; + i__2 = *m - *p; + zlasr_("L", "V", "F", &i__1, &i__2, &rwork[iu2cs + imin - 1], + &rwork[iu2sn + imin - 1], &u2[imin + u2_dim1], ldu2); + } + } + if (wantv1t) { + if (colmajor) { + i__1 = imax - imin + 1; + zlasr_("L", "V", "F", &i__1, q, &rwork[iv1tcs + imin - 1], & + rwork[iv1tsn + imin - 1], &v1t[imin + v1t_dim1], + ldv1t); + } else { + i__1 = imax - imin + 1; + zlasr_("R", "V", "F", q, &i__1, &rwork[iv1tcs + imin - 1], & + rwork[iv1tsn + imin - 1], &v1t[imin * v1t_dim1 + 1], + ldv1t); + } + } + if (wantv2t) { + if (colmajor) { + i__1 = imax - imin + 1; + i__2 = *m - *q; + zlasr_("L", "V", "F", &i__1, &i__2, &rwork[iv2tcs + imin - 1], + &rwork[iv2tsn + imin - 1], &v2t[imin + v2t_dim1], + ldv2t); + } else { + i__1 = *m - *q; + i__2 = imax - imin + 1; + zlasr_("R", "V", "F", &i__1, &i__2, &rwork[iv2tcs + imin - 1], + &rwork[iv2tsn + imin - 1], &v2t[imin * v2t_dim1 + 1], + ldv2t); + } + } + +/* Fix signs on B11(IMAX-1,IMAX) and B21(IMAX-1,IMAX) */ + + if (b11e[imax - 1] + b21e[imax - 1] > 0.) { + b11d[imax] = -b11d[imax]; + b21d[imax] = -b21d[imax]; + if (wantv1t) { + if (colmajor) { + zscal_(q, &c_b1, &v1t[imax + v1t_dim1], ldv1t); + } else { + zscal_(q, &c_b1, &v1t[imax * v1t_dim1 + 1], &c__1); + } + } + } + +/* Compute THETA(IMAX) */ + + x1 = cos(phi[imax - 1]) * b11d[imax] + sin(phi[imax - 1]) * b12e[imax + - 1]; + y1 = cos(phi[imax - 1]) * b21d[imax] + sin(phi[imax - 1]) * b22e[imax + - 1]; + + theta[imax] = atan2((abs(y1)), (abs(x1))); + +/* Fix signs on B11(IMAX,IMAX), B12(IMAX,IMAX-1), B21(IMAX,IMAX), */ +/* and B22(IMAX,IMAX-1) */ + + if (b11d[imax] + b12e[imax - 1] < 0.) { + b12d[imax] = -b12d[imax]; + if (wantu1) { + if (colmajor) { + zscal_(p, &c_b1, &u1[imax * u1_dim1 + 1], &c__1); + } else { + zscal_(p, &c_b1, &u1[imax + u1_dim1], ldu1); + } + } + } + if (b21d[imax] + b22e[imax - 1] > 0.) { + b22d[imax] = -b22d[imax]; + if (wantu2) { + if (colmajor) { + i__1 = *m - *p; + zscal_(&i__1, &c_b1, &u2[imax * u2_dim1 + 1], &c__1); + } else { + i__1 = *m - *p; + zscal_(&i__1, &c_b1, &u2[imax + u2_dim1], ldu2); + } + } + } + +/* Fix signs on B12(IMAX,IMAX) and B22(IMAX,IMAX) */ + + if (b12d[imax] + b22d[imax] < 0.) { + if (wantv2t) { + if (colmajor) { + i__1 = *m - *q; + zscal_(&i__1, &c_b1, &v2t[imax + v2t_dim1], ldv2t); + } else { + i__1 = *m - *q; + zscal_(&i__1, &c_b1, &v2t[imax * v2t_dim1 + 1], &c__1); + } + } + } + +/* Test for negligible sines or cosines */ + + i__1 = imax; + for (i__ = imin; i__ <= i__1; ++i__) { + if (theta[i__] < thresh) { + theta[i__] = 0.; + } else if (theta[i__] > 1.57079632679489662 - thresh) { + theta[i__] = 1.57079632679489662; + } + } + i__1 = imax - 1; + for (i__ = imin; i__ <= i__1; ++i__) { + if (phi[i__] < thresh) { + phi[i__] = 0.; + } else if (phi[i__] > 1.57079632679489662 - thresh) { + phi[i__] = 1.57079632679489662; + } + } + +/* Deflate */ + + if (imax > 1) { + while(phi[imax - 1] == 0.) { + --imax; + if (imax <= 1) { + myexit_(); + } + } + } + if (imin > imax - 1) { + imin = imax - 1; + } + if (imin > 1) { + while(phi[imin - 1] != 0.) { + --imin; + if (imin <= 1) { + myexit_(); + } + } + } + +/* Repeat main iteration loop */ + + } + +/* Postprocessing: order THETA from least to greatest */ + + i__1 = *q; + for (i__ = 1; i__ <= i__1; ++i__) { + + mini = i__; + thetamin = theta[i__]; + i__2 = *q; + for (j = i__ + 1; j <= i__2; ++j) { + if (theta[j] < thetamin) { + mini = j; + thetamin = theta[j]; + } + } + + if (mini != i__) { + theta[mini] = theta[i__]; + theta[i__] = thetamin; + if (colmajor) { + if (wantu1) { + zswap_(p, &u1[i__ * u1_dim1 + 1], &c__1, &u1[mini * + u1_dim1 + 1], &c__1); + } + if (wantu2) { + i__2 = *m - *p; + zswap_(&i__2, &u2[i__ * u2_dim1 + 1], &c__1, &u2[mini * + u2_dim1 + 1], &c__1); + } + if (wantv1t) { + zswap_(q, &v1t[i__ + v1t_dim1], ldv1t, &v1t[mini + + v1t_dim1], ldv1t); + } + if (wantv2t) { + i__2 = *m - *q; + zswap_(&i__2, &v2t[i__ + v2t_dim1], ldv2t, &v2t[mini + + v2t_dim1], ldv2t); + } + } else { + if (wantu1) { + zswap_(p, &u1[i__ + u1_dim1], ldu1, &u1[mini + u1_dim1], + ldu1); + } + if (wantu2) { + i__2 = *m - *p; + zswap_(&i__2, &u2[i__ + u2_dim1], ldu2, &u2[mini + + u2_dim1], ldu2); + } + if (wantv1t) { + zswap_(q, &v1t[i__ * v1t_dim1 + 1], &c__1, &v1t[mini * + v1t_dim1 + 1], &c__1); + } + if (wantv2t) { + i__2 = *m - *q; + zswap_(&i__2, &v2t[i__ * v2t_dim1 + 1], &c__1, &v2t[mini * + v2t_dim1 + 1], &c__1); + } + } + } + + } + + return 0; + +/* End of ZBBCSD */ + +} /* zbbcsd_ */ + diff --git a/lapack-netlib/SRC/zbdsqr.c b/lapack-netlib/SRC/zbdsqr.c new file mode 100644 index 000000000..ed4d2d916 --- /dev/null +++ b/lapack-netlib/SRC/zbdsqr.c @@ -0,0 +1,1368 @@ +/* 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 ZBDSQR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZBDSQR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U, */ +/* LDU, C, LDC, RWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU */ +/* DOUBLE PRECISION D( * ), E( * ), RWORK( * ) */ +/* COMPLEX*16 C( LDC, * ), U( LDU, * ), VT( LDVT, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZBDSQR computes the singular values and, optionally, the right and/or */ +/* > left singular vectors from the singular value decomposition (SVD) of */ +/* > a real N-by-N (upper or lower) bidiagonal matrix B using the implicit */ +/* > zero-shift QR algorithm. The SVD of B has the form */ +/* > */ +/* > B = Q * S * P**H */ +/* > */ +/* > where S is the diagonal matrix of singular values, Q is an orthogonal */ +/* > matrix of left singular vectors, and P is an orthogonal matrix of */ +/* > right singular vectors. If left singular vectors are requested, this */ +/* > subroutine actually returns U*Q instead of Q, and, if right singular */ +/* > vectors are requested, this subroutine returns P**H*VT instead of */ +/* > P**H, for given complex input matrices U and VT. When U and VT are */ +/* > the unitary matrices that reduce a general matrix A to bidiagonal */ +/* > form: A = U*B*VT, as computed by ZGEBRD, then */ +/* > */ +/* > A = (U*Q) * S * (P**H*VT) */ +/* > */ +/* > is the SVD of A. Optionally, the subroutine may also compute Q**H*C */ +/* > for a given complex input matrix C. */ +/* > */ +/* > See "Computing Small Singular Values of Bidiagonal Matrices With */ +/* > Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, */ +/* > LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, */ +/* > no. 5, pp. 873-912, Sept 1990) and */ +/* > "Accurate singular values and differential qd algorithms," by */ +/* > B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics */ +/* > Department, University of California at Berkeley, July 1992 */ +/* > for a detailed description of the algorithm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': B is upper bidiagonal; */ +/* > = 'L': B is lower bidiagonal. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NCVT */ +/* > \verbatim */ +/* > NCVT is INTEGER */ +/* > The number of columns of the matrix VT. NCVT >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRU */ +/* > \verbatim */ +/* > NRU is INTEGER */ +/* > The number of rows of the matrix U. NRU >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NCC */ +/* > \verbatim */ +/* > NCC is INTEGER */ +/* > The number of columns of the matrix C. NCC >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, the n diagonal elements of the bidiagonal matrix B. */ +/* > On exit, if INFO=0, the singular values of B in decreasing */ +/* > order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > On entry, the N-1 offdiagonal elements of the bidiagonal */ +/* > matrix B. */ +/* > On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E */ +/* > will contain the diagonal and superdiagonal elements of a */ +/* > bidiagonal matrix orthogonally equivalent to the one given */ +/* > as input. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VT */ +/* > \verbatim */ +/* > VT is COMPLEX*16 array, dimension (LDVT, NCVT) */ +/* > On entry, an N-by-NCVT matrix VT. */ +/* > On exit, VT is overwritten by P**H * VT. */ +/* > Not referenced if NCVT = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVT */ +/* > \verbatim */ +/* > LDVT is INTEGER */ +/* > The leading dimension of the array VT. */ +/* > LDVT >= f2cmax(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] U */ +/* > \verbatim */ +/* > U is COMPLEX*16 array, dimension (LDU, N) */ +/* > On entry, an NRU-by-N matrix U. */ +/* > On exit, U is overwritten by U * Q. */ +/* > Not referenced if NRU = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > The leading dimension of the array U. LDU >= f2cmax(1,NRU). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX*16 array, dimension (LDC, NCC) */ +/* > On entry, an N-by-NCC matrix C. */ +/* > On exit, C is overwritten by Q**H * C. */ +/* > Not referenced if NCC = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. */ +/* > LDC >= f2cmax(1,N) if NCC > 0; LDC >=1 if NCC = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (4*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 did not converge; D and E contain the */ +/* > elements of a bidiagonal matrix which is orthogonally */ +/* > similar to the input matrix B; if INFO = i, i */ +/* > elements of E have not converged to zero. */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > TOLMUL DOUBLE PRECISION, default = f2cmax(10,f2cmin(100,EPS**(-1/8))) */ +/* > TOLMUL controls the convergence criterion of the QR loop. */ +/* > If it is positive, TOLMUL*EPS is the desired relative */ +/* > precision in the computed singular values. */ +/* > If it is negative, abs(TOLMUL*EPS*sigma_max) is the */ +/* > desired absolute accuracy in the computed singular */ +/* > values (corresponds to relative accuracy */ +/* > abs(TOLMUL*EPS) in the largest singular value. */ +/* > abs(TOLMUL) should be between 1 and 1/EPS, and preferably */ +/* > between 10 (for fast convergence) and .1/EPS */ +/* > (for there to be some accuracy in the results). */ +/* > Default is to lose at either one eighth or 2 of the */ +/* > available decimal digits in each computed singular value */ +/* > (whichever is smaller). */ +/* > */ +/* > MAXITR INTEGER, default = 6 */ +/* > MAXITR controls the maximum number of passes of the */ +/* > algorithm through its inner loop. The algorithms stops */ +/* > (and so fails to converge) if the number of passes */ +/* > through the inner loop exceeds MAXITR*N**2. */ +/* > \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 zbdsqr_(char *uplo, integer *n, integer *ncvt, integer * + nru, integer *ncc, doublereal *d__, doublereal *e, doublecomplex *vt, + integer *ldvt, doublecomplex *u, integer *ldu, doublecomplex *c__, + integer *ldc, doublereal *rwork, integer *info) +{ + /* System generated locals */ + integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, + i__2; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + doublereal abse; + integer idir; + doublereal abss; + integer oldm; + doublereal cosl; + integer isub, iter; + doublereal unfl, sinl, cosr, smin, smax, sinr; + extern /* Subroutine */ int dlas2_(doublereal *, doublereal *, doublereal + *, doublereal *, doublereal *); + doublereal f, g, h__; + integer i__, j, m; + doublereal r__; + extern logical lsame_(char *, char *); + doublereal oldcs; + integer oldll; + doublereal shift, sigmn, oldsn; + integer maxit; + doublereal sminl, sigmx; + logical lower; + extern /* Subroutine */ int zlasr_(char *, char *, char *, integer *, + integer *, doublereal *, doublereal *, doublecomplex *, integer *), zdrot_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *, doublereal *, doublereal *) + , zswap_(integer *, doublecomplex *, integer *, doublecomplex *, + integer *), dlasq1_(integer *, doublereal *, doublereal *, + doublereal *, integer *), dlasv2_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *); + doublereal cs; + integer ll; + extern doublereal dlamch_(char *); + doublereal sn, mu; + extern /* Subroutine */ int dlartg_(doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *), xerbla_(char *, + integer *, ftnlen), zdscal_(integer *, doublereal *, + doublecomplex *, integer *); + doublereal sminoa, thresh; + logical rotate; + integer nm1; + doublereal tolmul; + integer nm12, nm13, lll; + doublereal eps, sll, 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 */ + --d__; + --e; + vt_dim1 = *ldvt; + vt_offset = 1 + vt_dim1 * 1; + vt -= vt_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --rwork; + + /* Function Body */ + *info = 0; + lower = lsame_(uplo, "L"); + if (! lsame_(uplo, "U") && ! lower) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ncvt < 0) { + *info = -3; + } else if (*nru < 0) { + *info = -4; + } else if (*ncc < 0) { + *info = -5; + } else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < f2cmax(1,*n)) { + *info = -9; + } else if (*ldu < f2cmax(1,*nru)) { + *info = -11; + } else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < f2cmax(1,*n)) { + *info = -13; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZBDSQR", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + if (*n == 1) { + goto L160; + } + +/* ROTATE is true if any singular vectors desired, false otherwise */ + + rotate = *ncvt > 0 || *nru > 0 || *ncc > 0; + +/* If no singular vectors desired, use qd algorithm */ + + if (! rotate) { + dlasq1_(n, &d__[1], &e[1], &rwork[1], info); + +/* If INFO equals 2, dqds didn't finish, try to finish */ + + if (*info != 2) { + return 0; + } + *info = 0; + } + + nm1 = *n - 1; + nm12 = nm1 + nm1; + nm13 = nm12 + nm1; + idir = 0; + +/* Get machine constants */ + + eps = dlamch_("Epsilon"); + unfl = dlamch_("Safe minimum"); + +/* If matrix lower bidiagonal, rotate to be upper bidiagonal */ +/* by applying Givens rotations on the left */ + + if (lower) { + 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]; + rwork[i__] = cs; + rwork[nm1 + i__] = sn; +/* L10: */ + } + +/* Update singular vectors if desired */ + + if (*nru > 0) { + zlasr_("R", "V", "F", nru, n, &rwork[1], &rwork[*n], &u[u_offset], + ldu); + } + if (*ncc > 0) { + zlasr_("L", "V", "F", n, ncc, &rwork[1], &rwork[*n], &c__[ + c_offset], ldc); + } + } + +/* Compute singular values to relative accuracy TOL */ +/* (By setting TOL to be negative, algorithm will compute */ +/* singular values to absolute accuracy ABS(TOL)*norm(input matrix)) */ + +/* Computing MAX */ +/* Computing MIN */ + d__3 = 100., d__4 = pow_dd(&eps, &c_b15); + d__1 = 10., d__2 = f2cmin(d__3,d__4); + tolmul = f2cmax(d__1,d__2); + tol = tolmul * eps; + +/* Compute approximate maximum, minimum singular values */ + + smax = 0.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__2 = smax, d__3 = (d__1 = d__[i__], abs(d__1)); + smax = f2cmax(d__2,d__3); +/* L20: */ + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__2 = smax, d__3 = (d__1 = e[i__], abs(d__1)); + smax = f2cmax(d__2,d__3); +/* L30: */ + } + sminl = 0.; + if (tol >= 0.) { + +/* Relative accuracy desired */ + + sminoa = abs(d__[1]); + if (sminoa == 0.) { + goto L50; + } + mu = sminoa; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + mu = (d__2 = d__[i__], abs(d__2)) * (mu / (mu + (d__1 = e[i__ - 1] + , abs(d__1)))); + sminoa = f2cmin(sminoa,mu); + if (sminoa == 0.) { + goto L50; + } +/* L40: */ + } +L50: + sminoa /= sqrt((doublereal) (*n)); +/* Computing MAX */ + d__1 = tol * sminoa, d__2 = *n * 6 * *n * unfl; + thresh = f2cmax(d__1,d__2); + } else { + +/* Absolute accuracy desired */ + +/* Computing MAX */ + d__1 = abs(tol) * smax, d__2 = *n * 6 * *n * unfl; + thresh = f2cmax(d__1,d__2); + } + +/* Prepare for main iteration loop for the singular values */ +/* (MAXIT is the maximum number of passes through the inner */ +/* loop permitted before nonconvergence signalled.) */ + + maxit = *n * 6 * *n; + iter = 0; + oldll = -1; + oldm = -1; + +/* M points to last element of unconverged part of matrix */ + + m = *n; + +/* Begin main iteration loop */ + +L60: + +/* Check for convergence or exceeding iteration count */ + + if (m <= 1) { + goto L160; + } + if (iter > maxit) { + goto L200; + } + +/* Find diagonal block of matrix to work on */ + + if (tol < 0. && (d__1 = d__[m], abs(d__1)) <= thresh) { + d__[m] = 0.; + } + smax = (d__1 = d__[m], abs(d__1)); + smin = smax; + i__1 = m - 1; + for (lll = 1; lll <= i__1; ++lll) { + ll = m - lll; + abss = (d__1 = d__[ll], abs(d__1)); + abse = (d__1 = e[ll], abs(d__1)); + if (tol < 0. && abss <= thresh) { + d__[ll] = 0.; + } + if (abse <= thresh) { + goto L80; + } + smin = f2cmin(smin,abss); +/* Computing MAX */ + d__1 = f2cmax(smax,abss); + smax = f2cmax(d__1,abse); +/* L70: */ + } + ll = 0; + goto L90; +L80: + e[ll] = 0.; + +/* Matrix splits since E(LL) = 0 */ + + if (ll == m - 1) { + +/* Convergence of bottom singular value, return to top of loop */ + + --m; + goto L60; + } +L90: + ++ll; + +/* E(LL) through E(M-1) are nonzero, E(LL-1) is zero */ + + if (ll == m - 1) { + +/* 2 by 2 block, handle separately */ + + dlasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr, + &sinl, &cosl); + d__[m - 1] = sigmx; + e[m - 1] = 0.; + d__[m] = sigmn; + +/* Compute singular vectors, if desired */ + + if (*ncvt > 0) { + zdrot_(ncvt, &vt[m - 1 + vt_dim1], ldvt, &vt[m + vt_dim1], ldvt, & + cosr, &sinr); + } + if (*nru > 0) { + zdrot_(nru, &u[(m - 1) * u_dim1 + 1], &c__1, &u[m * u_dim1 + 1], & + c__1, &cosl, &sinl); + } + if (*ncc > 0) { + zdrot_(ncc, &c__[m - 1 + c_dim1], ldc, &c__[m + c_dim1], ldc, & + cosl, &sinl); + } + m += -2; + goto L60; + } + +/* If working on new submatrix, choose shift direction */ +/* (from larger end diagonal element towards smaller) */ + + if (ll > oldm || m < oldll) { + if ((d__1 = d__[ll], abs(d__1)) >= (d__2 = d__[m], abs(d__2))) { + +/* Chase bulge from top (big end) to bottom (small end) */ + + idir = 1; + } else { + +/* Chase bulge from bottom (big end) to top (small end) */ + + idir = 2; + } + } + +/* Apply convergence tests */ + + if (idir == 1) { + +/* Run convergence test in forward direction */ +/* First apply standard test to bottom of matrix */ + + if ((d__2 = e[m - 1], abs(d__2)) <= abs(tol) * (d__1 = d__[m], abs( + d__1)) || tol < 0. && (d__3 = e[m - 1], abs(d__3)) <= thresh) + { + e[m - 1] = 0.; + goto L60; + } + + if (tol >= 0.) { + +/* If relative accuracy desired, */ +/* apply convergence criterion forward */ + + mu = (d__1 = d__[ll], abs(d__1)); + sminl = mu; + i__1 = m - 1; + for (lll = ll; lll <= i__1; ++lll) { + if ((d__1 = e[lll], abs(d__1)) <= tol * mu) { + e[lll] = 0.; + goto L60; + } + mu = (d__2 = d__[lll + 1], abs(d__2)) * (mu / (mu + (d__1 = e[ + lll], abs(d__1)))); + sminl = f2cmin(sminl,mu); +/* L100: */ + } + } + + } else { + +/* Run convergence test in backward direction */ +/* First apply standard test to top of matrix */ + + if ((d__2 = e[ll], abs(d__2)) <= abs(tol) * (d__1 = d__[ll], abs(d__1) + ) || tol < 0. && (d__3 = e[ll], abs(d__3)) <= thresh) { + e[ll] = 0.; + goto L60; + } + + if (tol >= 0.) { + +/* If relative accuracy desired, */ +/* apply convergence criterion backward */ + + mu = (d__1 = d__[m], abs(d__1)); + sminl = mu; + i__1 = ll; + for (lll = m - 1; lll >= i__1; --lll) { + if ((d__1 = e[lll], abs(d__1)) <= tol * mu) { + e[lll] = 0.; + goto L60; + } + mu = (d__2 = d__[lll], abs(d__2)) * (mu / (mu + (d__1 = e[lll] + , abs(d__1)))); + sminl = f2cmin(sminl,mu); +/* L110: */ + } + } + } + oldll = ll; + oldm = m; + +/* Compute shift. First, test if shifting would ruin relative */ +/* accuracy, and if so set the shift to zero. */ + +/* Computing MAX */ + d__1 = eps, d__2 = tol * .01; + if (tol >= 0. && *n * tol * (sminl / smax) <= f2cmax(d__1,d__2)) { + +/* Use a zero shift to avoid loss of relative accuracy */ + + shift = 0.; + } else { + +/* Compute the shift from 2-by-2 block at end of matrix */ + + if (idir == 1) { + sll = (d__1 = d__[ll], abs(d__1)); + dlas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__); + } else { + sll = (d__1 = d__[m], abs(d__1)); + dlas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__); + } + +/* Test if shift negligible, and if so set to zero */ + + if (sll > 0.) { +/* Computing 2nd power */ + d__1 = shift / sll; + if (d__1 * d__1 < eps) { + shift = 0.; + } + } + } + +/* Increment iteration count */ + + iter = iter + m - ll; + +/* If SHIFT = 0, do simplified QR iteration */ + + if (shift == 0.) { + if (idir == 1) { + +/* Chase bulge from top to bottom */ +/* Save cosines and sines for later singular vector updates */ + + cs = 1.; + oldcs = 1.; + i__1 = m - 1; + for (i__ = ll; i__ <= i__1; ++i__) { + d__1 = d__[i__] * cs; + dlartg_(&d__1, &e[i__], &cs, &sn, &r__); + if (i__ > ll) { + e[i__ - 1] = oldsn * r__; + } + d__1 = oldcs * r__; + d__2 = d__[i__ + 1] * sn; + dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]); + rwork[i__ - ll + 1] = cs; + rwork[i__ - ll + 1 + nm1] = sn; + rwork[i__ - ll + 1 + nm12] = oldcs; + rwork[i__ - ll + 1 + nm13] = oldsn; +/* L120: */ + } + h__ = d__[m] * cs; + d__[m] = h__ * oldcs; + e[m - 1] = h__ * oldsn; + +/* Update singular vectors */ + + if (*ncvt > 0) { + i__1 = m - ll + 1; + zlasr_("L", "V", "F", &i__1, ncvt, &rwork[1], &rwork[*n], &vt[ + ll + vt_dim1], ldvt); + } + if (*nru > 0) { + i__1 = m - ll + 1; + zlasr_("R", "V", "F", nru, &i__1, &rwork[nm12 + 1], &rwork[ + nm13 + 1], &u[ll * u_dim1 + 1], ldu); + } + if (*ncc > 0) { + i__1 = m - ll + 1; + zlasr_("L", "V", "F", &i__1, ncc, &rwork[nm12 + 1], &rwork[ + nm13 + 1], &c__[ll + c_dim1], ldc); + } + +/* Test convergence */ + + if ((d__1 = e[m - 1], abs(d__1)) <= thresh) { + e[m - 1] = 0.; + } + + } else { + +/* Chase bulge from bottom to top */ +/* Save cosines and sines for later singular vector updates */ + + cs = 1.; + oldcs = 1.; + i__1 = ll + 1; + for (i__ = m; i__ >= i__1; --i__) { + d__1 = d__[i__] * cs; + dlartg_(&d__1, &e[i__ - 1], &cs, &sn, &r__); + if (i__ < m) { + e[i__] = oldsn * r__; + } + d__1 = oldcs * r__; + d__2 = d__[i__ - 1] * sn; + dlartg_(&d__1, &d__2, &oldcs, &oldsn, &d__[i__]); + rwork[i__ - ll] = cs; + rwork[i__ - ll + nm1] = -sn; + rwork[i__ - ll + nm12] = oldcs; + rwork[i__ - ll + nm13] = -oldsn; +/* L130: */ + } + h__ = d__[ll] * cs; + d__[ll] = h__ * oldcs; + e[ll] = h__ * oldsn; + +/* Update singular vectors */ + + if (*ncvt > 0) { + i__1 = m - ll + 1; + zlasr_("L", "V", "B", &i__1, ncvt, &rwork[nm12 + 1], &rwork[ + nm13 + 1], &vt[ll + vt_dim1], ldvt); + } + if (*nru > 0) { + i__1 = m - ll + 1; + zlasr_("R", "V", "B", nru, &i__1, &rwork[1], &rwork[*n], &u[ + ll * u_dim1 + 1], ldu); + } + if (*ncc > 0) { + i__1 = m - ll + 1; + zlasr_("L", "V", "B", &i__1, ncc, &rwork[1], &rwork[*n], &c__[ + ll + c_dim1], ldc); + } + +/* Test convergence */ + + if ((d__1 = e[ll], abs(d__1)) <= thresh) { + e[ll] = 0.; + } + } + } else { + +/* Use nonzero shift */ + + if (idir == 1) { + +/* Chase bulge from top to bottom */ +/* Save cosines and sines for later singular vector updates */ + + f = ((d__1 = d__[ll], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[ + ll]) + shift / d__[ll]); + g = e[ll]; + i__1 = m - 1; + for (i__ = ll; i__ <= i__1; ++i__) { + dlartg_(&f, &g, &cosr, &sinr, &r__); + if (i__ > ll) { + e[i__ - 1] = r__; + } + f = cosr * d__[i__] + sinr * e[i__]; + e[i__] = cosr * e[i__] - sinr * d__[i__]; + g = sinr * d__[i__ + 1]; + d__[i__ + 1] = cosr * d__[i__ + 1]; + dlartg_(&f, &g, &cosl, &sinl, &r__); + d__[i__] = r__; + f = cosl * e[i__] + sinl * d__[i__ + 1]; + d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__]; + if (i__ < m - 1) { + g = sinl * e[i__ + 1]; + e[i__ + 1] = cosl * e[i__ + 1]; + } + rwork[i__ - ll + 1] = cosr; + rwork[i__ - ll + 1 + nm1] = sinr; + rwork[i__ - ll + 1 + nm12] = cosl; + rwork[i__ - ll + 1 + nm13] = sinl; +/* L140: */ + } + e[m - 1] = f; + +/* Update singular vectors */ + + if (*ncvt > 0) { + i__1 = m - ll + 1; + zlasr_("L", "V", "F", &i__1, ncvt, &rwork[1], &rwork[*n], &vt[ + ll + vt_dim1], ldvt); + } + if (*nru > 0) { + i__1 = m - ll + 1; + zlasr_("R", "V", "F", nru, &i__1, &rwork[nm12 + 1], &rwork[ + nm13 + 1], &u[ll * u_dim1 + 1], ldu); + } + if (*ncc > 0) { + i__1 = m - ll + 1; + zlasr_("L", "V", "F", &i__1, ncc, &rwork[nm12 + 1], &rwork[ + nm13 + 1], &c__[ll + c_dim1], ldc); + } + +/* Test convergence */ + + if ((d__1 = e[m - 1], abs(d__1)) <= thresh) { + e[m - 1] = 0.; + } + + } else { + +/* Chase bulge from bottom to top */ +/* Save cosines and sines for later singular vector updates */ + + f = ((d__1 = d__[m], abs(d__1)) - shift) * (d_sign(&c_b49, &d__[m] + ) + shift / d__[m]); + g = e[m - 1]; + i__1 = ll + 1; + for (i__ = m; i__ >= i__1; --i__) { + dlartg_(&f, &g, &cosr, &sinr, &r__); + if (i__ < m) { + e[i__] = r__; + } + f = cosr * d__[i__] + sinr * e[i__ - 1]; + e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__]; + g = sinr * d__[i__ - 1]; + d__[i__ - 1] = cosr * d__[i__ - 1]; + dlartg_(&f, &g, &cosl, &sinl, &r__); + d__[i__] = r__; + f = cosl * e[i__ - 1] + sinl * d__[i__ - 1]; + d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1]; + if (i__ > ll + 1) { + g = sinl * e[i__ - 2]; + e[i__ - 2] = cosl * e[i__ - 2]; + } + rwork[i__ - ll] = cosr; + rwork[i__ - ll + nm1] = -sinr; + rwork[i__ - ll + nm12] = cosl; + rwork[i__ - ll + nm13] = -sinl; +/* L150: */ + } + e[ll] = f; + +/* Test convergence */ + + if ((d__1 = e[ll], abs(d__1)) <= thresh) { + e[ll] = 0.; + } + +/* Update singular vectors if desired */ + + if (*ncvt > 0) { + i__1 = m - ll + 1; + zlasr_("L", "V", "B", &i__1, ncvt, &rwork[nm12 + 1], &rwork[ + nm13 + 1], &vt[ll + vt_dim1], ldvt); + } + if (*nru > 0) { + i__1 = m - ll + 1; + zlasr_("R", "V", "B", nru, &i__1, &rwork[1], &rwork[*n], &u[ + ll * u_dim1 + 1], ldu); + } + if (*ncc > 0) { + i__1 = m - ll + 1; + zlasr_("L", "V", "B", &i__1, ncc, &rwork[1], &rwork[*n], &c__[ + ll + c_dim1], ldc); + } + } + } + +/* QR iteration finished, go back and check convergence */ + + goto L60; + +/* All singular values converged, so make them positive */ + +L160: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (d__[i__] < 0.) { + d__[i__] = -d__[i__]; + +/* Change sign of singular vectors, if desired */ + + if (*ncvt > 0) { + zdscal_(ncvt, &c_b72, &vt[i__ + vt_dim1], ldvt); + } + } +/* L170: */ + } + +/* Sort the singular values into decreasing order (insertion sort on */ +/* singular values, but only one transposition per singular vector) */ + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Scan for smallest D(I) */ + + isub = 1; + smin = d__[1]; + i__2 = *n + 1 - i__; + for (j = 2; j <= i__2; ++j) { + if (d__[j] <= smin) { + isub = j; + smin = d__[j]; + } +/* L180: */ + } + if (isub != *n + 1 - i__) { + +/* Swap singular values and vectors */ + + d__[isub] = d__[*n + 1 - i__]; + d__[*n + 1 - i__] = smin; + if (*ncvt > 0) { + zswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[*n + 1 - i__ + + vt_dim1], ldvt); + } + if (*nru > 0) { + zswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[(*n + 1 - i__) * + u_dim1 + 1], &c__1); + } + if (*ncc > 0) { + zswap_(ncc, &c__[isub + c_dim1], ldc, &c__[*n + 1 - i__ + + c_dim1], ldc); + } + } +/* L190: */ + } + goto L220; + +/* Maximum number of iterations exceeded, failure to converge */ + +L200: + *info = 0; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + if (e[i__] != 0.) { + ++(*info); + } +/* L210: */ + } +L220: + return 0; + +/* End of ZBDSQR */ + +} /* zbdsqr_ */ + diff --git a/lapack-netlib/SRC/zcgesv.c b/lapack-netlib/SRC/zcgesv.c new file mode 100644 index 000000000..c7eb11290 --- /dev/null +++ b/lapack-netlib/SRC/zcgesv.c @@ -0,0 +1,879 @@ +/* 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 ZCGESV computes the solution to system of linear equations A * X = B for GE matrices (mixe +d precision with iterative refinement) */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZCGESV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZCGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK, */ +/* SWORK, RWORK, ITER, INFO ) */ + +/* INTEGER INFO, ITER, LDA, LDB, LDX, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION RWORK( * ) */ +/* COMPLEX SWORK( * ) */ +/* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( N, * ), */ +/* $ X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZCGESV computes the solution to a complex system of linear equations */ +/* > A * X = B, */ +/* > where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */ +/* > */ +/* > ZCGESV first attempts to factorize the matrix in COMPLEX and use this */ +/* > factorization within an iterative refinement procedure to produce a */ +/* > solution with COMPLEX*16 normwise backward error quality (see below). */ +/* > If the approach fails the method switches to a COMPLEX*16 */ +/* > factorization and solve. */ +/* > */ +/* > The iterative refinement is not going to be a winning strategy if */ +/* > the ratio COMPLEX performance over COMPLEX*16 performance is too */ +/* > small. A reasonable strategy should take the number of right-hand */ +/* > sides and the size of the matrix into account. This might be done */ +/* > with a call to ILAENV in the future. Up to now, we always try */ +/* > iterative refinement. */ +/* > */ +/* > The iterative refinement process is stopped if */ +/* > ITER > ITERMAX */ +/* > or for all the RHS we have: */ +/* > RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX */ +/* > where */ +/* > o ITER is the number of the current iteration in the iterative */ +/* > refinement process */ +/* > o RNRM is the infinity-norm of the residual */ +/* > o XNRM is the infinity-norm of the solution */ +/* > o ANRM is the infinity-operator-norm of the matrix A */ +/* > o EPS is the machine epsilon returned by DLAMCH('Epsilon') */ +/* > The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 */ +/* > respectively. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, */ +/* > dimension (LDA,N) */ +/* > On entry, the N-by-N coefficient matrix A. */ +/* > On exit, if iterative refinement has been successfully used */ +/* > (INFO = 0 and ITER >= 0, see description below), then A is */ +/* > unchanged, if double precision factorization has been used */ +/* > (INFO = 0 and ITER < 0, see description below), then the */ +/* > array A contains the factors L and U from the factorization */ +/* > A = P*L*U; the unit diagonal elements of L are not stored. */ +/* > \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) */ +/* > The pivot indices that define the permutation matrix P; */ +/* > row i of the matrix was interchanged with row IPIV(i). */ +/* > Corresponds either to the single precision factorization */ +/* > (if INFO = 0 and ITER >= 0) or the double precision */ +/* > factorization (if INFO = 0 and ITER < 0). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > The N-by-NRHS right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (LDX,NRHS) */ +/* > If INFO = 0, the N-by-NRHS solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (N,NRHS) */ +/* > This array is used to hold the residual vectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SWORK */ +/* > \verbatim */ +/* > SWORK is COMPLEX array, dimension (N*(N+NRHS)) */ +/* > This array is used to use the single precision matrix and the */ +/* > right-hand sides or solutions in single precision. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ITER */ +/* > \verbatim */ +/* > ITER is INTEGER */ +/* > < 0: iterative refinement has failed, COMPLEX*16 */ +/* > factorization has been performed */ +/* > -1 : the routine fell back to full precision for */ +/* > implementation- or machine-specific reasons */ +/* > -2 : narrowing the precision induced an overflow, */ +/* > the routine fell back to full precision */ +/* > -3 : failure of CGETRF */ +/* > -31: stop the iterative refinement after the 30th */ +/* > iterations */ +/* > > 0: iterative refinement has been successfully used. */ +/* > Returns the number of iterations */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, U(i,i) computed in COMPLEX*16 is exactly */ +/* > zero. The factorization has been completed, but the */ +/* > factor U is exactly singular, so the solution */ +/* > could not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16GEsolve */ + +/* ===================================================================== */ +/* Subroutine */ int zcgesv_(integer *n, integer *nrhs, doublecomplex *a, + integer *lda, integer *ipiv, doublecomplex *b, integer *ldb, + doublecomplex *x, integer *ldx, doublecomplex *work, complex *swork, + doublereal *rwork, integer *iter, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, work_dim1, work_offset, + x_dim1, x_offset, i__1, i__2; + doublereal d__1, d__2; + + /* Local variables */ + doublereal anrm; + integer ptsa; + doublereal rnrm, xnrm; + integer ptsx, i__, iiter; + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *), zaxpy_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *), clag2z_( + integer *, integer *, complex *, integer *, doublecomplex *, + integer *, integer *), zlag2c_(integer *, integer *, + doublecomplex *, integer *, complex *, integer *, integer *); + extern doublereal dlamch_(char *); + extern /* Subroutine */ int cgetrf_(integer *, integer *, complex *, + integer *, integer *, integer *), xerbla_(char *, integer *, ftnlen); + extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, + integer *, doublereal *); + extern /* Subroutine */ int cgetrs_(char *, integer *, integer *, complex + *, integer *, integer *, complex *, integer *, integer *); + extern integer izamax_(integer *, doublecomplex *, integer *); + extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *), + zgetrf_(integer *, integer *, doublecomplex *, integer *, integer + *, integer *), zgetrs_(char *, integer *, integer *, + doublecomplex *, integer *, integer *, doublecomplex *, integer *, + integer *); + doublereal cte, eps; + + +/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + + + + + + /* Parameter adjustments */ + work_dim1 = *n; + work_offset = 1 + work_dim1 * 1; + work -= work_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --swork; + --rwork; + + /* Function Body */ + *info = 0; + *iter = 0; + +/* Test the input parameters. */ + + if (*n < 0) { + *info = -1; + } else if (*nrhs < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } else if (*ldx < f2cmax(1,*n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZCGESV", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if (N.EQ.0). */ + + if (*n == 0) { + return 0; + } + +/* Skip single precision iterative refinement if a priori slower */ +/* than double precision factorization. */ + + if (FALSE_) { + *iter = -1; + goto L40; + } + +/* Compute some constants. */ + + anrm = zlange_("I", n, n, &a[a_offset], lda, &rwork[1]); + eps = dlamch_("Epsilon"); + cte = anrm * eps * sqrt((doublereal) (*n)) * 1.; + +/* Set the indices PTSA, PTSX for referencing SA and SX in SWORK. */ + + ptsa = 1; + ptsx = ptsa + *n * *n; + +/* Convert B from double precision to single precision and store the */ +/* result in SX. */ + + zlag2c_(n, nrhs, &b[b_offset], ldb, &swork[ptsx], n, info); + + if (*info != 0) { + *iter = -2; + goto L40; + } + +/* Convert A from double precision to single precision and store the */ +/* result in SA. */ + + zlag2c_(n, n, &a[a_offset], lda, &swork[ptsa], n, info); + + if (*info != 0) { + *iter = -2; + goto L40; + } + +/* Compute the LU factorization of SA. */ + + cgetrf_(n, n, &swork[ptsa], n, &ipiv[1], info); + + if (*info != 0) { + *iter = -3; + goto L40; + } + +/* Solve the system SA*SX = SB. */ + + cgetrs_("No transpose", n, nrhs, &swork[ptsa], n, &ipiv[1], &swork[ptsx], + n, info); + +/* Convert SX back to double precision */ + + clag2z_(n, nrhs, &swork[ptsx], n, &x[x_offset], ldx, info); + +/* Compute R = B - AX (R is WORK). */ + + zlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n); + + zgemm_("No Transpose", "No Transpose", n, nrhs, n, &c_b1, &a[a_offset], + lda, &x[x_offset], ldx, &c_b2, &work[work_offset], n); + +/* Check whether the NRHS normwise backward errors satisfy the */ +/* stopping criterion. If yes, set ITER=0 and return. */ + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = izamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1; + xnrm = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[izamax_(n, & + x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1]), abs(d__2)); + i__2 = izamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ * + work_dim1; + rnrm = (d__1 = work[i__2].r, abs(d__1)) + (d__2 = d_imag(&work[ + izamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ * + work_dim1]), abs(d__2)); + if (rnrm > xnrm * cte) { + goto L10; + } + } + +/* If we are here, the NRHS normwise backward errors satisfy the */ +/* stopping criterion. We are good to exit. */ + + *iter = 0; + return 0; + +L10: + + for (iiter = 1; iiter <= 30; ++iiter) { + +/* Convert R (in WORK) from double precision to single precision */ +/* and store the result in SX. */ + + zlag2c_(n, nrhs, &work[work_offset], n, &swork[ptsx], n, info); + + if (*info != 0) { + *iter = -2; + goto L40; + } + +/* Solve the system SA*SX = SR. */ + + cgetrs_("No transpose", n, nrhs, &swork[ptsa], n, &ipiv[1], &swork[ + ptsx], n, info); + +/* Convert SX back to double precision and update the current */ +/* iterate. */ + + clag2z_(n, nrhs, &swork[ptsx], n, &work[work_offset], n, info); + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + zaxpy_(n, &c_b2, &work[i__ * work_dim1 + 1], &c__1, &x[i__ * + x_dim1 + 1], &c__1); + } + +/* Compute R = B - AX (R is WORK). */ + + zlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n); + + zgemm_("No Transpose", "No Transpose", n, nrhs, n, &c_b1, &a[a_offset] + , lda, &x[x_offset], ldx, &c_b2, &work[work_offset], n); + +/* Check whether the NRHS normwise backward errors satisfy the */ +/* stopping criterion. If yes, set ITER=IITER>0 and return. */ + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = izamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1; + xnrm = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[izamax_( + n, &x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1]), abs( + d__2)); + i__2 = izamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ * + work_dim1; + rnrm = (d__1 = work[i__2].r, abs(d__1)) + (d__2 = d_imag(&work[ + izamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ * + work_dim1]), abs(d__2)); + if (rnrm > xnrm * cte) { + goto L20; + } + } + +/* If we are here, the NRHS normwise backward errors satisfy the */ +/* stopping criterion, we are good to exit. */ + + *iter = iiter; + + return 0; + +L20: + +/* L30: */ + ; + } + +/* If we are at this place of the code, this is because we have */ +/* performed ITER=ITERMAX iterations and never satisfied the stopping */ +/* criterion, set up the ITER flag accordingly and follow up on double */ +/* precision routine. */ + + *iter = -31; + +L40: + +/* Single-precision iterative refinement failed to converge to a */ +/* satisfactory solution, so we resort to double precision. */ + + zgetrf_(n, n, &a[a_offset], lda, &ipiv[1], info); + + if (*info != 0) { + return 0; + } + + zlacpy_("All", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + zgetrs_("No transpose", n, nrhs, &a[a_offset], lda, &ipiv[1], &x[x_offset] + , ldx, info); + + return 0; + +/* End of ZCGESV. */ + +} /* zcgesv_ */ + diff --git a/lapack-netlib/SRC/zcposv.c b/lapack-netlib/SRC/zcposv.c new file mode 100644 index 000000000..0de182d56 --- /dev/null +++ b/lapack-netlib/SRC/zcposv.c @@ -0,0 +1,885 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#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 ZCPOSV computes the solution to system of linear equations A * X = B for PO matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZCPOSV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZCPOSV( UPLO, N, NRHS, A, LDA, B, LDB, X, LDX, WORK, */ +/* SWORK, RWORK, ITER, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, ITER, LDA, LDB, LDX, N, NRHS */ +/* DOUBLE PRECISION RWORK( * ) */ +/* COMPLEX SWORK( * ) */ +/* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( N, * ), */ +/* $ X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZCPOSV computes the solution to a complex system of linear equations */ +/* > A * X = B, */ +/* > where A is an N-by-N Hermitian positive definite matrix and X and B */ +/* > are N-by-NRHS matrices. */ +/* > */ +/* > ZCPOSV first attempts to factorize the matrix in COMPLEX and use this */ +/* > factorization within an iterative refinement procedure to produce a */ +/* > solution with COMPLEX*16 normwise backward error quality (see below). */ +/* > If the approach fails the method switches to a COMPLEX*16 */ +/* > factorization and solve. */ +/* > */ +/* > The iterative refinement is not going to be a winning strategy if */ +/* > the ratio COMPLEX performance over COMPLEX*16 performance is too */ +/* > small. A reasonable strategy should take the number of right-hand */ +/* > sides and the size of the matrix into account. This might be done */ +/* > with a call to ILAENV in the future. Up to now, we always try */ +/* > iterative refinement. */ +/* > */ +/* > The iterative refinement process is stopped if */ +/* > ITER > ITERMAX */ +/* > or for all the RHS we have: */ +/* > RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX */ +/* > where */ +/* > o ITER is the number of the current iteration in the iterative */ +/* > refinement process */ +/* > o RNRM is the infinity-norm of the residual */ +/* > o XNRM is the infinity-norm of the solution */ +/* > o ANRM is the infinity-operator-norm of the matrix A */ +/* > o EPS is the machine epsilon returned by DLAMCH('Epsilon') */ +/* > The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 */ +/* > respectively. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is 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. */ +/* > */ +/* > Note that the imaginary parts of the diagonal */ +/* > elements need not be set and are assumed to be zero. */ +/* > */ +/* > On exit, if iterative refinement has been successfully used */ +/* > (INFO = 0 and ITER >= 0, see description below), then A is */ +/* > unchanged, if double precision factorization has been used */ +/* > (INFO = 0 and ITER < 0, see description below), then the */ +/* > array A contains the factor U or L from the Cholesky */ +/* > factorization A = U**H*U or A = L*L**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > The N-by-NRHS right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (LDX,NRHS) */ +/* > If INFO = 0, the N-by-NRHS solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (N,NRHS) */ +/* > This array is used to hold the residual vectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SWORK */ +/* > \verbatim */ +/* > SWORK is COMPLEX array, dimension (N*(N+NRHS)) */ +/* > This array is used to use the single precision matrix and the */ +/* > right-hand sides or solutions in single precision. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ITER */ +/* > \verbatim */ +/* > ITER is INTEGER */ +/* > < 0: iterative refinement has failed, COMPLEX*16 */ +/* > factorization has been performed */ +/* > -1 : the routine fell back to full precision for */ +/* > implementation- or machine-specific reasons */ +/* > -2 : narrowing the precision induced an overflow, */ +/* > the routine fell back to full precision */ +/* > -3 : failure of CPOTRF */ +/* > -31: stop the iterative refinement after the 30th */ +/* > iterations */ +/* > > 0: iterative refinement has been successfully used. */ +/* > Returns the number of iterations */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the leading minor of order i of */ +/* > (COMPLEX*16) A is not positive definite, so the */ +/* > factorization could not be completed, and the solution */ +/* > has not been computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16POsolve */ + +/* ===================================================================== */ +/* Subroutine */ int zcposv_(char *uplo, integer *n, integer *nrhs, + doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, + doublecomplex *x, integer *ldx, doublecomplex *work, complex *swork, + doublereal *rwork, integer *iter, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, work_dim1, work_offset, + x_dim1, x_offset, i__1, i__2; + doublereal d__1, d__2; + + /* Local variables */ + doublereal anrm; + integer ptsa; + doublereal rnrm, xnrm; + integer ptsx, i__; + extern logical lsame_(char *, char *); + integer iiter; + extern /* Subroutine */ int zhemm_(char *, char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, integer *), zlag2c_(integer *, + integer *, doublecomplex *, integer *, complex *, integer *, + integer *), clag2z_(integer *, integer *, complex *, integer *, + doublecomplex *, integer *, integer *), zlat2c_(char *, integer *, + doublecomplex *, integer *, complex *, integer *, integer *); + extern doublereal dlamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *, + integer *, doublereal *); + extern integer izamax_(integer *, doublecomplex *, integer *); + extern /* Subroutine */ int cpotrf_(char *, integer *, complex *, integer + *, integer *), zlacpy_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *), + cpotrs_(char *, integer *, integer *, complex *, integer *, + complex *, integer *, integer *), zpotrf_(char *, integer + *, doublecomplex *, integer *, integer *), zpotrs_(char *, + integer *, integer *, doublecomplex *, integer *, doublecomplex * + , integer *, integer *); + doublereal cte, eps; + + +/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + + + + + + /* Parameter adjustments */ + work_dim1 = *n; + work_offset = 1 + work_dim1 * 1; + work -= work_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; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --swork; + --rwork; + + /* Function Body */ + *info = 0; + *iter = 0; + +/* Test the input parameters. */ + + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } else if (*ldx < f2cmax(1,*n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZCPOSV", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if (N.EQ.0). */ + + if (*n == 0) { + return 0; + } + +/* Skip single precision iterative refinement if a priori slower */ +/* than double precision factorization. */ + + if (FALSE_) { + *iter = -1; + goto L40; + } + +/* Compute some constants. */ + + anrm = zlanhe_("I", uplo, n, &a[a_offset], lda, &rwork[1]); + eps = dlamch_("Epsilon"); + cte = anrm * eps * sqrt((doublereal) (*n)) * 1.; + +/* Set the indices PTSA, PTSX for referencing SA and SX in SWORK. */ + + ptsa = 1; + ptsx = ptsa + *n * *n; + +/* Convert B from double precision to single precision and store the */ +/* result in SX. */ + + zlag2c_(n, nrhs, &b[b_offset], ldb, &swork[ptsx], n, info); + + if (*info != 0) { + *iter = -2; + goto L40; + } + +/* Convert A from double precision to single precision and store the */ +/* result in SA. */ + + zlat2c_(uplo, n, &a[a_offset], lda, &swork[ptsa], n, info); + + if (*info != 0) { + *iter = -2; + goto L40; + } + +/* Compute the Cholesky factorization of SA. */ + + cpotrf_(uplo, n, &swork[ptsa], n, info); + + if (*info != 0) { + *iter = -3; + goto L40; + } + +/* Solve the system SA*SX = SB. */ + + cpotrs_(uplo, n, nrhs, &swork[ptsa], n, &swork[ptsx], n, info); + +/* Convert SX back to COMPLEX*16 */ + + clag2z_(n, nrhs, &swork[ptsx], n, &x[x_offset], ldx, info); + +/* Compute R = B - AX (R is WORK). */ + + zlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n); + + zhemm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset], ldx, + &c_b2, &work[work_offset], n); + +/* Check whether the NRHS normwise backward errors satisfy the */ +/* stopping criterion. If yes, set ITER=0 and return. */ + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = izamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1; + xnrm = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[izamax_(n, & + x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1]), abs(d__2)); + i__2 = izamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ * + work_dim1; + rnrm = (d__1 = work[i__2].r, abs(d__1)) + (d__2 = d_imag(&work[ + izamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ * + work_dim1]), abs(d__2)); + if (rnrm > xnrm * cte) { + goto L10; + } + } + +/* If we are here, the NRHS normwise backward errors satisfy the */ +/* stopping criterion. We are good to exit. */ + + *iter = 0; + return 0; + +L10: + + for (iiter = 1; iiter <= 30; ++iiter) { + +/* Convert R (in WORK) from double precision to single precision */ +/* and store the result in SX. */ + + zlag2c_(n, nrhs, &work[work_offset], n, &swork[ptsx], n, info); + + if (*info != 0) { + *iter = -2; + goto L40; + } + +/* Solve the system SA*SX = SR. */ + + cpotrs_(uplo, n, nrhs, &swork[ptsa], n, &swork[ptsx], n, info); + +/* Convert SX back to double precision and update the current */ +/* iterate. */ + + clag2z_(n, nrhs, &swork[ptsx], n, &work[work_offset], n, info); + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + zaxpy_(n, &c_b2, &work[i__ * work_dim1 + 1], &c__1, &x[i__ * + x_dim1 + 1], &c__1); + } + +/* Compute R = B - AX (R is WORK). */ + + zlacpy_("All", n, nrhs, &b[b_offset], ldb, &work[work_offset], n); + + zhemm_("L", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset], + ldx, &c_b2, &work[work_offset], n); + +/* Check whether the NRHS normwise backward errors satisfy the */ +/* stopping criterion. If yes, set ITER=IITER>0 and return. */ + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = izamax_(n, &x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1; + xnrm = (d__1 = x[i__2].r, abs(d__1)) + (d__2 = d_imag(&x[izamax_( + n, &x[i__ * x_dim1 + 1], &c__1) + i__ * x_dim1]), abs( + d__2)); + i__2 = izamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ * + work_dim1; + rnrm = (d__1 = work[i__2].r, abs(d__1)) + (d__2 = d_imag(&work[ + izamax_(n, &work[i__ * work_dim1 + 1], &c__1) + i__ * + work_dim1]), abs(d__2)); + if (rnrm > xnrm * cte) { + goto L20; + } + } + +/* If we are here, the NRHS normwise backward errors satisfy the */ +/* stopping criterion, we are good to exit. */ + + *iter = iiter; + + return 0; + +L20: + +/* L30: */ + ; + } + +/* If we are at this place of the code, this is because we have */ +/* performed ITER=ITERMAX iterations and never satisfied the */ +/* stopping criterion, set up the ITER flag accordingly and follow */ +/* up on double precision routine. */ + + *iter = -31; + +L40: + +/* Single-precision iterative refinement failed to converge to a */ +/* satisfactory solution, so we resort to double precision. */ + + zpotrf_(uplo, n, &a[a_offset], lda, info); + + if (*info != 0) { + return 0; + } + + zlacpy_("All", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + zpotrs_(uplo, n, nrhs, &a[a_offset], lda, &x[x_offset], ldx, info); + + return 0; + +/* End of ZCPOSV. */ + +} /* zcposv_ */ + diff --git a/lapack-netlib/SRC/zdrscl.c b/lapack-netlib/SRC/zdrscl.c new file mode 100644 index 000000000..5330dca2e --- /dev/null +++ b/lapack-netlib/SRC/zdrscl.c @@ -0,0 +1,553 @@ +/* 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 ZDRSCL multiplies a vector by the reciprocal of a real scalar. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZDRSCL + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZDRSCL( N, SA, SX, INCX ) */ + +/* INTEGER INCX, N */ +/* DOUBLE PRECISION SA */ +/* COMPLEX*16 SX( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZDRSCL multiplies an n-element complex vector x by the real scalar */ +/* > 1/a. This is done without overflow or underflow as long as */ +/* > the final result x/a does not overflow or underflow. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of components of the vector x. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SA */ +/* > \verbatim */ +/* > SA is DOUBLE PRECISION */ +/* > The scalar a which is used to divide each component of x. */ +/* > SA must be >= 0, or the subroutine will divide by zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] SX */ +/* > \verbatim */ +/* > SX is COMPLEX*16 array, dimension */ +/* > (1+(N-1)*abs(INCX)) */ +/* > The n-element vector x. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The increment between successive values of the vector SX. */ +/* > > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= 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 zdrscl_(integer *n, doublereal *sa, doublecomplex *sx, + integer *incx) +{ + doublereal cden; + logical done; + doublereal cnum, cden1, cnum1; + extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); + extern doublereal dlamch_(char *); + extern /* Subroutine */ int zdscal_(integer *, doublereal *, + doublecomplex *, integer *); + doublereal bignum, smlnum, mul; + + +/* -- 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 */ + --sx; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + +/* Get machine parameters */ + + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + +/* Initialize the denominator to SA and the numerator to 1. */ + + cden = *sa; + cnum = 1.; + +L10: + cden1 = cden * smlnum; + cnum1 = cnum / bignum; + if (abs(cden1) > abs(cnum) && cnum != 0.) { + +/* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM. */ + + mul = smlnum; + done = FALSE_; + cden = cden1; + } else if (abs(cnum1) > abs(cden)) { + +/* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM. */ + + mul = bignum; + done = FALSE_; + cnum = cnum1; + } else { + +/* Multiply X by CNUM / CDEN and return. */ + + mul = cnum / cden; + done = TRUE_; + } + +/* Scale the vector X by MUL */ + + zdscal_(n, &mul, &sx[1], incx); + + if (! done) { + goto L10; + } + + return 0; + +/* End of ZDRSCL */ + +} /* zdrscl_ */ + diff --git a/lapack-netlib/SRC/zgbbrd.c b/lapack-netlib/SRC/zgbbrd.c new file mode 100644 index 000000000..af8c9d1d5 --- /dev/null +++ b/lapack-netlib/SRC/zgbbrd.c @@ -0,0 +1,1120 @@ +/* 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 ZGBBRD */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGBBRD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, */ +/* LDQ, PT, LDPT, C, LDC, WORK, RWORK, INFO ) */ + +/* CHARACTER VECT */ +/* INTEGER INFO, KL, KU, LDAB, LDC, LDPT, LDQ, M, N, NCC */ +/* DOUBLE PRECISION D( * ), E( * ), RWORK( * ) */ +/* COMPLEX*16 AB( LDAB, * ), C( LDC, * ), PT( LDPT, * ), */ +/* $ Q( LDQ, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGBBRD reduces a complex general m-by-n band matrix A to real upper */ +/* > bidiagonal form B by a unitary transformation: Q**H * A * P = B. */ +/* > */ +/* > The routine computes B, and optionally forms Q or P**H, or computes */ +/* > Q**H*C for a given matrix C. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] VECT */ +/* > \verbatim */ +/* > VECT is CHARACTER*1 */ +/* > Specifies whether or not the matrices Q and P**H are to be */ +/* > formed. */ +/* > = 'N': do not form Q or P**H; */ +/* > = 'Q': form Q only; */ +/* > = 'P': form P**H only; */ +/* > = 'B': form both. */ +/* > \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] NCC */ +/* > \verbatim */ +/* > NCC is INTEGER */ +/* > The number of columns of the matrix C. NCC >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of subdiagonals of the matrix A. KL >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of superdiagonals of the matrix A. KU >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is COMPLEX*16 array, dimension (LDAB,N) */ +/* > On entry, the m-by-n 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(m,j+kl). */ +/* > On exit, A is overwritten by values generated during the */ +/* > reduction. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array A. LDAB >= KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (f2cmin(M,N)) */ +/* > The diagonal elements of the bidiagonal matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (f2cmin(M,N)-1) */ +/* > The superdiagonal elements of the bidiagonal matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is COMPLEX*16 array, dimension (LDQ,M) */ +/* > If VECT = 'Q' or 'B', the m-by-m unitary matrix Q. */ +/* > If VECT = 'N' or 'P', the array Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. */ +/* > LDQ >= f2cmax(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PT */ +/* > \verbatim */ +/* > PT is COMPLEX*16 array, dimension (LDPT,N) */ +/* > If VECT = 'P' or 'B', the n-by-n unitary matrix P'. */ +/* > If VECT = 'N' or 'Q', the array PT is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDPT */ +/* > \verbatim */ +/* > LDPT is INTEGER */ +/* > The leading dimension of the array PT. */ +/* > LDPT >= f2cmax(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX*16 array, dimension (LDC,NCC) */ +/* > On entry, an m-by-ncc matrix C. */ +/* > On exit, C is overwritten by Q**H*C. */ +/* > C is not referenced if NCC = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. */ +/* > LDC >= f2cmax(1,M) if NCC > 0; LDC >= 1 if NCC = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (f2cmax(M,N)) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (f2cmax(M,N)) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GBcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zgbbrd_(char *vect, integer *m, integer *n, integer *ncc, + integer *kl, integer *ku, doublecomplex *ab, integer *ldab, + doublereal *d__, doublereal *e, doublecomplex *q, integer *ldq, + doublecomplex *pt, integer *ldpt, doublecomplex *c__, integer *ldc, + doublecomplex *work, doublereal *rwork, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, c_dim1, c_offset, pt_dim1, pt_offset, q_dim1, + q_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + integer inca; + doublereal abst; + extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublereal *, doublecomplex *); + integer i__, j, l; + doublecomplex t; + extern logical lsame_(char *, char *); + logical wantb, wantc; + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *); + integer minmn; + logical wantq; + integer j1, j2, kb; + doublecomplex ra, rb; + doublereal rc; + integer kk, ml, nr, mu; + doublecomplex rs; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + integer kb1; + extern /* Subroutine */ int zlaset_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *), zlartg_(doublecomplex *, doublecomplex *, doublereal *, + doublecomplex *, doublecomplex *), zlargv_(integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublereal *, integer *); + integer ml0; + logical wantpt; + integer mu0; + extern /* Subroutine */ int zlartv_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublereal *, doublecomplex *, + integer *); + integer klm, kun, nrt, klu1; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --d__; + --e; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + pt_dim1 = *ldpt; + pt_offset = 1 + pt_dim1 * 1; + pt -= pt_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + --rwork; + + /* Function Body */ + wantb = lsame_(vect, "B"); + wantq = lsame_(vect, "Q") || wantb; + wantpt = lsame_(vect, "P") || wantb; + wantc = *ncc > 0; + klu1 = *kl + *ku + 1; + *info = 0; + if (! wantq && ! wantpt && ! lsame_(vect, "N")) { + *info = -1; + } else if (*m < 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ncc < 0) { + *info = -4; + } else if (*kl < 0) { + *info = -5; + } else if (*ku < 0) { + *info = -6; + } else if (*ldab < klu1) { + *info = -8; + } else if (*ldq < 1 || wantq && *ldq < f2cmax(1,*m)) { + *info = -12; + } else if (*ldpt < 1 || wantpt && *ldpt < f2cmax(1,*n)) { + *info = -14; + } else if (*ldc < 1 || wantc && *ldc < f2cmax(1,*m)) { + *info = -16; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGBBRD", &i__1, (ftnlen)6); + return 0; + } + +/* Initialize Q and P**H to the unit matrix, if needed */ + + if (wantq) { + zlaset_("Full", m, m, &c_b1, &c_b2, &q[q_offset], ldq); + } + if (wantpt) { + zlaset_("Full", n, n, &c_b1, &c_b2, &pt[pt_offset], ldpt); + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0) { + return 0; + } + + minmn = f2cmin(*m,*n); + + if (*kl + *ku > 1) { + +/* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce */ +/* first to lower bidiagonal form and then transform to upper */ +/* bidiagonal */ + + if (*ku > 0) { + ml0 = 1; + mu0 = 2; + } else { + ml0 = 2; + mu0 = 1; + } + +/* Wherever possible, plane rotations are generated and applied in */ +/* vector operations of length NR over the index set J1:J2:KLU1. */ + +/* The complex sines of the plane rotations are stored in WORK, */ +/* and the real cosines in RWORK. */ + +/* Computing MIN */ + i__1 = *m - 1; + klm = f2cmin(i__1,*kl); +/* Computing MIN */ + i__1 = *n - 1; + kun = f2cmin(i__1,*ku); + kb = klm + kun; + kb1 = kb + 1; + inca = kb1 * *ldab; + nr = 0; + j1 = klm + 2; + j2 = 1 - kun; + + i__1 = minmn; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Reduce i-th column and i-th row of matrix to bidiagonal form */ + + ml = klm + 1; + mu = kun + 1; + i__2 = kb; + for (kk = 1; kk <= i__2; ++kk) { + j1 += kb; + j2 += kb; + +/* generate plane rotations to annihilate nonzero elements */ +/* which have been created below the band */ + + if (nr > 0) { + zlargv_(&nr, &ab[klu1 + (j1 - klm - 1) * ab_dim1], &inca, + &work[j1], &kb1, &rwork[j1], &kb1); + } + +/* apply plane rotations from the left */ + + i__3 = kb; + for (l = 1; l <= i__3; ++l) { + if (j2 - klm + l - 1 > *n) { + nrt = nr - 1; + } else { + nrt = nr; + } + if (nrt > 0) { + zlartv_(&nrt, &ab[klu1 - l + (j1 - klm + l - 1) * + ab_dim1], &inca, &ab[klu1 - l + 1 + (j1 - klm + + l - 1) * ab_dim1], &inca, &rwork[j1], &work[ + j1], &kb1); + } +/* L10: */ + } + + if (ml > ml0) { + if (ml <= *m - i__ + 1) { + +/* generate plane rotation to annihilate a(i+ml-1,i) */ +/* within the band, and apply rotation from the left */ + + zlartg_(&ab[*ku + ml - 1 + i__ * ab_dim1], &ab[*ku + + ml + i__ * ab_dim1], &rwork[i__ + ml - 1], & + work[i__ + ml - 1], &ra); + i__3 = *ku + ml - 1 + i__ * ab_dim1; + ab[i__3].r = ra.r, ab[i__3].i = ra.i; + if (i__ < *n) { +/* Computing MIN */ + i__4 = *ku + ml - 2, i__5 = *n - i__; + i__3 = f2cmin(i__4,i__5); + i__6 = *ldab - 1; + i__7 = *ldab - 1; + zrot_(&i__3, &ab[*ku + ml - 2 + (i__ + 1) * + ab_dim1], &i__6, &ab[*ku + ml - 1 + (i__ + + 1) * ab_dim1], &i__7, &rwork[i__ + ml - + 1], &work[i__ + ml - 1]); + } + } + ++nr; + j1 -= kb1; + } + + if (wantq) { + +/* accumulate product of plane rotations in Q */ + + i__3 = j2; + i__4 = kb1; + for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) + { + d_cnjg(&z__1, &work[j]); + zrot_(m, &q[(j - 1) * q_dim1 + 1], &c__1, &q[j * + q_dim1 + 1], &c__1, &rwork[j], &z__1); +/* L20: */ + } + } + + if (wantc) { + +/* apply plane rotations to C */ + + i__4 = j2; + i__3 = kb1; + for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) + { + zrot_(ncc, &c__[j - 1 + c_dim1], ldc, &c__[j + c_dim1] + , ldc, &rwork[j], &work[j]); +/* L30: */ + } + } + + if (j2 + kun > *n) { + +/* adjust J2 to keep within the bounds of the matrix */ + + --nr; + j2 -= kb1; + } + + i__3 = j2; + i__4 = kb1; + for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { + +/* create nonzero element a(j-1,j+ku) above the band */ +/* and store it in WORK(n+1:2*n) */ + + i__5 = j + kun; + i__6 = j; + i__7 = (j + kun) * ab_dim1 + 1; + z__1.r = work[i__6].r * ab[i__7].r - work[i__6].i * ab[ + i__7].i, z__1.i = work[i__6].r * ab[i__7].i + + work[i__6].i * ab[i__7].r; + work[i__5].r = z__1.r, work[i__5].i = z__1.i; + i__5 = (j + kun) * ab_dim1 + 1; + i__6 = j; + i__7 = (j + kun) * ab_dim1 + 1; + z__1.r = rwork[i__6] * ab[i__7].r, z__1.i = rwork[i__6] * + ab[i__7].i; + ab[i__5].r = z__1.r, ab[i__5].i = z__1.i; +/* L40: */ + } + +/* generate plane rotations to annihilate nonzero elements */ +/* which have been generated above the band */ + + if (nr > 0) { + zlargv_(&nr, &ab[(j1 + kun - 1) * ab_dim1 + 1], &inca, & + work[j1 + kun], &kb1, &rwork[j1 + kun], &kb1); + } + +/* apply plane rotations from the right */ + + i__4 = kb; + for (l = 1; l <= i__4; ++l) { + if (j2 + l - 1 > *m) { + nrt = nr - 1; + } else { + nrt = nr; + } + if (nrt > 0) { + zlartv_(&nrt, &ab[l + 1 + (j1 + kun - 1) * ab_dim1], & + inca, &ab[l + (j1 + kun) * ab_dim1], &inca, & + rwork[j1 + kun], &work[j1 + kun], &kb1); + } +/* L50: */ + } + + if (ml == ml0 && mu > mu0) { + if (mu <= *n - i__ + 1) { + +/* generate plane rotation to annihilate a(i,i+mu-1) */ +/* within the band, and apply rotation from the right */ + + zlartg_(&ab[*ku - mu + 3 + (i__ + mu - 2) * ab_dim1], + &ab[*ku - mu + 2 + (i__ + mu - 1) * ab_dim1], + &rwork[i__ + mu - 1], &work[i__ + mu - 1], & + ra); + i__4 = *ku - mu + 3 + (i__ + mu - 2) * ab_dim1; + ab[i__4].r = ra.r, ab[i__4].i = ra.i; +/* Computing MIN */ + i__3 = *kl + mu - 2, i__5 = *m - i__; + i__4 = f2cmin(i__3,i__5); + zrot_(&i__4, &ab[*ku - mu + 4 + (i__ + mu - 2) * + ab_dim1], &c__1, &ab[*ku - mu + 3 + (i__ + mu + - 1) * ab_dim1], &c__1, &rwork[i__ + mu - 1], + &work[i__ + mu - 1]); + } + ++nr; + j1 -= kb1; + } + + if (wantpt) { + +/* accumulate product of plane rotations in P**H */ + + i__4 = j2; + i__3 = kb1; + for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) + { + d_cnjg(&z__1, &work[j + kun]); + zrot_(n, &pt[j + kun - 1 + pt_dim1], ldpt, &pt[j + + kun + pt_dim1], ldpt, &rwork[j + kun], &z__1); +/* L60: */ + } + } + + if (j2 + kb > *m) { + +/* adjust J2 to keep within the bounds of the matrix */ + + --nr; + j2 -= kb1; + } + + i__3 = j2; + i__4 = kb1; + for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { + +/* create nonzero element a(j+kl+ku,j+ku-1) below the */ +/* band and store it in WORK(1:n) */ + + i__5 = j + kb; + i__6 = j + kun; + i__7 = klu1 + (j + kun) * ab_dim1; + z__1.r = work[i__6].r * ab[i__7].r - work[i__6].i * ab[ + i__7].i, z__1.i = work[i__6].r * ab[i__7].i + + work[i__6].i * ab[i__7].r; + work[i__5].r = z__1.r, work[i__5].i = z__1.i; + i__5 = klu1 + (j + kun) * ab_dim1; + i__6 = j + kun; + i__7 = klu1 + (j + kun) * ab_dim1; + z__1.r = rwork[i__6] * ab[i__7].r, z__1.i = rwork[i__6] * + ab[i__7].i; + ab[i__5].r = z__1.r, ab[i__5].i = z__1.i; +/* L70: */ + } + + if (ml > ml0) { + --ml; + } else { + --mu; + } +/* L80: */ + } +/* L90: */ + } + } + + if (*ku == 0 && *kl > 0) { + +/* A has been reduced to complex lower bidiagonal form */ + +/* Transform lower bidiagonal form to upper bidiagonal by applying */ +/* plane rotations from the left, overwriting superdiagonal */ +/* elements on subdiagonal elements */ + +/* Computing MIN */ + i__2 = *m - 1; + i__1 = f2cmin(i__2,*n); + for (i__ = 1; i__ <= i__1; ++i__) { + zlartg_(&ab[i__ * ab_dim1 + 1], &ab[i__ * ab_dim1 + 2], &rc, &rs, + &ra); + i__2 = i__ * ab_dim1 + 1; + ab[i__2].r = ra.r, ab[i__2].i = ra.i; + if (i__ < *n) { + i__2 = i__ * ab_dim1 + 2; + i__4 = (i__ + 1) * ab_dim1 + 1; + z__1.r = rs.r * ab[i__4].r - rs.i * ab[i__4].i, z__1.i = rs.r + * ab[i__4].i + rs.i * ab[i__4].r; + ab[i__2].r = z__1.r, ab[i__2].i = z__1.i; + i__2 = (i__ + 1) * ab_dim1 + 1; + i__4 = (i__ + 1) * ab_dim1 + 1; + z__1.r = rc * ab[i__4].r, z__1.i = rc * ab[i__4].i; + ab[i__2].r = z__1.r, ab[i__2].i = z__1.i; + } + if (wantq) { + d_cnjg(&z__1, &rs); + zrot_(m, &q[i__ * q_dim1 + 1], &c__1, &q[(i__ + 1) * q_dim1 + + 1], &c__1, &rc, &z__1); + } + if (wantc) { + zrot_(ncc, &c__[i__ + c_dim1], ldc, &c__[i__ + 1 + c_dim1], + ldc, &rc, &rs); + } +/* L100: */ + } + } else { + +/* A has been reduced to complex upper bidiagonal form or is */ +/* diagonal */ + + if (*ku > 0 && *m < *n) { + +/* Annihilate a(m,m+1) by applying plane rotations from the */ +/* right */ + + i__1 = *ku + (*m + 1) * ab_dim1; + rb.r = ab[i__1].r, rb.i = ab[i__1].i; + for (i__ = *m; i__ >= 1; --i__) { + zlartg_(&ab[*ku + 1 + i__ * ab_dim1], &rb, &rc, &rs, &ra); + i__1 = *ku + 1 + i__ * ab_dim1; + ab[i__1].r = ra.r, ab[i__1].i = ra.i; + if (i__ > 1) { + d_cnjg(&z__3, &rs); + z__2.r = -z__3.r, z__2.i = -z__3.i; + i__1 = *ku + i__ * ab_dim1; + z__1.r = z__2.r * ab[i__1].r - z__2.i * ab[i__1].i, + z__1.i = z__2.r * ab[i__1].i + z__2.i * ab[i__1] + .r; + rb.r = z__1.r, rb.i = z__1.i; + i__1 = *ku + i__ * ab_dim1; + i__2 = *ku + i__ * ab_dim1; + z__1.r = rc * ab[i__2].r, z__1.i = rc * ab[i__2].i; + ab[i__1].r = z__1.r, ab[i__1].i = z__1.i; + } + if (wantpt) { + d_cnjg(&z__1, &rs); + zrot_(n, &pt[i__ + pt_dim1], ldpt, &pt[*m + 1 + pt_dim1], + ldpt, &rc, &z__1); + } +/* L110: */ + } + } + } + +/* Make diagonal and superdiagonal elements real, storing them in D */ +/* and E */ + + i__1 = *ku + 1 + ab_dim1; + t.r = ab[i__1].r, t.i = ab[i__1].i; + i__1 = minmn; + for (i__ = 1; i__ <= i__1; ++i__) { + abst = z_abs(&t); + d__[i__] = abst; + if (abst != 0.) { + z__1.r = t.r / abst, z__1.i = t.i / abst; + t.r = z__1.r, t.i = z__1.i; + } else { + t.r = 1., t.i = 0.; + } + if (wantq) { + zscal_(m, &t, &q[i__ * q_dim1 + 1], &c__1); + } + if (wantc) { + d_cnjg(&z__1, &t); + zscal_(ncc, &z__1, &c__[i__ + c_dim1], ldc); + } + if (i__ < minmn) { + if (*ku == 0 && *kl == 0) { + e[i__] = 0.; + i__2 = (i__ + 1) * ab_dim1 + 1; + t.r = ab[i__2].r, t.i = ab[i__2].i; + } else { + if (*ku == 0) { + i__2 = i__ * ab_dim1 + 2; + d_cnjg(&z__2, &t); + z__1.r = ab[i__2].r * z__2.r - ab[i__2].i * z__2.i, + z__1.i = ab[i__2].r * z__2.i + ab[i__2].i * + z__2.r; + t.r = z__1.r, t.i = z__1.i; + } else { + i__2 = *ku + (i__ + 1) * ab_dim1; + d_cnjg(&z__2, &t); + z__1.r = ab[i__2].r * z__2.r - ab[i__2].i * z__2.i, + z__1.i = ab[i__2].r * z__2.i + ab[i__2].i * + z__2.r; + t.r = z__1.r, t.i = z__1.i; + } + abst = z_abs(&t); + e[i__] = abst; + if (abst != 0.) { + z__1.r = t.r / abst, z__1.i = t.i / abst; + t.r = z__1.r, t.i = z__1.i; + } else { + t.r = 1., t.i = 0.; + } + if (wantpt) { + zscal_(n, &t, &pt[i__ + 1 + pt_dim1], ldpt); + } + i__2 = *ku + 1 + (i__ + 1) * ab_dim1; + d_cnjg(&z__2, &t); + z__1.r = ab[i__2].r * z__2.r - ab[i__2].i * z__2.i, z__1.i = + ab[i__2].r * z__2.i + ab[i__2].i * z__2.r; + t.r = z__1.r, t.i = z__1.i; + } + } +/* L120: */ + } + return 0; + +/* End of ZGBBRD */ + +} /* zgbbrd_ */ + diff --git a/lapack-netlib/SRC/zgbcon.c b/lapack-netlib/SRC/zgbcon.c new file mode 100644 index 000000000..e63d5aed8 --- /dev/null +++ b/lapack-netlib/SRC/zgbcon.c @@ -0,0 +1,743 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#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 ZGBCON */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGBCON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, */ +/* WORK, RWORK, INFO ) */ + +/* CHARACTER NORM */ +/* INTEGER INFO, KL, KU, LDAB, N */ +/* DOUBLE PRECISION ANORM, RCOND */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION RWORK( * ) */ +/* COMPLEX*16 AB( LDAB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGBCON estimates the reciprocal of the condition number of a complex */ +/* > general band matrix A, in either the 1-norm or the infinity-norm, */ +/* > using the LU factorization computed by ZGBTRF. */ +/* > */ +/* > An estimate is obtained for norm(inv(A)), and the reciprocal of the */ +/* > condition number is computed as */ +/* > RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies whether the 1-norm condition number or the */ +/* > infinity-norm condition number is required: */ +/* > = '1' or 'O': 1-norm; */ +/* > = 'I': Infinity-norm. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order 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] AB */ +/* > \verbatim */ +/* > AB is COMPLEX*16 array, dimension (LDAB,N) */ +/* > Details of the LU factorization of the band matrix A, as */ +/* > computed by ZGBTRF. U is stored as an upper triangular band */ +/* > matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */ +/* > the multipliers used during the factorization are stored in */ +/* > rows KL+KU+2 to 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices; for 1 <= i <= N, row i of the matrix was */ +/* > interchanged with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ANORM */ +/* > \verbatim */ +/* > ANORM is DOUBLE PRECISION */ +/* > If NORM = '1' or 'O', the 1-norm of the original matrix A. */ +/* > If NORM = 'I', the infinity-norm of the original matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > The reciprocal of the condition number of the matrix A, */ +/* > computed as RCOND = 1/(norm(A) * norm(inv(A))). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GBcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zgbcon_(char *norm, integer *n, integer *kl, integer *ku, + doublecomplex *ab, integer *ldab, integer *ipiv, doublereal *anorm, + doublereal *rcond, doublecomplex *work, doublereal *rwork, integer * + info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3; + doublereal d__1, d__2; + doublecomplex z__1, z__2; + + /* Local variables */ + integer kase, kase1, j; + doublecomplex t; + doublereal scale; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + logical lnoti; + extern /* Subroutine */ int zaxpy_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *), zlacn2_( + integer *, doublecomplex *, doublecomplex *, doublereal *, + integer *, integer *); + integer kd; + extern doublereal dlamch_(char *); + integer lm, jp, ix; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal ainvnm; + extern integer izamax_(integer *, doublecomplex *, integer *); + logical onenrm; + extern /* Subroutine */ int zlatbs_(char *, char *, char *, char *, + integer *, integer *, doublecomplex *, integer *, doublecomplex *, + doublereal *, doublereal *, integer *), zdrscl_(integer *, doublereal *, doublecomplex *, + integer *); + char normin[1]; + doublereal smlnum; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --ipiv; + --work; + --rwork; + + /* Function Body */ + *info = 0; + onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); + if (! onenrm && ! lsame_(norm, "I")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0) { + *info = -3; + } else if (*ku < 0) { + *info = -4; + } else if (*ldab < (*kl << 1) + *ku + 1) { + *info = -6; + } else if (*anorm < 0.) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGBCON", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + *rcond = 0.; + if (*n == 0) { + *rcond = 1.; + return 0; + } else if (*anorm == 0.) { + return 0; + } + + smlnum = dlamch_("Safe minimum"); + +/* Estimate the norm of inv(A). */ + + ainvnm = 0.; + *(unsigned char *)normin = 'N'; + if (onenrm) { + kase1 = 1; + } else { + kase1 = 2; + } + kd = *kl + *ku + 1; + lnoti = *kl > 0; + kase = 0; +L10: + zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == kase1) { + +/* Multiply by inv(L). */ + + if (lnoti) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = *kl, i__3 = *n - j; + lm = f2cmin(i__2,i__3); + jp = ipiv[j]; + i__2 = jp; + t.r = work[i__2].r, t.i = work[i__2].i; + if (jp != j) { + i__2 = jp; + i__3 = j; + work[i__2].r = work[i__3].r, work[i__2].i = work[i__3] + .i; + i__2 = j; + work[i__2].r = t.r, work[i__2].i = t.i; + } + z__1.r = -t.r, z__1.i = -t.i; + zaxpy_(&lm, &z__1, &ab[kd + 1 + j * ab_dim1], &c__1, & + work[j + 1], &c__1); +/* L20: */ + } + } + +/* Multiply by inv(U). */ + + i__1 = *kl + *ku; + zlatbs_("Upper", "No transpose", "Non-unit", normin, n, &i__1, & + ab[ab_offset], ldab, &work[1], &scale, &rwork[1], info); + } else { + +/* Multiply by inv(U**H). */ + + i__1 = *kl + *ku; + zlatbs_("Upper", "Conjugate transpose", "Non-unit", normin, n, & + i__1, &ab[ab_offset], ldab, &work[1], &scale, &rwork[1], + info); + +/* Multiply by inv(L**H). */ + + if (lnoti) { + for (j = *n - 1; j >= 1; --j) { +/* Computing MIN */ + i__1 = *kl, i__2 = *n - j; + lm = f2cmin(i__1,i__2); + i__1 = j; + i__2 = j; + zdotc_(&z__2, &lm, &ab[kd + 1 + j * ab_dim1], &c__1, & + work[j + 1], &c__1); + z__1.r = work[i__2].r - z__2.r, z__1.i = work[i__2].i - + z__2.i; + work[i__1].r = z__1.r, work[i__1].i = z__1.i; + jp = ipiv[j]; + if (jp != j) { + i__1 = jp; + t.r = work[i__1].r, t.i = work[i__1].i; + i__1 = jp; + i__2 = j; + work[i__1].r = work[i__2].r, work[i__1].i = work[i__2] + .i; + i__1 = j; + work[i__1].r = t.r, work[i__1].i = t.i; + } +/* L30: */ + } + } + } + +/* Divide X by 1/SCALE if doing so will not cause overflow. */ + + *(unsigned char *)normin = 'Y'; + if (scale != 1.) { + ix = izamax_(n, &work[1], &c__1); + i__1 = ix; + if (scale < ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(& + work[ix]), abs(d__2))) * smlnum || scale == 0.) { + goto L40; + } + zdrscl_(n, &scale, &work[1], &c__1); + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + *rcond = 1. / ainvnm / *anorm; + } + +L40: + return 0; + +/* End of ZGBCON */ + +} /* zgbcon_ */ + diff --git a/lapack-netlib/SRC/zgbequ.c b/lapack-netlib/SRC/zgbequ.c new file mode 100644 index 000000000..89084f04c --- /dev/null +++ b/lapack-netlib/SRC/zgbequ.c @@ -0,0 +1,768 @@ +/* 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 ZGBEQU */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGBEQU + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, */ +/* AMAX, INFO ) */ + +/* INTEGER INFO, KL, KU, LDAB, M, N */ +/* DOUBLE PRECISION AMAX, COLCND, ROWCND */ +/* DOUBLE PRECISION C( * ), R( * ) */ +/* COMPLEX*16 AB( LDAB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGBEQU computes row and column scalings intended to equilibrate an */ +/* > M-by-N band matrix A and reduce its condition number. R returns the */ +/* > row scale factors and C the column scale factors, chosen to try to */ +/* > make the largest element in each row and column of the matrix B with */ +/* > elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. */ +/* > */ +/* > R(i) and C(j) are restricted to be between SMLNUM = smallest safe */ +/* > number and BIGNUM = largest safe number. Use of these scaling */ +/* > factors is not guaranteed to reduce the condition number of A but */ +/* > works well in practice. */ +/* > \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] 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(m,j+kl). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] R */ +/* > \verbatim */ +/* > R is DOUBLE PRECISION array, dimension (M) */ +/* > If INFO = 0, or INFO > M, R contains the row scale factors */ +/* > for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N) */ +/* > If INFO = 0, C contains the column scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ROWCND */ +/* > \verbatim */ +/* > ROWCND is DOUBLE PRECISION */ +/* > If INFO = 0 or INFO > M, ROWCND contains the ratio of the */ +/* > smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */ +/* > AMAX is neither too large nor too small, it is not worth */ +/* > scaling by R. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] COLCND */ +/* > \verbatim */ +/* > COLCND is DOUBLE PRECISION */ +/* > If INFO = 0, COLCND contains the ratio of the smallest */ +/* > C(i) to the largest C(i). If COLCND >= 0.1, it is not */ +/* > worth scaling by C. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] AMAX */ +/* > \verbatim */ +/* > AMAX is DOUBLE PRECISION */ +/* > Absolute value of largest matrix element. If AMAX is very */ +/* > close to overflow or very close to underflow, the matrix */ +/* > should be scaled. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, and i is */ +/* > <= M: the i-th row of A is exactly zero */ +/* > > M: the (i-M)-th column of A is exactly zero */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GBcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zgbequ_(integer *m, integer *n, integer *kl, integer *ku, + doublecomplex *ab, integer *ldab, doublereal *r__, doublereal *c__, + doublereal *rowcnd, doublereal *colcnd, doublereal *amax, integer * + info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + integer i__, j; + doublereal rcmin, rcmax; + integer kd; + extern doublereal dlamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum, smlnum; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --r__; + --c__; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0) { + *info = -3; + } else if (*ku < 0) { + *info = -4; + } else if (*ldab < *kl + *ku + 1) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGBEQU", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + *rowcnd = 1.; + *colcnd = 1.; + *amax = 0.; + return 0; + } + +/* Get machine constants. */ + + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + +/* Compute row scale factors. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + r__[i__] = 0.; +/* L10: */ + } + +/* Find the maximum element in each row. */ + + kd = *ku + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = j - *ku; +/* Computing MIN */ + i__4 = j + *kl; + i__3 = f2cmin(i__4,*m); + for (i__ = f2cmax(i__2,1); i__ <= i__3; ++i__) { +/* Computing MAX */ + i__2 = kd + i__ - j + j * ab_dim1; + d__3 = r__[i__], d__4 = (d__1 = ab[i__2].r, abs(d__1)) + (d__2 = + d_imag(&ab[kd + i__ - j + j * ab_dim1]), abs(d__2)); + r__[i__] = f2cmax(d__3,d__4); +/* L20: */ + } +/* L30: */ + } + +/* Find the maximum and minimum scale factors. */ + + rcmin = bignum; + rcmax = 0.; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__1 = rcmax, d__2 = r__[i__]; + rcmax = f2cmax(d__1,d__2); +/* Computing MIN */ + d__1 = rcmin, d__2 = r__[i__]; + rcmin = f2cmin(d__1,d__2); +/* L40: */ + } + *amax = rcmax; + + if (rcmin == 0.) { + +/* Find the first zero scale factor and return an error code. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (r__[i__] == 0.) { + *info = i__; + return 0; + } +/* L50: */ + } + } else { + +/* Invert the scale factors. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MIN */ +/* Computing MAX */ + d__2 = r__[i__]; + d__1 = f2cmax(d__2,smlnum); + r__[i__] = 1. / f2cmin(d__1,bignum); +/* L60: */ + } + +/* Compute ROWCND = f2cmin(R(I)) / f2cmax(R(I)) */ + + *rowcnd = f2cmax(rcmin,smlnum) / f2cmin(rcmax,bignum); + } + +/* Compute column scale factors */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + c__[j] = 0.; +/* L70: */ + } + +/* Find the maximum element in each column, */ +/* assuming the row scaling computed above. */ + + kd = *ku + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__3 = j - *ku; +/* Computing MIN */ + i__4 = j + *kl; + i__2 = f2cmin(i__4,*m); + for (i__ = f2cmax(i__3,1); i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = kd + i__ - j + j * ab_dim1; + d__3 = c__[j], d__4 = ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 = + d_imag(&ab[kd + i__ - j + j * ab_dim1]), abs(d__2))) * + r__[i__]; + c__[j] = f2cmax(d__3,d__4); +/* L80: */ + } +/* L90: */ + } + +/* Find the maximum and minimum scale factors. */ + + rcmin = bignum; + rcmax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = rcmin, d__2 = c__[j]; + rcmin = f2cmin(d__1,d__2); +/* Computing MAX */ + d__1 = rcmax, d__2 = c__[j]; + rcmax = f2cmax(d__1,d__2); +/* L100: */ + } + + if (rcmin == 0.) { + +/* Find the first zero scale factor and return an error code. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (c__[j] == 0.) { + *info = *m + j; + return 0; + } +/* L110: */ + } + } else { + +/* Invert the scale factors. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ +/* Computing MAX */ + d__2 = c__[j]; + d__1 = f2cmax(d__2,smlnum); + c__[j] = 1. / f2cmin(d__1,bignum); +/* L120: */ + } + +/* Compute COLCND = f2cmin(C(J)) / f2cmax(C(J)) */ + + *colcnd = f2cmax(rcmin,smlnum) / f2cmin(rcmax,bignum); + } + + return 0; + +/* End of ZGBEQU */ + +} /* zgbequ_ */ + diff --git a/lapack-netlib/SRC/zgbequb.c b/lapack-netlib/SRC/zgbequb.c new file mode 100644 index 000000000..a0e5391f3 --- /dev/null +++ b/lapack-netlib/SRC/zgbequb.c @@ -0,0 +1,787 @@ +/* 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 ZGBEQUB */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGBEQUB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, */ +/* AMAX, INFO ) */ + +/* INTEGER INFO, KL, KU, LDAB, M, N */ +/* DOUBLE PRECISION AMAX, COLCND, ROWCND */ +/* DOUBLE PRECISION C( * ), R( * ) */ +/* COMPLEX*16 AB( LDAB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGBEQUB computes row and column scalings intended to equilibrate an */ +/* > M-by-N matrix A and reduce its condition number. R returns the row */ +/* > scale factors and C the column scale factors, chosen to try to make */ +/* > the largest element in each row and column of the matrix B with */ +/* > elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most */ +/* > the radix. */ +/* > */ +/* > R(i) and C(j) are restricted to be a power of the radix between */ +/* > SMLNUM = smallest safe number and BIGNUM = largest safe number. Use */ +/* > of these scaling factors is not guaranteed to reduce the condition */ +/* > number of A but works well in practice. */ +/* > */ +/* > This routine differs from ZGEEQU by restricting the scaling factors */ +/* > to a power of the radix. Barring over- and underflow, scaling by */ +/* > these factors introduces no additional rounding errors. However, the */ +/* > scaled entries' magnitudes are no longer approximately 1 but lie */ +/* > between sqrt(radix) and 1/sqrt(radix). */ +/* > \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] 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(N,j+kl) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array A. LDAB >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] R */ +/* > \verbatim */ +/* > R is DOUBLE PRECISION array, dimension (M) */ +/* > If INFO = 0 or INFO > M, R contains the row scale factors */ +/* > for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N) */ +/* > If INFO = 0, C contains the column scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ROWCND */ +/* > \verbatim */ +/* > ROWCND is DOUBLE PRECISION */ +/* > If INFO = 0 or INFO > M, ROWCND contains the ratio of the */ +/* > smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */ +/* > AMAX is neither too large nor too small, it is not worth */ +/* > scaling by R. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] COLCND */ +/* > \verbatim */ +/* > COLCND is DOUBLE PRECISION */ +/* > If INFO = 0, COLCND contains the ratio of the smallest */ +/* > C(i) to the largest C(i). If COLCND >= 0.1, it is not */ +/* > worth scaling by C. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] AMAX */ +/* > \verbatim */ +/* > AMAX is DOUBLE PRECISION */ +/* > Absolute value of largest matrix element. If AMAX is very */ +/* > close to overflow or very close to underflow, the matrix */ +/* > should be scaled. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, and i is */ +/* > <= M: the i-th row of A is exactly zero */ +/* > > M: the (i-M)-th column of A is exactly zero */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16GBcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zgbequb_(integer *m, integer *n, integer *kl, integer * + ku, doublecomplex *ab, integer *ldab, doublereal *r__, doublereal * + c__, doublereal *rowcnd, doublereal *colcnd, doublereal *amax, + integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + integer i__, j; + doublereal radix, rcmin, rcmax; + integer kd; + extern doublereal dlamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum, logrdx, smlnum; + + +/* -- 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 */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --r__; + --c__; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0) { + *info = -3; + } else if (*ku < 0) { + *info = -4; + } else if (*ldab < *kl + *ku + 1) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGBEQUB", &i__1, (ftnlen)7); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0) { + *rowcnd = 1.; + *colcnd = 1.; + *amax = 0.; + return 0; + } + +/* Get machine constants. Assume SMLNUM is a power of the radix. */ + + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + radix = dlamch_("B"); + logrdx = log(radix); + +/* Compute row scale factors. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + r__[i__] = 0.; +/* L10: */ + } + +/* Find the maximum element in each row. */ + + kd = *ku + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = j - *ku; +/* Computing MIN */ + i__4 = j + *kl; + i__3 = f2cmin(i__4,*m); + for (i__ = f2cmax(i__2,1); i__ <= i__3; ++i__) { +/* Computing MAX */ + i__2 = kd + i__ - j + j * ab_dim1; + d__3 = r__[i__], d__4 = (d__1 = ab[i__2].r, abs(d__1)) + (d__2 = + d_imag(&ab[kd + i__ - j + j * ab_dim1]), abs(d__2)); + r__[i__] = f2cmax(d__3,d__4); +/* L20: */ + } +/* L30: */ + } + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (r__[i__] > 0.) { + i__3 = (integer) (log(r__[i__]) / logrdx); + r__[i__] = pow_di(&radix, &i__3); + } + } + +/* Find the maximum and minimum scale factors. */ + + rcmin = bignum; + rcmax = 0.; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__1 = rcmax, d__2 = r__[i__]; + rcmax = f2cmax(d__1,d__2); +/* Computing MIN */ + d__1 = rcmin, d__2 = r__[i__]; + rcmin = f2cmin(d__1,d__2); +/* L40: */ + } + *amax = rcmax; + + if (rcmin == 0.) { + +/* Find the first zero scale factor and return an error code. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (r__[i__] == 0.) { + *info = i__; + return 0; + } +/* L50: */ + } + } else { + +/* Invert the scale factors. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MIN */ +/* Computing MAX */ + d__2 = r__[i__]; + d__1 = f2cmax(d__2,smlnum); + r__[i__] = 1. / f2cmin(d__1,bignum); +/* L60: */ + } + +/* Compute ROWCND = f2cmin(R(I)) / f2cmax(R(I)). */ + + *rowcnd = f2cmax(rcmin,smlnum) / f2cmin(rcmax,bignum); + } + +/* Compute column scale factors. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + c__[j] = 0.; +/* L70: */ + } + +/* Find the maximum element in each column, */ +/* assuming the row scaling computed above. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__3 = j - *ku; +/* Computing MIN */ + i__4 = j + *kl; + i__2 = f2cmin(i__4,*m); + for (i__ = f2cmax(i__3,1); i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = kd + i__ - j + j * ab_dim1; + d__3 = c__[j], d__4 = ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 = + d_imag(&ab[kd + i__ - j + j * ab_dim1]), abs(d__2))) * + r__[i__]; + c__[j] = f2cmax(d__3,d__4); +/* L80: */ + } + if (c__[j] > 0.) { + i__2 = (integer) (log(c__[j]) / logrdx); + c__[j] = pow_di(&radix, &i__2); + } +/* L90: */ + } + +/* Find the maximum and minimum scale factors. */ + + rcmin = bignum; + rcmax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = rcmin, d__2 = c__[j]; + rcmin = f2cmin(d__1,d__2); +/* Computing MAX */ + d__1 = rcmax, d__2 = c__[j]; + rcmax = f2cmax(d__1,d__2); +/* L100: */ + } + + if (rcmin == 0.) { + +/* Find the first zero scale factor and return an error code. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (c__[j] == 0.) { + *info = *m + j; + return 0; + } +/* L110: */ + } + } else { + +/* Invert the scale factors. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ +/* Computing MAX */ + d__2 = c__[j]; + d__1 = f2cmax(d__2,smlnum); + c__[j] = 1. / f2cmin(d__1,bignum); +/* L120: */ + } + +/* Compute COLCND = f2cmin(C(J)) / f2cmax(C(J)). */ + + *colcnd = f2cmax(rcmin,smlnum) / f2cmin(rcmax,bignum); + } + + return 0; + +/* End of ZGBEQUB */ + +} /* zgbequb_ */ + diff --git a/lapack-netlib/SRC/zgbrfs.c b/lapack-netlib/SRC/zgbrfs.c new file mode 100644 index 000000000..d28d89f84 --- /dev/null +++ b/lapack-netlib/SRC/zgbrfs.c @@ -0,0 +1,953 @@ +/* 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 ZGBRFS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGBRFS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, */ +/* IPIV, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, */ +/* INFO ) */ + +/* CHARACTER TRANS */ +/* INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * ) */ +/* COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), */ +/* $ WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGBRFS improves the computed solution to a system of linear */ +/* > equations when the coefficient matrix is banded, and provides */ +/* > error bounds and backward error estimates for the solution. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order 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] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is COMPLEX*16 array, dimension (LDAB,N) */ +/* > The original 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[in] AFB */ +/* > \verbatim */ +/* > AFB is COMPLEX*16 array, dimension (LDAFB,N) */ +/* > Details of the LU factorization of the band matrix A, as */ +/* > computed by ZGBTRF. U is stored as an upper triangular band */ +/* > matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */ +/* > the multipliers used during the factorization are stored in */ +/* > rows KL+KU+2 to 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAFB */ +/* > \verbatim */ +/* > LDAFB is INTEGER */ +/* > The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices from ZGBTRF; for 1<=i<=N, row i of the */ +/* > matrix was interchanged with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > The right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (LDX,NRHS) */ +/* > On entry, the solution matrix X, as computed by ZGBTRS. */ +/* > On exit, the improved solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > ITMAX is the maximum number of steps of iterative refinement. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GBcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zgbrfs_(char *trans, integer *n, integer *kl, integer * + ku, integer *nrhs, doublecomplex *ab, integer *ldab, doublecomplex * + afb, integer *ldafb, integer *ipiv, doublecomplex *b, integer *ldb, + doublecomplex *x, integer *ldx, doublereal *ferr, doublereal *berr, + doublecomplex *work, doublereal *rwork, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, + x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; + doublereal d__1, d__2, d__3, d__4; + doublecomplex z__1; + + /* Local variables */ + integer kase; + doublereal safe1, safe2; + integer i__, j, k; + doublereal s; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int zgbmv_(char *, integer *, integer *, integer * + , integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + integer count; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *), zlacn2_( + integer *, doublecomplex *, doublecomplex *, doublereal *, + integer *, integer *); + integer kk; + extern doublereal dlamch_(char *); + doublereal xk; + integer nz; + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical notran; + char transn[1], transt[1]; + doublereal lstres; + extern /* Subroutine */ int zgbtrs_(char *, integer *, integer *, integer + *, integer *, doublecomplex *, integer *, integer *, + doublecomplex *, integer *, integer *); + doublereal eps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + afb_dim1 = *ldafb; + afb_offset = 1 + afb_dim1 * 1; + afb -= afb_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --rwork; + + /* Function Body */ + *info = 0; + notran = lsame_(trans, "N"); + if (! notran && ! lsame_(trans, "T") && ! lsame_( + trans, "C")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0) { + *info = -3; + } else if (*ku < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*ldab < *kl + *ku + 1) { + *info = -7; + } else if (*ldafb < (*kl << 1) + *ku + 1) { + *info = -9; + } else if (*ldb < f2cmax(1,*n)) { + *info = -12; + } else if (*ldx < f2cmax(1,*n)) { + *info = -14; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGBRFS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.; + berr[j] = 0.; +/* L10: */ + } + return 0; + } + + if (notran) { + *(unsigned char *)transn = 'N'; + *(unsigned char *)transt = 'C'; + } else { + *(unsigned char *)transn = 'C'; + *(unsigned char *)transt = 'N'; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + +/* Computing MIN */ + i__1 = *kl + *ku + 2, i__2 = *n + 1; + nz = f2cmin(i__1,i__2); + eps = dlamch_("Epsilon"); + safmin = dlamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + + count = 1; + lstres = 3.; +L20: + +/* Loop until stopping criterion is satisfied. */ + +/* Compute residual R = B - op(A) * X, */ +/* where op(A) = A, A**T, or A**H, depending on TRANS. */ + + zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1); + z__1.r = -1., z__1.i = 0.; + zgbmv_(trans, n, n, kl, ku, &z__1, &ab[ab_offset], ldab, &x[j * + x_dim1 + 1], &c__1, &c_b1, &work[1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* f2cmax(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[ + i__ + j * b_dim1]), abs(d__2)); +/* L30: */ + } + +/* Compute abs(op(A))*abs(X) + abs(B). */ + + if (notran) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + kk = *ku + 1 - k; + i__3 = k + j * x_dim1; + xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j * + x_dim1]), abs(d__2)); +/* Computing MAX */ + i__3 = 1, i__4 = k - *ku; +/* Computing MIN */ + i__6 = *n, i__7 = k + *kl; + i__5 = f2cmin(i__6,i__7); + for (i__ = f2cmax(i__3,i__4); i__ <= i__5; ++i__) { + i__3 = kk + i__ + k * ab_dim1; + rwork[i__] += ((d__1 = ab[i__3].r, abs(d__1)) + (d__2 = + d_imag(&ab[kk + i__ + k * ab_dim1]), abs(d__2))) * + xk; +/* L40: */ + } +/* L50: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + kk = *ku + 1 - k; +/* Computing MAX */ + i__5 = 1, i__3 = k - *ku; +/* Computing MIN */ + i__6 = *n, i__7 = k + *kl; + i__4 = f2cmin(i__6,i__7); + for (i__ = f2cmax(i__5,i__3); i__ <= i__4; ++i__) { + i__5 = kk + i__ + k * ab_dim1; + i__3 = i__ + j * x_dim1; + s += ((d__1 = ab[i__5].r, abs(d__1)) + (d__2 = d_imag(&ab[ + kk + i__ + k * ab_dim1]), abs(d__2))) * ((d__3 = + x[i__3].r, abs(d__3)) + (d__4 = d_imag(&x[i__ + j + * x_dim1]), abs(d__4))); +/* L60: */ + } + rwork[k] += s; +/* L70: */ + } + } + s = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (rwork[i__] > safe2) { +/* Computing MAX */ + i__4 = i__; + d__3 = s, d__4 = ((d__1 = work[i__4].r, abs(d__1)) + (d__2 = + d_imag(&work[i__]), abs(d__2))) / rwork[i__]; + s = f2cmax(d__3,d__4); + } else { +/* Computing MAX */ + i__4 = i__; + d__3 = s, d__4 = ((d__1 = work[i__4].r, abs(d__1)) + (d__2 = + d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__] + + safe1); + s = f2cmax(d__3,d__4); + } +/* L80: */ + } + berr[j] = s; + +/* Test stopping criterion. Continue iterating if */ +/* 1) The residual BERR(J) is larger than machine epsilon, and */ +/* 2) BERR(J) decreased by at least a factor of 2 during the */ +/* last iteration, and */ +/* 3) At most ITMAX iterations tried. */ + + if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { + +/* Update solution and try again. */ + + zgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1] + , &work[1], n, info); + zaxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1); + lstres = berr[j]; + ++count; + goto L20; + } + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(op(A)))* */ +/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(op(A)) is the inverse of op(A) */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ + +/* Use ZLACN2 to estimate the infinity-norm of the matrix */ +/* inv(op(A)) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (rwork[i__] > safe2) { + i__4 = i__; + rwork[i__] = (d__1 = work[i__4].r, abs(d__1)) + (d__2 = + d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__] + ; + } else { + i__4 = i__; + rwork[i__] = (d__1 = work[i__4].r, abs(d__1)) + (d__2 = + d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__] + + safe1; + } +/* L90: */ + } + + kase = 0; +L100: + zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(op(A)**H). */ + + zgbtrs_(transt, n, kl, ku, &c__1, &afb[afb_offset], ldafb, & + ipiv[1], &work[1], n, info); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__4 = i__; + i__5 = i__; + i__3 = i__; + z__1.r = rwork[i__5] * work[i__3].r, z__1.i = rwork[i__5] + * work[i__3].i; + work[i__4].r = z__1.r, work[i__4].i = z__1.i; +/* L110: */ + } + } else { + +/* Multiply by inv(op(A))*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__4 = i__; + i__5 = i__; + i__3 = i__; + z__1.r = rwork[i__5] * work[i__3].r, z__1.i = rwork[i__5] + * work[i__3].i; + work[i__4].r = z__1.r, work[i__4].i = z__1.i; +/* L120: */ + } + zgbtrs_(transn, n, kl, ku, &c__1, &afb[afb_offset], ldafb, & + ipiv[1], &work[1], n, info); + } + goto L100; + } + +/* Normalize error. */ + + lstres = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__4 = i__ + j * x_dim1; + d__3 = lstres, d__4 = (d__1 = x[i__4].r, abs(d__1)) + (d__2 = + d_imag(&x[i__ + j * x_dim1]), abs(d__2)); + lstres = f2cmax(d__3,d__4); +/* L130: */ + } + if (lstres != 0.) { + ferr[j] /= lstres; + } + +/* L140: */ + } + + return 0; + +/* End of ZGBRFS */ + +} /* zgbrfs_ */ + diff --git a/lapack-netlib/SRC/zgbrfsx.c b/lapack-netlib/SRC/zgbrfsx.c new file mode 100644 index 000000000..e8dddda2b --- /dev/null +++ b/lapack-netlib/SRC/zgbrfsx.c @@ -0,0 +1,381 @@ +/* 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 +#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 ZGBSV computes the solution to system of linear equations A * X = B for GB matrices (simpl +e driver) */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGBSV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) */ + +/* INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 AB( LDAB, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGBSV computes the solution to a complex system of linear equations */ +/* > A * X = B, where A is a band matrix of order N with KL subdiagonals */ +/* > and KU superdiagonals, and X and B are N-by-NRHS matrices. */ +/* > */ +/* > The LU decomposition with partial pivoting and row interchanges is */ +/* > used to factor A as A = L * U, where L is a product of permutation */ +/* > and unit lower triangular matrices with KL subdiagonals, and U is */ +/* > upper triangular with KL+KU superdiagonals. The factored form of A */ +/* > is then used to solve the system of equations A * X = B. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] 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] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is COMPLEX*16 array, dimension (LDAB,N) */ +/* > On entry, the matrix A in band storage, in rows KL+1 to */ +/* > 2*KL+KU+1; rows 1 to KL of the array need not be set. */ +/* > The j-th column of A is stored in the j-th column of the */ +/* > array AB as follows: */ +/* > AB(KL+KU+1+i-j,j) = A(i,j) for f2cmax(1,j-KU)<=i<=f2cmin(N,j+KL) */ +/* > On exit, details of the factorization: U is stored as an */ +/* > upper triangular band matrix with KL+KU superdiagonals in */ +/* > rows 1 to KL+KU+1, and the multipliers used during the */ +/* > factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */ +/* > See below for further details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices that define the permutation matrix P; */ +/* > row i of the matrix was interchanged with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > On entry, the N-by-NRHS right hand side matrix B. */ +/* > On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, U(i,i) is exactly zero. The factorization */ +/* > has been completed, but the factor U is exactly */ +/* > singular, and the solution has not been computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GBsolve */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The band storage scheme is illustrated by the following example, when */ +/* > M = N = 6, KL = 2, KU = 1: */ +/* > */ +/* > On entry: On exit: */ +/* > */ +/* > * * * + + + * * * u14 u25 u36 */ +/* > * * + + + + * * u13 u24 u35 u46 */ +/* > * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */ +/* > a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */ +/* > a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */ +/* > a31 a42 a53 a64 * * m31 m42 m53 m64 * * */ +/* > */ +/* > Array elements marked * are not used by the routine; elements marked */ +/* > + need not be set on entry, but are required by the routine to store */ +/* > elements of U because of fill-in resulting from the row interchanges. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgbsv_(integer *n, integer *kl, integer *ku, integer * + nrhs, doublecomplex *ab, integer *ldab, integer *ipiv, doublecomplex * + b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zgbtrf_( + integer *, integer *, integer *, integer *, doublecomplex *, + integer *, integer *, integer *), zgbtrs_(char *, integer *, + integer *, integer *, integer *, doublecomplex *, integer *, + integer *, doublecomplex *, integer *, integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*kl < 0) { + *info = -2; + } else if (*ku < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*ldab < (*kl << 1) + *ku + 1) { + *info = -6; + } else if (*ldb < f2cmax(*n,1)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGBSV ", &i__1, (ftnlen)6); + return 0; + } + +/* Compute the LU factorization of the band matrix A. */ + + zgbtrf_(n, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + zgbtrs_("No transpose", n, kl, ku, nrhs, &ab[ab_offset], ldab, &ipiv[ + 1], &b[b_offset], ldb, info); + } + return 0; + +/* End of ZGBSV */ + +} /* zgbsv_ */ + diff --git a/lapack-netlib/SRC/zgbsvx.c b/lapack-netlib/SRC/zgbsvx.c new file mode 100644 index 000000000..41dc112ca --- /dev/null +++ b/lapack-netlib/SRC/zgbsvx.c @@ -0,0 +1,1164 @@ +/* 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 ZGBSVX computes the solution to system of linear equations A * X = B for GB matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGBSVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, */ +/* LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, */ +/* RCOND, FERR, BERR, WORK, RWORK, INFO ) */ + +/* CHARACTER EQUED, FACT, TRANS */ +/* INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS */ +/* DOUBLE PRECISION RCOND */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION BERR( * ), C( * ), FERR( * ), R( * ), */ +/* $ RWORK( * ) */ +/* COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), */ +/* $ WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGBSVX uses the LU factorization to compute the solution to a complex */ +/* > system of linear equations A * X = B, A**T * X = B, or A**H * X = B, */ +/* > where A is a band matrix of order N with KL subdiagonals and KU */ +/* > superdiagonals, and X and B are N-by-NRHS matrices. */ +/* > */ +/* > Error bounds on the solution and a condition estimate are also */ +/* > provided. */ +/* > \endverbatim */ + +/* > \par Description: */ +/* ================= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The following steps are performed by this subroutine: */ +/* > */ +/* > 1. If FACT = 'E', real scaling factors are computed to equilibrate */ +/* > the system: */ +/* > TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */ +/* > TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */ +/* > TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */ +/* > Whether or not the system will be equilibrated depends on the */ +/* > scaling of the matrix A, but if equilibration is used, A is */ +/* > overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */ +/* > or diag(C)*B (if TRANS = 'T' or 'C'). */ +/* > */ +/* > 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the */ +/* > matrix A (after equilibration if FACT = 'E') as */ +/* > A = L * U, */ +/* > where L is a product of permutation and unit lower triangular */ +/* > matrices with KL subdiagonals, and U is upper triangular with */ +/* > KL+KU superdiagonals. */ +/* > */ +/* > 3. If some U(i,i)=0, so that U is exactly singular, then the routine */ +/* > returns with INFO = i. Otherwise, the factored form of A is used */ +/* > to estimate the condition number of the matrix A. If the */ +/* > reciprocal of the condition number is less than machine precision, */ +/* > INFO = N+1 is returned as a warning, but the routine still goes on */ +/* > to solve for X and compute error bounds as described below. */ +/* > */ +/* > 4. The system of equations is solved for X using the factored form */ +/* > of A. */ +/* > */ +/* > 5. Iterative refinement is applied to improve the computed solution */ +/* > matrix and calculate error bounds and backward error estimates */ +/* > for it. */ +/* > */ +/* > 6. If equilibration was used, the matrix X is premultiplied by */ +/* > diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */ +/* > that it solves the original system before equilibration. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] FACT */ +/* > \verbatim */ +/* > FACT is CHARACTER*1 */ +/* > Specifies whether or not the factored form of the matrix A is */ +/* > supplied on entry, and if not, whether the matrix A should be */ +/* > equilibrated before it is factored. */ +/* > = 'F': On entry, AFB and IPIV contain the factored form of */ +/* > A. If EQUED is not 'N', the matrix A has been */ +/* > equilibrated with scaling factors given by R and C. */ +/* > AB, AFB, and IPIV are not modified. */ +/* > = 'N': The matrix A will be copied to AFB and factored. */ +/* > = 'E': The matrix A will be equilibrated if necessary, then */ +/* > copied to AFB and factored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations. */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] 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] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,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(N,j+kl) */ +/* > */ +/* > If FACT = 'F' and EQUED is not 'N', then A must have been */ +/* > equilibrated by the scaling factors in R and/or C. AB is not */ +/* > modified if FACT = 'F' or 'N', or if FACT = 'E' and */ +/* > EQUED = 'N' on exit. */ +/* > */ +/* > On exit, if EQUED .ne. 'N', A is scaled as follows: */ +/* > EQUED = 'R': A := diag(R) * A */ +/* > EQUED = 'C': A := A * diag(C) */ +/* > EQUED = 'B': A := diag(R) * A * diag(C). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AFB */ +/* > \verbatim */ +/* > AFB is COMPLEX*16 array, dimension (LDAFB,N) */ +/* > If FACT = 'F', then AFB is an input argument and on entry */ +/* > contains details of the LU factorization of the band matrix */ +/* > A, as computed by ZGBTRF. U is stored as an upper triangular */ +/* > band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */ +/* > and the multipliers used during the factorization are stored */ +/* > in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is */ +/* > the factored form of the equilibrated matrix A. */ +/* > */ +/* > If FACT = 'N', then AFB is an output argument and on exit */ +/* > returns details of the LU factorization of A. */ +/* > */ +/* > If FACT = 'E', then AFB is an output argument and on exit */ +/* > returns details of the LU factorization of the equilibrated */ +/* > matrix A (see the description of AB for the form of the */ +/* > equilibrated matrix). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAFB */ +/* > \verbatim */ +/* > LDAFB is INTEGER */ +/* > The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > If FACT = 'F', then IPIV is an input argument and on entry */ +/* > contains the pivot indices from the factorization A = L*U */ +/* > as computed by ZGBTRF; row i of the matrix was interchanged */ +/* > with row IPIV(i). */ +/* > */ +/* > If FACT = 'N', then IPIV is an output argument and on exit */ +/* > contains the pivot indices from the factorization A = L*U */ +/* > of the original matrix A. */ +/* > */ +/* > If FACT = 'E', then IPIV is an output argument and on exit */ +/* > contains the pivot indices from the factorization A = L*U */ +/* > of the equilibrated matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies the form of equilibration that was done. */ +/* > = 'N': No equilibration (always true if FACT = 'N'). */ +/* > = '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). */ +/* > EQUED is an input argument if FACT = 'F'; otherwise, it is an */ +/* > output argument. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] R */ +/* > \verbatim */ +/* > R is DOUBLE PRECISION array, dimension (N) */ +/* > The row scale factors for A. If EQUED = 'R' or 'B', A is */ +/* > multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */ +/* > is not accessed. R is an input argument if FACT = 'F'; */ +/* > otherwise, R is an output argument. If FACT = 'F' and */ +/* > EQUED = 'R' or 'B', each element of R must be positive. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N) */ +/* > The column scale factors for A. If EQUED = 'C' or 'B', A is */ +/* > multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */ +/* > is not accessed. C is an input argument if FACT = 'F'; */ +/* > otherwise, C is an output argument. If FACT = 'F' and */ +/* > EQUED = 'C' or 'B', each element of C must be positive. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, */ +/* > if EQUED = 'N', B is not modified; */ +/* > if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */ +/* > diag(R)*B; */ +/* > if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */ +/* > overwritten by diag(C)*B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (LDX,NRHS) */ +/* > If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X */ +/* > to the original system of equations. Note that A and B are */ +/* > modified on exit if EQUED .ne. 'N', and the solution to the */ +/* > equilibrated system is inv(diag(C))*X if TRANS = 'N' and */ +/* > EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' */ +/* > and EQUED = 'R' or 'B'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > The estimate of the reciprocal condition number of the matrix */ +/* > A after equilibration (if done). If RCOND is less than the */ +/* > machine precision (in particular, if RCOND = 0), the matrix */ +/* > is singular to working precision. This condition is */ +/* > indicated by a return code of INFO > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (N) */ +/* > On exit, RWORK(1) contains the reciprocal pivot growth */ +/* > factor norm(A)/norm(U). The "f2cmax absolute element" norm is */ +/* > used. If RWORK(1) is much less than 1, then the stability */ +/* > of the LU factorization of the (equilibrated) matrix A */ +/* > could be poor. This also means that the solution X, condition */ +/* > estimator RCOND, and forward error bound FERR could be */ +/* > unreliable. If factorization fails with 0 RWORK(1) contains the reciprocal pivot growth factor for the */ +/* > leading INFO columns of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, and i is */ +/* > <= N: U(i,i) is exactly zero. The factorization */ +/* > has been completed, but the factor U is exactly */ +/* > singular, so the solution and error bounds */ +/* > could not be computed. RCOND = 0 is returned. */ +/* > = N+1: U is nonsingular, but RCOND is less than machine */ +/* > precision, meaning that the matrix is singular */ +/* > to working precision. Nevertheless, the */ +/* > solution and error bounds are computed because */ +/* > there are a number of situations where the */ +/* > computed solution can be more accurate than the */ +/* > value of RCOND would suggest. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup complex16GBsolve */ + +/* ===================================================================== */ +/* Subroutine */ int zgbsvx_(char *fact, char *trans, integer *n, integer *kl, + integer *ku, integer *nrhs, doublecomplex *ab, integer *ldab, + doublecomplex *afb, integer *ldafb, integer *ipiv, char *equed, + doublereal *r__, doublereal *c__, doublecomplex *b, integer *ldb, + doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *ferr, + doublereal *berr, doublecomplex *work, doublereal *rwork, integer * + info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, + x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5; + doublereal d__1, d__2; + doublecomplex z__1; + + /* Local variables */ + doublereal amax; + char norm[1]; + integer i__, j; + extern logical lsame_(char *, char *); + doublereal rcmin, rcmax, anorm; + logical equil; + integer j1, j2; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + extern doublereal dlamch_(char *); + doublereal colcnd; + logical nofact; + extern doublereal zlangb_(char *, integer *, integer *, integer *, + doublecomplex *, integer *, doublereal *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zlaqgb_( + integer *, integer *, integer *, integer *, doublecomplex *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, char *); + doublereal bignum; + extern /* Subroutine */ int zgbcon_(char *, integer *, integer *, integer + *, doublecomplex *, integer *, integer *, doublereal *, + doublereal *, doublecomplex *, doublereal *, integer *); + integer infequ; + logical colequ; + extern doublereal zlantb_(char *, char *, char *, integer *, integer *, + doublecomplex *, integer *, doublereal *); + doublereal rowcnd; + extern /* Subroutine */ int zgbequ_(integer *, integer *, integer *, + integer *, doublecomplex *, integer *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, integer *), zgbrfs_( + char *, integer *, integer *, integer *, integer *, doublecomplex + *, integer *, doublecomplex *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublereal *, doublereal *, doublecomplex *, doublereal *, + integer *), zgbtrf_(integer *, integer *, integer *, + integer *, doublecomplex *, integer *, integer *, integer *); + logical notran; + extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + doublereal smlnum; + extern /* Subroutine */ int zgbtrs_(char *, integer *, integer *, integer + *, integer *, doublecomplex *, integer *, integer *, + doublecomplex *, integer *, integer *); + logical rowequ; + doublereal rpvgrw; + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ===================================================================== */ +/* Moved setting of INFO = N+1 so INFO does not subsequently get */ +/* overwritten. Sven, 17 Mar 05. */ +/* ===================================================================== */ + + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + afb_dim1 = *ldafb; + afb_offset = 1 + afb_dim1 * 1; + afb -= afb_offset; + --ipiv; + --r__; + --c__; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --rwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + equil = lsame_(fact, "E"); + notran = lsame_(trans, "N"); + if (nofact || equil) { + *(unsigned char *)equed = 'N'; + rowequ = FALSE_; + colequ = FALSE_; + } else { + rowequ = lsame_(equed, "R") || lsame_(equed, + "B"); + colequ = lsame_(equed, "C") || lsame_(equed, + "B"); + smlnum = dlamch_("Safe minimum"); + bignum = 1. / smlnum; + } + +/* Test the input parameters. */ + + if (! nofact && ! equil && ! lsame_(fact, "F")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*kl < 0) { + *info = -4; + } else if (*ku < 0) { + *info = -5; + } else if (*nrhs < 0) { + *info = -6; + } else if (*ldab < *kl + *ku + 1) { + *info = -8; + } else if (*ldafb < (*kl << 1) + *ku + 1) { + *info = -10; + } else if (lsame_(fact, "F") && ! (rowequ || colequ + || lsame_(equed, "N"))) { + *info = -12; + } else { + if (rowequ) { + rcmin = bignum; + rcmax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = rcmin, d__2 = r__[j]; + rcmin = f2cmin(d__1,d__2); +/* Computing MAX */ + d__1 = rcmax, d__2 = r__[j]; + rcmax = f2cmax(d__1,d__2); +/* L10: */ + } + if (rcmin <= 0.) { + *info = -13; + } else if (*n > 0) { + rowcnd = f2cmax(rcmin,smlnum) / f2cmin(rcmax,bignum); + } else { + rowcnd = 1.; + } + } + if (colequ && *info == 0) { + rcmin = bignum; + rcmax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = rcmin, d__2 = c__[j]; + rcmin = f2cmin(d__1,d__2); +/* Computing MAX */ + d__1 = rcmax, d__2 = c__[j]; + rcmax = f2cmax(d__1,d__2); +/* L20: */ + } + if (rcmin <= 0.) { + *info = -14; + } else if (*n > 0) { + colcnd = f2cmax(rcmin,smlnum) / f2cmin(rcmax,bignum); + } else { + colcnd = 1.; + } + } + if (*info == 0) { + if (*ldb < f2cmax(1,*n)) { + *info = -16; + } else if (*ldx < f2cmax(1,*n)) { + *info = -18; + } + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGBSVX", &i__1, (ftnlen)6); + return 0; + } + + if (equil) { + +/* Compute row and column scalings to equilibrate the matrix A. */ + + zgbequ_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &rowcnd, + &colcnd, &amax, &infequ); + if (infequ == 0) { + +/* Equilibrate the matrix. */ + + zlaqgb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], & + rowcnd, &colcnd, &amax, equed); + rowequ = lsame_(equed, "R") || lsame_(equed, + "B"); + colequ = lsame_(equed, "C") || lsame_(equed, + "B"); + } + } + +/* Scale the right hand side. */ + + if (notran) { + if (rowequ) { + 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__; + i__5 = i__ + j * b_dim1; + z__1.r = r__[i__4] * b[i__5].r, z__1.i = r__[i__4] * b[ + i__5].i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L30: */ + } +/* L40: */ + } + } + } else if (colequ) { + 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__; + i__5 = i__ + j * b_dim1; + z__1.r = c__[i__4] * b[i__5].r, z__1.i = c__[i__4] * b[i__5] + .i; + b[i__3].r = z__1.r, b[i__3].i = z__1.i; +/* L50: */ + } +/* L60: */ + } + } + + if (nofact || equil) { + +/* Compute the LU factorization of the band matrix A. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = j - *ku; + j1 = f2cmax(i__2,1); +/* Computing MIN */ + i__2 = j + *kl; + j2 = f2cmin(i__2,*n); + i__2 = j2 - j1 + 1; + zcopy_(&i__2, &ab[*ku + 1 - j + j1 + j * ab_dim1], &c__1, &afb[* + kl + *ku + 1 - j + j1 + j * afb_dim1], &c__1); +/* L70: */ + } + + zgbtrf_(n, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + +/* Compute the reciprocal pivot growth factor of the */ +/* leading rank-deficient INFO columns of A. */ + + anorm = 0.; + i__1 = *info; + 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__) { +/* Computing MAX */ + d__1 = anorm, d__2 = z_abs(&ab[i__ + j * ab_dim1]); + anorm = f2cmax(d__1,d__2); +/* L80: */ + } +/* L90: */ + } +/* Computing MIN */ + i__3 = *info - 1, i__2 = *kl + *ku; + i__1 = f2cmin(i__3,i__2); +/* Computing MAX */ + i__4 = 1, i__5 = *kl + *ku + 2 - *info; + rpvgrw = zlantb_("M", "U", "N", info, &i__1, &afb[f2cmax(i__4,i__5) + + afb_dim1], ldafb, &rwork[1]); + if (rpvgrw == 0.) { + rpvgrw = 1.; + } else { + rpvgrw = anorm / rpvgrw; + } + rwork[1] = rpvgrw; + *rcond = 0.; + return 0; + } + } + +/* Compute the norm of the matrix A and the */ +/* reciprocal pivot growth factor RPVGRW. */ + + if (notran) { + *(unsigned char *)norm = '1'; + } else { + *(unsigned char *)norm = 'I'; + } + anorm = zlangb_(norm, n, kl, ku, &ab[ab_offset], ldab, &rwork[1]); + i__1 = *kl + *ku; + rpvgrw = zlantb_("M", "U", "N", n, &i__1, &afb[afb_offset], ldafb, &rwork[ + 1]); + if (rpvgrw == 0.) { + rpvgrw = 1.; + } else { + rpvgrw = zlangb_("M", n, kl, ku, &ab[ab_offset], ldab, &rwork[1]) / rpvgrw; + } + +/* Compute the reciprocal of the condition number of A. */ + + zgbcon_(norm, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], &anorm, rcond, + &work[1], &rwork[1], info); + +/* Compute the solution matrix X. */ + + zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + zgbtrs_(trans, n, kl, ku, nrhs, &afb[afb_offset], ldafb, &ipiv[1], &x[ + x_offset], ldx, info); + +/* Use iterative refinement to improve the computed solution and */ +/* compute error bounds and backward error estimates for it. */ + + zgbrfs_(trans, n, kl, ku, nrhs, &ab[ab_offset], ldab, &afb[afb_offset], + ldafb, &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], & + berr[1], &work[1], &rwork[1], info); + +/* Transform the solution matrix X to a solution of the original */ +/* system. */ + + if (notran) { + if (colequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__2 = i__ + j * x_dim1; + i__4 = i__; + i__5 = i__ + j * x_dim1; + z__1.r = c__[i__4] * x[i__5].r, z__1.i = c__[i__4] * x[ + i__5].i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; +/* L100: */ + } +/* L110: */ + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] /= colcnd; +/* L120: */ + } + } + } else if (rowequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__2 = i__ + j * x_dim1; + i__4 = i__; + i__5 = i__ + j * x_dim1; + z__1.r = r__[i__4] * x[i__5].r, z__1.i = r__[i__4] * x[i__5] + .i; + x[i__2].r = z__1.r, x[i__2].i = z__1.i; +/* L130: */ + } +/* L140: */ + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] /= rowcnd; +/* L150: */ + } + } + +/* Set INFO = N+1 if the matrix is singular to working precision. */ + + if (*rcond < dlamch_("Epsilon")) { + *info = *n + 1; + } + + rwork[1] = rpvgrw; + return 0; + +/* End of ZGBSVX */ + +} /* zgbsvx_ */ + diff --git a/lapack-netlib/SRC/zgbsvxx.c b/lapack-netlib/SRC/zgbsvxx.c new file mode 100644 index 000000000..fdbfc1503 --- /dev/null +++ b/lapack-netlib/SRC/zgbsvxx.c @@ -0,0 +1,1251 @@ +/* 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 ZGBSVXX computes the solution to system of linear equations A * X = B for GB matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGBSVXX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, */ +/* LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, */ +/* RCOND, RPVGRW, BERR, N_ERR_BNDS, */ +/* ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, */ +/* WORK, RWORK, INFO ) */ + +/* CHARACTER EQUED, FACT, TRANS */ +/* INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, NRHS, NPARAMS, */ +/* $ N_ERR_BNDS */ +/* DOUBLE PRECISION RCOND, RPVGRW */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), */ +/* $ X( LDX , * ),WORK( * ) */ +/* DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ), */ +/* $ ERR_BNDS_NORM( NRHS, * ), */ +/* $ ERR_BNDS_COMP( NRHS, * ), RWORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGBSVXX uses the LU factorization to compute the solution to a */ +/* > complex*16 system of linear equations A * X = B, where A is an */ +/* > N-by-N matrix and X and B are N-by-NRHS matrices. */ +/* > */ +/* > If requested, both normwise and maximum componentwise error bounds */ +/* > are returned. ZGBSVXX will return a solution with a tiny */ +/* > guaranteed error (O(eps) where eps is the working machine */ +/* > precision) unless the matrix is very ill-conditioned, in which */ +/* > case a warning is returned. Relevant condition numbers also are */ +/* > calculated and returned. */ +/* > */ +/* > ZGBSVXX accepts user-provided factorizations and equilibration */ +/* > factors; see the definitions of the FACT and EQUED options. */ +/* > Solving with refinement and using a factorization from a previous */ +/* > ZGBSVXX call will also produce a solution with either O(eps) */ +/* > errors or warnings, but we cannot make that claim for general */ +/* > user-provided factorizations and equilibration factors if they */ +/* > differ from what ZGBSVXX would itself produce. */ +/* > \endverbatim */ + +/* > \par Description: */ +/* ================= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The following steps are performed: */ +/* > */ +/* > 1. If FACT = 'E', double precision scaling factors are computed to equilibrate */ +/* > the system: */ +/* > */ +/* > TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */ +/* > TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */ +/* > TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */ +/* > */ +/* > Whether or not the system will be equilibrated depends on the */ +/* > scaling of the matrix A, but if equilibration is used, A is */ +/* > overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */ +/* > or diag(C)*B (if TRANS = 'T' or 'C'). */ +/* > */ +/* > 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */ +/* > the matrix A (after equilibration if FACT = 'E') as */ +/* > */ +/* > A = P * L * U, */ +/* > */ +/* > where P is a permutation matrix, L is a unit lower triangular */ +/* > matrix, and U is upper triangular. */ +/* > */ +/* > 3. If some U(i,i)=0, so that U is exactly singular, then the */ +/* > routine returns with INFO = i. Otherwise, the factored form of A */ +/* > is used to estimate the condition number of the matrix A (see */ +/* > argument RCOND). If the reciprocal of the condition number is less */ +/* > than machine precision, the routine still goes on to solve for X */ +/* > and compute error bounds as described below. */ +/* > */ +/* > 4. The system of equations is solved for X using the factored form */ +/* > of A. */ +/* > */ +/* > 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */ +/* > the routine will use iterative refinement to try to get a small */ +/* > error and error bounds. Refinement calculates the residual to at */ +/* > least twice the working precision. */ +/* > */ +/* > 6. If equilibration was used, the matrix X is premultiplied by */ +/* > diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */ +/* > that it solves the original system before equilibration. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \verbatim */ +/* > Some optional parameters are bundled in the PARAMS array. These */ +/* > settings determine how refinement is performed, but often the */ +/* > defaults are acceptable. If the defaults are acceptable, users */ +/* > can pass NPARAMS = 0 which prevents the source code from accessing */ +/* > the PARAMS argument. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] FACT */ +/* > \verbatim */ +/* > FACT is CHARACTER*1 */ +/* > Specifies whether or not the factored form of the matrix A is */ +/* > supplied on entry, and if not, whether the matrix A should be */ +/* > equilibrated before it is factored. */ +/* > = 'F': On entry, AF and IPIV contain the factored form of A. */ +/* > If EQUED is not 'N', the matrix A has been */ +/* > equilibrated with scaling factors given by R and C. */ +/* > A, AF, and IPIV are not modified. */ +/* > = 'N': The matrix A will be copied to AF and factored. */ +/* > = 'E': The matrix A will be equilibrated if necessary, then */ +/* > copied to AF and factored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate Transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] 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] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,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(N,j+kl) */ +/* > */ +/* > If FACT = 'F' and EQUED is not 'N', then AB must have been */ +/* > equilibrated by the scaling factors in R and/or C. AB is not */ +/* > modified if FACT = 'F' or 'N', or if FACT = 'E' and */ +/* > EQUED = 'N' on exit. */ +/* > */ +/* > On exit, if EQUED .ne. 'N', A is scaled as follows: */ +/* > EQUED = 'R': A := diag(R) * A */ +/* > EQUED = 'C': A := A * diag(C) */ +/* > EQUED = 'B': A := diag(R) * A * diag(C). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AFB */ +/* > \verbatim */ +/* > AFB is COMPLEX*16 array, dimension (LDAFB,N) */ +/* > If FACT = 'F', then AFB is an input argument and on entry */ +/* > contains details of the LU factorization of the band matrix */ +/* > A, as computed by ZGBTRF. U is stored as an upper triangular */ +/* > band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */ +/* > and the multipliers used during the factorization are stored */ +/* > in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is */ +/* > the factored form of the equilibrated matrix A. */ +/* > */ +/* > If FACT = 'N', then AF is an output argument and on exit */ +/* > returns the factors L and U from the factorization A = P*L*U */ +/* > of the original matrix A. */ +/* > */ +/* > If FACT = 'E', then AF is an output argument and on exit */ +/* > returns the factors L and U from the factorization A = P*L*U */ +/* > of the equilibrated matrix A (see the description of A for */ +/* > the form of the equilibrated matrix). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAFB */ +/* > \verbatim */ +/* > LDAFB is INTEGER */ +/* > The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > If FACT = 'F', then IPIV is an input argument and on entry */ +/* > contains the pivot indices from the factorization A = P*L*U */ +/* > as computed by DGETRF; row i of the matrix was interchanged */ +/* > with row IPIV(i). */ +/* > */ +/* > If FACT = 'N', then IPIV is an output argument and on exit */ +/* > contains the pivot indices from the factorization A = P*L*U */ +/* > of the original matrix A. */ +/* > */ +/* > If FACT = 'E', then IPIV is an output argument and on exit */ +/* > contains the pivot indices from the factorization A = P*L*U */ +/* > of the equilibrated matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies the form of equilibration that was done. */ +/* > = 'N': No equilibration (always true if FACT = 'N'). */ +/* > = '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). */ +/* > EQUED is an input argument if FACT = 'F'; otherwise, it is an */ +/* > output argument. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] R */ +/* > \verbatim */ +/* > R is DOUBLE PRECISION array, dimension (N) */ +/* > The row scale factors for A. If EQUED = 'R' or 'B', A is */ +/* > multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */ +/* > is not accessed. R is an input argument if FACT = 'F'; */ +/* > otherwise, R is an output argument. If FACT = 'F' and */ +/* > EQUED = 'R' or 'B', each element of R must be positive. */ +/* > If R is output, each element of R is a power of the radix. */ +/* > If R is input, each element of R should be a power of the radix */ +/* > to ensure a reliable solution and error estimates. Scaling by */ +/* > powers of the radix does not cause rounding errors unless the */ +/* > result underflows or overflows. Rounding errors during scaling */ +/* > lead to refining with a matrix that is not equivalent to the */ +/* > input matrix, producing error estimates that may not be */ +/* > reliable. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N) */ +/* > The column scale factors for A. If EQUED = 'C' or 'B', A is */ +/* > multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */ +/* > is not accessed. C is an input argument if FACT = 'F'; */ +/* > otherwise, C is an output argument. If FACT = 'F' and */ +/* > EQUED = 'C' or 'B', each element of C must be positive. */ +/* > If C is output, each element of C is a power of the radix. */ +/* > If C is input, each element of C should be a power of the radix */ +/* > to ensure a reliable solution and error estimates. Scaling by */ +/* > powers of the radix does not cause rounding errors unless the */ +/* > result underflows or overflows. Rounding errors during scaling */ +/* > lead to refining with a matrix that is not equivalent to the */ +/* > input matrix, producing error estimates that may not be */ +/* > reliable. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > On entry, the N-by-NRHS right hand side matrix B. */ +/* > On exit, */ +/* > if EQUED = 'N', B is not modified; */ +/* > if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */ +/* > diag(R)*B; */ +/* > if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */ +/* > overwritten by diag(C)*B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (LDX,NRHS) */ +/* > If INFO = 0, the N-by-NRHS solution matrix X to the original */ +/* > system of equations. Note that A and B are modified on exit */ +/* > if EQUED .ne. 'N', and the solution to the equilibrated system is */ +/* > inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or */ +/* > inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > Reciprocal scaled condition number. This is an estimate of the */ +/* > reciprocal Skeel condition number of the matrix A after */ +/* > equilibration (if done). If this is less than the machine */ +/* > precision (in particular, if it is zero), the matrix is singular */ +/* > to working precision. Note that the error may still be small even */ +/* > if this number is very small and the matrix appears ill- */ +/* > conditioned. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RPVGRW */ +/* > \verbatim */ +/* > RPVGRW is DOUBLE PRECISION */ +/* > Reciprocal pivot growth. On exit, this contains the reciprocal */ +/* > pivot growth factor norm(A)/norm(U). The "f2cmax absolute element" */ +/* > norm is used. If this is much less than 1, then the stability of */ +/* > the LU factorization of the (equilibrated) matrix A could be poor. */ +/* > This also means that the solution X, estimated condition numbers, */ +/* > and error bounds could be unreliable. If factorization fails with */ +/* > 0 for the leading INFO columns of A. In DGESVX, this quantity is */ +/* > returned in WORK(1). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > Componentwise relative backward error. This is the */ +/* > componentwise relative backward error of each solution vector X(j) */ +/* > (i.e., the smallest relative change in any element of A or B that */ +/* > makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N_ERR_BNDS */ +/* > \verbatim */ +/* > N_ERR_BNDS is INTEGER */ +/* > Number of error bounds to return for each right hand side */ +/* > and each type (normwise or componentwise). See ERR_BNDS_NORM and */ +/* > ERR_BNDS_COMP below. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ERR_BNDS_NORM */ +/* > \verbatim */ +/* > ERR_BNDS_NORM is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > normwise relative error, which is defined as follows: */ +/* > */ +/* > Normwise relative error in the ith solution vector: */ +/* > max_j (abs(XTRUE(j,i) - X(j,i))) */ +/* > ------------------------------ */ +/* > max_j abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the type of error information as described */ +/* > below. There currently are up to three pieces of information */ +/* > returned. */ +/* > */ +/* > The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_NORM(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * dlamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * dlamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated normwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * dlamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*A, where S scales each row by a power of the */ +/* > radix so all absolute row sums of Z are approximately 1. */ +/* > */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ERR_BNDS_COMP */ +/* > \verbatim */ +/* > ERR_BNDS_COMP is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > componentwise relative error, which is defined as follows: */ +/* > */ +/* > Componentwise relative error in the ith solution vector: */ +/* > abs(XTRUE(j,i) - X(j,i)) */ +/* > max_j ---------------------- */ +/* > abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the right-hand side i (on which the */ +/* > componentwise relative error depends), and the type of error */ +/* > information as described below. There currently are up to three */ +/* > pieces of information returned for each right-hand side. If */ +/* > componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ +/* > ERR_BNDS_COMP is not accessed. If N_ERR_BNDS < 3, then at most */ +/* > the first (:,N_ERR_BNDS) entries are returned. */ +/* > */ +/* > The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_COMP(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * dlamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * dlamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated componentwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * dlamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*(A*diag(x)), where x is the solution for the */ +/* > current right-hand side and S scales each row of */ +/* > A*diag(x) by a power of the radix so all absolute row */ +/* > sums of Z are approximately 1. */ +/* > */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NPARAMS */ +/* > \verbatim */ +/* > NPARAMS is INTEGER */ +/* > Specifies the number of parameters set in PARAMS. If <= 0, the */ +/* > PARAMS array is never referenced and default values are used. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] PARAMS */ +/* > \verbatim */ +/* > PARAMS is DOUBLE PRECISION array, dimension NPARAMS */ +/* > Specifies algorithm parameters. If an entry is < 0.0, then */ +/* > that entry will be filled with default value used for that */ +/* > parameter. Only positions up to NPARAMS are accessed; defaults */ +/* > are used for higher-numbered parameters. */ +/* > */ +/* > PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */ +/* > refinement or not. */ +/* > Default: 1.0D+0 */ +/* > = 0.0: No refinement is performed, and no error bounds are */ +/* > computed. */ +/* > = 1.0: Use the extra-precise refinement algorithm. */ +/* > (other values are reserved for future use) */ +/* > */ +/* > PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */ +/* > computations allowed for refinement. */ +/* > Default: 10 */ +/* > Aggressive: Set to 100 to permit convergence using approximate */ +/* > factorizations or factorizations other than LU. If */ +/* > the factorization uses a technique other than */ +/* > Gaussian elimination, the guarantees in */ +/* > err_bnds_norm and err_bnds_comp may no longer be */ +/* > trustworthy. */ +/* > */ +/* > PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */ +/* > will attempt to find a solution with small componentwise */ +/* > relative error in the double-precision algorithm. Positive */ +/* > is true, 0.0 is false. */ +/* > Default: 1.0 (attempt componentwise convergence) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. The solution to every right-hand side is */ +/* > guaranteed. */ +/* > < 0: If INFO = -i, the i-th argument had an illegal value */ +/* > > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */ +/* > has been completed, but the factor U is exactly singular, so */ +/* > the solution and error bounds could not be computed. RCOND = 0 */ +/* > is returned. */ +/* > = N+J: The solution corresponding to the Jth right-hand side is */ +/* > not guaranteed. The solutions corresponding to other right- */ +/* > hand sides K with K > J may not be guaranteed as well, but */ +/* > only the first such right-hand side is reported. If a small */ +/* > componentwise error is not requested (PARAMS(3) = 0.0) then */ +/* > the Jth right-hand side is the first with a normwise error */ +/* > bound that is not guaranteed (the smallest J such */ +/* > that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */ +/* > the Jth right-hand side is the first with either a normwise or */ +/* > componentwise error bound that is not guaranteed (the smallest */ +/* > J such that either ERR_BNDS_NORM(J,1) = 0.0 or */ +/* > ERR_BNDS_COMP(J,1) = 0.0). See the definition of */ +/* > ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */ +/* > about all of the right-hand sides check ERR_BNDS_NORM or */ +/* > ERR_BNDS_COMP. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup complex16GBsolve */ + +/* ===================================================================== */ +/* Subroutine */ int zgbsvxx_(char *fact, char *trans, integer *n, integer * + kl, integer *ku, integer *nrhs, doublecomplex *ab, integer *ldab, + doublecomplex *afb, integer *ldafb, integer *ipiv, char *equed, + doublereal *r__, doublereal *c__, doublecomplex *b, integer *ldb, + doublecomplex *x, integer *ldx, doublereal *rcond, doublereal *rpvgrw, + doublereal *berr, integer *n_err_bnds__, doublereal *err_bnds_norm__, + doublereal *err_bnds_comp__, integer *nparams, doublereal *params, + doublecomplex *work, doublereal *rwork, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, + x_dim1, x_offset, err_bnds_norm_dim1, err_bnds_norm_offset, + err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3, i__4; + doublereal d__1, d__2; + + /* Local variables */ + doublereal amax; + extern doublereal zla_gbrpvgrw_(integer *, integer *, integer *, integer + *, doublecomplex *, integer *, doublecomplex *, integer *); + integer i__, j; + extern logical lsame_(char *, char *); + doublereal rcmin, rcmax; + logical equil; + extern doublereal dlamch_(char *); + doublereal colcnd; + logical nofact; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zlaqgb_( + integer *, integer *, integer *, integer *, doublecomplex *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, char *); + doublereal bignum; + integer infequ; + logical colequ; + doublereal rowcnd; + extern /* Subroutine */ int zgbtrf_(integer *, integer *, integer *, + integer *, doublecomplex *, integer *, integer *, integer *); + logical notran; + extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + doublereal smlnum; + extern /* Subroutine */ int zgbtrs_(char *, integer *, integer *, integer + *, integer *, doublecomplex *, integer *, integer *, + doublecomplex *, integer *, integer *); + logical rowequ; + extern /* Subroutine */ int zlascl2_(integer *, integer *, doublereal *, + doublecomplex *, integer *), zgbequb_(integer *, integer *, + integer *, integer *, doublecomplex *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *) + , zgbrfsx_(char *, char *, integer *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *, + integer *, doublereal *, doublereal *, doublecomplex *, integer * + , doublecomplex *, integer *, doublereal *, doublereal *, integer + *, doublereal *, doublereal *, integer *, doublereal *, + doublecomplex *, doublereal *, integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ================================================================== */ + + + /* Parameter adjustments */ + err_bnds_comp_dim1 = *nrhs; + err_bnds_comp_offset = 1 + err_bnds_comp_dim1 * 1; + err_bnds_comp__ -= err_bnds_comp_offset; + err_bnds_norm_dim1 = *nrhs; + err_bnds_norm_offset = 1 + err_bnds_norm_dim1 * 1; + err_bnds_norm__ -= err_bnds_norm_offset; + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + afb_dim1 = *ldafb; + afb_offset = 1 + afb_dim1 * 1; + afb -= afb_offset; + --ipiv; + --r__; + --c__; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --berr; + --params; + --work; + --rwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + equil = lsame_(fact, "E"); + notran = lsame_(trans, "N"); + smlnum = dlamch_("Safe minimum"); + bignum = 1. / smlnum; + if (nofact || equil) { + *(unsigned char *)equed = 'N'; + rowequ = FALSE_; + colequ = FALSE_; + } else { + rowequ = lsame_(equed, "R") || lsame_(equed, + "B"); + colequ = lsame_(equed, "C") || lsame_(equed, + "B"); + } + +/* Default is failure. If an input parameter is wrong or */ +/* factorization fails, make everything look horrible. Only the */ +/* pivot growth is set here, the rest is initialized in ZGBRFSX. */ + + *rpvgrw = 0.; + +/* Test the input parameters. PARAMS is not tested until DGERFSX. */ + + if (! nofact && ! equil && ! lsame_(fact, "F")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*kl < 0) { + *info = -4; + } else if (*ku < 0) { + *info = -5; + } else if (*nrhs < 0) { + *info = -6; + } else if (*ldab < *kl + *ku + 1) { + *info = -8; + } else if (*ldafb < (*kl << 1) + *ku + 1) { + *info = -10; + } else if (lsame_(fact, "F") && ! (rowequ || colequ + || lsame_(equed, "N"))) { + *info = -12; + } else { + if (rowequ) { + rcmin = bignum; + rcmax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = rcmin, d__2 = r__[j]; + rcmin = f2cmin(d__1,d__2); +/* Computing MAX */ + d__1 = rcmax, d__2 = r__[j]; + rcmax = f2cmax(d__1,d__2); +/* L10: */ + } + if (rcmin <= 0.) { + *info = -13; + } else if (*n > 0) { + rowcnd = f2cmax(rcmin,smlnum) / f2cmin(rcmax,bignum); + } else { + rowcnd = 1.; + } + } + if (colequ && *info == 0) { + rcmin = bignum; + rcmax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = rcmin, d__2 = c__[j]; + rcmin = f2cmin(d__1,d__2); +/* Computing MAX */ + d__1 = rcmax, d__2 = c__[j]; + rcmax = f2cmax(d__1,d__2); +/* L20: */ + } + if (rcmin <= 0.) { + *info = -14; + } else if (*n > 0) { + colcnd = f2cmax(rcmin,smlnum) / f2cmin(rcmax,bignum); + } else { + colcnd = 1.; + } + } + if (*info == 0) { + if (*ldb < f2cmax(1,*n)) { + *info = -15; + } else if (*ldx < f2cmax(1,*n)) { + *info = -16; + } + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGBSVXX", &i__1, (ftnlen)7); + return 0; + } + + if (equil) { + +/* Compute row and column scalings to equilibrate the matrix A. */ + + zgbequb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], & + rowcnd, &colcnd, &amax, &infequ); + if (infequ == 0) { + +/* Equilibrate the matrix. */ + + zlaqgb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], & + rowcnd, &colcnd, &amax, equed); + rowequ = lsame_(equed, "R") || lsame_(equed, + "B"); + colequ = lsame_(equed, "C") || lsame_(equed, + "B"); + } + +/* If the scaling factors are not applied, set them to 1.0. */ + + if (! rowequ) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + r__[j] = 1.; + } + } + if (! colequ) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + c__[j] = 1.; + } + } + } + +/* Scale the right-hand side. */ + + if (notran) { + if (rowequ) { + zlascl2_(n, nrhs, &r__[1], &b[b_offset], ldb); + } + } else { + if (colequ) { + zlascl2_(n, nrhs, &c__[1], &b[b_offset], ldb); + } + } + + if (nofact || equil) { + +/* Compute the LU factorization of A. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = (*kl << 1) + *ku + 1; + for (i__ = *kl + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * afb_dim1; + i__4 = i__ - *kl + j * ab_dim1; + afb[i__3].r = ab[i__4].r, afb[i__3].i = ab[i__4].i; +/* L30: */ + } +/* L40: */ + } + zgbtrf_(n, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + +/* Pivot in column INFO is exactly 0 */ +/* Compute the reciprocal pivot growth factor of the */ +/* leading rank-deficient INFO columns of A. */ + + *rpvgrw = zla_gbrpvgrw_(n, kl, ku, info, &ab[ab_offset], ldab, & + afb[afb_offset], ldafb); + return 0; + } + } + +/* Compute the reciprocal pivot growth factor RPVGRW. */ + + *rpvgrw = zla_gbrpvgrw_(n, kl, ku, n, &ab[ab_offset], ldab, &afb[ + afb_offset], ldafb); + +/* Compute the solution matrix X. */ + + zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + zgbtrs_(trans, n, kl, ku, nrhs, &afb[afb_offset], ldafb, &ipiv[1], &x[ + x_offset], ldx, info); + +/* Use iterative refinement to improve the computed solution and */ +/* compute error bounds and backward error estimates for it. */ + + zgbrfsx_(trans, equed, n, kl, ku, nrhs, &ab[ab_offset], ldab, &afb[ + afb_offset], ldafb, &ipiv[1], &r__[1], &c__[1], &b[b_offset], ldb, + &x[x_offset], ldx, rcond, &berr[1], n_err_bnds__, & + err_bnds_norm__[err_bnds_norm_offset], &err_bnds_comp__[ + err_bnds_comp_offset], nparams, ¶ms[1], &work[1], &rwork[1], + info); + +/* Scale solutions. */ + + if (colequ && notran) { + zlascl2_(n, nrhs, &c__[1], &x[x_offset], ldx); + } else if (rowequ && ! notran) { + zlascl2_(n, nrhs, &r__[1], &x[x_offset], ldx); + } + + return 0; + +/* End of ZGBSVXX */ + +} /* zgbsvxx_ */ + diff --git a/lapack-netlib/SRC/zgbtf2.c b/lapack-netlib/SRC/zgbtf2.c new file mode 100644 index 000000000..35566d16c --- /dev/null +++ b/lapack-netlib/SRC/zgbtf2.c @@ -0,0 +1,700 @@ +/* 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 ZGBTF2 computes the LU factorization of a general band matrix using the unblocked version of th +e algorithm. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGBTF2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) */ + +/* INTEGER INFO, KL, KU, LDAB, M, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 AB( LDAB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGBTF2 computes an LU factorization of a complex m-by-n band matrix */ +/* > A using partial pivoting with row interchanges. */ +/* > */ +/* > This is the unblocked version of the algorithm, calling Level 2 BLAS. */ +/* > \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 KL+1 to */ +/* > 2*KL+KU+1; rows 1 to KL of the array need not be set. */ +/* > The j-th column of A is stored in the j-th column of the */ +/* > array AB as follows: */ +/* > AB(kl+ku+1+i-j,j) = A(i,j) for f2cmax(1,j-ku)<=i<=f2cmin(m,j+kl) */ +/* > */ +/* > On exit, details of the factorization: U is stored as an */ +/* > upper triangular band matrix with KL+KU superdiagonals in */ +/* > rows 1 to KL+KU+1, and the multipliers used during the */ +/* > factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */ +/* > See below for further details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (f2cmin(M,N)) */ +/* > The pivot indices; for 1 <= i <= f2cmin(M,N), row i of the */ +/* > matrix was interchanged with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = +i, U(i,i) is exactly zero. The factorization */ +/* > has been completed, but the factor U is exactly */ +/* > singular, and division by zero will occur if it is used */ +/* > to solve a system of equations. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GBcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The band storage scheme is illustrated by the following example, when */ +/* > M = N = 6, KL = 2, KU = 1: */ +/* > */ +/* > On entry: On exit: */ +/* > */ +/* > * * * + + + * * * u14 u25 u36 */ +/* > * * + + + + * * u13 u24 u35 u46 */ +/* > * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */ +/* > a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */ +/* > a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */ +/* > a31 a42 a53 a64 * * m31 m42 m53 m64 * * */ +/* > */ +/* > Array elements marked * are not used by the routine; elements marked */ +/* > + need not be set on entry, but are required by the routine to store */ +/* > elements of U, because of fill-in resulting from the row */ +/* > interchanges. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgbtf2_(integer *m, integer *n, integer *kl, integer *ku, + doublecomplex *ab, integer *ldab, integer *ipiv, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; + doublecomplex z__1; + + /* Local variables */ + integer i__, j; + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *), zgeru_(integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, integer *), zswap_(integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + integer km, jp, ju, kv; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer izamax_(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 */ + + +/* ===================================================================== */ + + +/* KV is the number of superdiagonals in the factor U, allowing for */ +/* fill-in. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --ipiv; + + /* Function Body */ + kv = *ku + *kl; + +/* Test the input parameters. */ + + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0) { + *info = -3; + } else if (*ku < 0) { + *info = -4; + } else if (*ldab < *kl + kv + 1) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGBTF2", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Gaussian elimination with partial pivoting */ + +/* Set fill-in elements in columns KU+2 to KV to zero. */ + + i__1 = f2cmin(kv,*n); + for (j = *ku + 2; j <= i__1; ++j) { + i__2 = *kl; + for (i__ = kv - j + 2; i__ <= i__2; ++i__) { + i__3 = i__ + j * ab_dim1; + ab[i__3].r = 0., ab[i__3].i = 0.; +/* L10: */ + } +/* L20: */ + } + +/* JU is the index of the last column affected by the current stage */ +/* of the factorization. */ + + ju = 1; + + i__1 = f2cmin(*m,*n); + for (j = 1; j <= i__1; ++j) { + +/* Set fill-in elements in column J+KV to zero. */ + + if (j + kv <= *n) { + i__2 = *kl; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + (j + kv) * ab_dim1; + ab[i__3].r = 0., ab[i__3].i = 0.; +/* L30: */ + } + } + +/* Find pivot and test for singularity. KM is the number of */ +/* subdiagonal elements in the current column. */ + +/* Computing MIN */ + i__2 = *kl, i__3 = *m - j; + km = f2cmin(i__2,i__3); + i__2 = km + 1; + jp = izamax_(&i__2, &ab[kv + 1 + j * ab_dim1], &c__1); + ipiv[j] = jp + j - 1; + i__2 = kv + jp + j * ab_dim1; + if (ab[i__2].r != 0. || ab[i__2].i != 0.) { +/* Computing MAX */ +/* Computing MIN */ + i__4 = j + *ku + jp - 1; + i__2 = ju, i__3 = f2cmin(i__4,*n); + ju = f2cmax(i__2,i__3); + +/* Apply interchange to columns J to JU. */ + + if (jp != 1) { + i__2 = ju - j + 1; + i__3 = *ldab - 1; + i__4 = *ldab - 1; + zswap_(&i__2, &ab[kv + jp + j * ab_dim1], &i__3, &ab[kv + 1 + + j * ab_dim1], &i__4); + } + if (km > 0) { + +/* Compute multipliers. */ + + z_div(&z__1, &c_b1, &ab[kv + 1 + j * ab_dim1]); + zscal_(&km, &z__1, &ab[kv + 2 + j * ab_dim1], &c__1); + +/* Update trailing submatrix within the band. */ + + if (ju > j) { + i__2 = ju - j; + z__1.r = -1., z__1.i = 0.; + i__3 = *ldab - 1; + i__4 = *ldab - 1; + zgeru_(&km, &i__2, &z__1, &ab[kv + 2 + j * ab_dim1], & + c__1, &ab[kv + (j + 1) * ab_dim1], &i__3, &ab[kv + + 1 + (j + 1) * ab_dim1], &i__4); + } + } + } else { + +/* If pivot is zero, set INFO to the index of the pivot */ +/* unless a zero pivot has already been found. */ + + if (*info == 0) { + *info = j; + } + } +/* L40: */ + } + return 0; + +/* End of ZGBTF2 */ + +} /* zgbtf2_ */ + diff --git a/lapack-netlib/SRC/zgbtrf.c b/lapack-netlib/SRC/zgbtrf.c new file mode 100644 index 000000000..894b58a3f --- /dev/null +++ b/lapack-netlib/SRC/zgbtrf.c @@ -0,0 +1,1035 @@ +/* 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 ZGBTRF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGBTRF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) */ + +/* INTEGER INFO, KL, KU, LDAB, M, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 AB( LDAB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGBTRF computes an LU factorization of a complex m-by-n band matrix A */ +/* > using partial pivoting with row interchanges. */ +/* > */ +/* > This is the blocked version of the algorithm, calling Level 3 BLAS. */ +/* > \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 KL+1 to */ +/* > 2*KL+KU+1; rows 1 to KL of the array need not be set. */ +/* > The j-th column of A is stored in the j-th column of the */ +/* > array AB as follows: */ +/* > AB(kl+ku+1+i-j,j) = A(i,j) for f2cmax(1,j-ku)<=i<=f2cmin(m,j+kl) */ +/* > */ +/* > On exit, details of the factorization: U is stored as an */ +/* > upper triangular band matrix with KL+KU superdiagonals in */ +/* > rows 1 to KL+KU+1, and the multipliers used during the */ +/* > factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */ +/* > See below for further details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (f2cmin(M,N)) */ +/* > The pivot indices; for 1 <= i <= f2cmin(M,N), row i of the */ +/* > matrix was interchanged with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = +i, U(i,i) is exactly zero. The factorization */ +/* > has been completed, but the factor U is exactly */ +/* > singular, and division by zero will occur if it is used */ +/* > to solve a system of equations. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GBcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The band storage scheme is illustrated by the following example, when */ +/* > M = N = 6, KL = 2, KU = 1: */ +/* > */ +/* > On entry: On exit: */ +/* > */ +/* > * * * + + + * * * u14 u25 u36 */ +/* > * * + + + + * * u13 u24 u35 u46 */ +/* > * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */ +/* > a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */ +/* > a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */ +/* > a31 a42 a53 a64 * * m31 m42 m53 m64 * * */ +/* > */ +/* > Array elements marked * are not used by the routine; elements marked */ +/* > + need not be set on entry, but are required by the routine to store */ +/* > elements of U because of fill-in resulting from the row interchanges. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgbtrf_(integer *m, integer *n, integer *kl, integer *ku, + doublecomplex *ab, integer *ldab, integer *ipiv, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6; + doublecomplex z__1; + + /* Local variables */ + doublecomplex temp; + integer i__, j; + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *), zgemm_(char *, char *, integer *, + integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + doublecomplex work13[4160] /* was [65][64] */, work31[4160] /* + was [65][64] */; + integer i2, i3, j2, j3, k2; + extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zcopy_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *), zswap_(integer *, + doublecomplex *, integer *, doublecomplex *, integer *), ztrsm_( + char *, char *, char *, char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *), zgbtf2_(integer *, + integer *, integer *, integer *, doublecomplex *, integer *, + integer *, integer *); + integer jb, nb, ii, jj, jm, ip, jp, km, ju, kv, nw; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen), izamax_(integer *, + doublecomplex *, integer *); + extern /* Subroutine */ int zlaswp_(integer *, doublecomplex *, integer *, + integer *, integer *, integer *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* KV is the number of superdiagonals in the factor U, allowing for */ +/* fill-in */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --ipiv; + + /* Function Body */ + kv = *ku + *kl; + +/* Test the input parameters. */ + + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0) { + *info = -3; + } else if (*ku < 0) { + *info = -4; + } else if (*ldab < *kl + kv + 1) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGBTRF", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Determine the block size for this environment */ + + nb = ilaenv_(&c__1, "ZGBTRF", " ", m, n, kl, ku, (ftnlen)6, (ftnlen)1); + +/* The block size must not exceed the limit set by the size of the */ +/* local arrays WORK13 and WORK31. */ + + nb = f2cmin(nb,64); + + if (nb <= 1 || nb > *kl) { + +/* Use unblocked code */ + + zgbtf2_(m, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info); + } else { + +/* Use blocked code */ + +/* Zero the superdiagonal elements of the work array WORK13 */ + + i__1 = nb; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * 65 - 66; + work13[i__3].r = 0., work13[i__3].i = 0.; +/* L10: */ + } +/* L20: */ + } + +/* Zero the subdiagonal elements of the work array WORK31 */ + + i__1 = nb; + for (j = 1; j <= i__1; ++j) { + i__2 = nb; + for (i__ = j + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * 65 - 66; + work31[i__3].r = 0., work31[i__3].i = 0.; +/* L30: */ + } +/* L40: */ + } + +/* Gaussian elimination with partial pivoting */ + +/* Set fill-in elements in columns KU+2 to KV to zero */ + + i__1 = f2cmin(kv,*n); + for (j = *ku + 2; j <= i__1; ++j) { + i__2 = *kl; + for (i__ = kv - j + 2; i__ <= i__2; ++i__) { + i__3 = i__ + j * ab_dim1; + ab[i__3].r = 0., ab[i__3].i = 0.; +/* L50: */ + } +/* L60: */ + } + +/* JU is the index of the last column affected by the current */ +/* stage of the factorization */ + + ju = 1; + + i__1 = f2cmin(*m,*n); + i__2 = nb; + for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = nb, i__4 = f2cmin(*m,*n) - j + 1; + jb = f2cmin(i__3,i__4); + +/* The active part of the matrix is partitioned */ + +/* A11 A12 A13 */ +/* A21 A22 A23 */ +/* A31 A32 A33 */ + +/* Here A11, A21 and A31 denote the current block of JB columns */ +/* which is about to be factorized. The number of rows in the */ +/* partitioning are JB, I2, I3 respectively, and the numbers */ +/* of columns are JB, J2, J3. The superdiagonal elements of A13 */ +/* and the subdiagonal elements of A31 lie outside the band. */ + +/* Computing MIN */ + i__3 = *kl - jb, i__4 = *m - j - jb + 1; + i2 = f2cmin(i__3,i__4); +/* Computing MIN */ + i__3 = jb, i__4 = *m - j - *kl + 1; + i3 = f2cmin(i__3,i__4); + +/* J2 and J3 are computed after JU has been updated. */ + +/* Factorize the current block of JB columns */ + + i__3 = j + jb - 1; + for (jj = j; jj <= i__3; ++jj) { + +/* Set fill-in elements in column JJ+KV to zero */ + + if (jj + kv <= *n) { + i__4 = *kl; + for (i__ = 1; i__ <= i__4; ++i__) { + i__5 = i__ + (jj + kv) * ab_dim1; + ab[i__5].r = 0., ab[i__5].i = 0.; +/* L70: */ + } + } + +/* Find pivot and test for singularity. KM is the number of */ +/* subdiagonal elements in the current column. */ + +/* Computing MIN */ + i__4 = *kl, i__5 = *m - jj; + km = f2cmin(i__4,i__5); + i__4 = km + 1; + jp = izamax_(&i__4, &ab[kv + 1 + jj * ab_dim1], &c__1); + ipiv[jj] = jp + jj - j; + i__4 = kv + jp + jj * ab_dim1; + if (ab[i__4].r != 0. || ab[i__4].i != 0.) { +/* Computing MAX */ +/* Computing MIN */ + i__6 = jj + *ku + jp - 1; + i__4 = ju, i__5 = f2cmin(i__6,*n); + ju = f2cmax(i__4,i__5); + if (jp != 1) { + +/* Apply interchange to columns J to J+JB-1 */ + + if (jp + jj - 1 < j + *kl) { + + i__4 = *ldab - 1; + i__5 = *ldab - 1; + zswap_(&jb, &ab[kv + 1 + jj - j + j * ab_dim1], & + i__4, &ab[kv + jp + jj - j + j * ab_dim1], + &i__5); + } else { + +/* The interchange affects columns J to JJ-1 of A31 */ +/* which are stored in the work array WORK31 */ + + i__4 = jj - j; + i__5 = *ldab - 1; + zswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], + &i__5, &work31[jp + jj - j - *kl - 1], & + c__65); + i__4 = j + jb - jj; + i__5 = *ldab - 1; + i__6 = *ldab - 1; + zswap_(&i__4, &ab[kv + 1 + jj * ab_dim1], &i__5, & + ab[kv + jp + jj * ab_dim1], &i__6); + } + } + +/* Compute multipliers */ + + z_div(&z__1, &c_b1, &ab[kv + 1 + jj * ab_dim1]); + zscal_(&km, &z__1, &ab[kv + 2 + jj * ab_dim1], &c__1); + +/* Update trailing submatrix within the band and within */ +/* the current block. JM is the index of the last column */ +/* which needs to be updated. */ + +/* Computing MIN */ + i__4 = ju, i__5 = j + jb - 1; + jm = f2cmin(i__4,i__5); + if (jm > jj) { + i__4 = jm - jj; + z__1.r = -1., z__1.i = 0.; + i__5 = *ldab - 1; + i__6 = *ldab - 1; + zgeru_(&km, &i__4, &z__1, &ab[kv + 2 + jj * ab_dim1], + &c__1, &ab[kv + (jj + 1) * ab_dim1], &i__5, & + ab[kv + 1 + (jj + 1) * ab_dim1], &i__6); + } + } else { + +/* If pivot is zero, set INFO to the index of the pivot */ +/* unless a zero pivot has already been found. */ + + if (*info == 0) { + *info = jj; + } + } + +/* Copy current column of A31 into the work array WORK31 */ + +/* Computing MIN */ + i__4 = jj - j + 1; + nw = f2cmin(i__4,i3); + if (nw > 0) { + zcopy_(&nw, &ab[kv + *kl + 1 - jj + j + jj * ab_dim1], & + c__1, &work31[(jj - j + 1) * 65 - 65], &c__1); + } +/* L80: */ + } + if (j + jb <= *n) { + +/* Apply the row interchanges to the other blocks. */ + +/* Computing MIN */ + i__3 = ju - j + 1; + j2 = f2cmin(i__3,kv) - jb; +/* Computing MAX */ + i__3 = 0, i__4 = ju - j - kv + 1; + j3 = f2cmax(i__3,i__4); + +/* Use ZLASWP to apply the row interchanges to A12, A22, and */ +/* A32. */ + + i__3 = *ldab - 1; + zlaswp_(&j2, &ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__3, & + c__1, &jb, &ipiv[j], &c__1); + +/* Adjust the pivot indices. */ + + i__3 = j + jb - 1; + for (i__ = j; i__ <= i__3; ++i__) { + ipiv[i__] = ipiv[i__] + j - 1; +/* L90: */ + } + +/* Apply the row interchanges to A13, A23, and A33 */ +/* columnwise. */ + + k2 = j - 1 + jb + j2; + i__3 = j3; + for (i__ = 1; i__ <= i__3; ++i__) { + jj = k2 + i__; + i__4 = j + jb - 1; + for (ii = j + i__ - 1; ii <= i__4; ++ii) { + ip = ipiv[ii]; + if (ip != ii) { + i__5 = kv + 1 + ii - jj + jj * ab_dim1; + temp.r = ab[i__5].r, temp.i = ab[i__5].i; + i__5 = kv + 1 + ii - jj + jj * ab_dim1; + i__6 = kv + 1 + ip - jj + jj * ab_dim1; + ab[i__5].r = ab[i__6].r, ab[i__5].i = ab[i__6].i; + i__5 = kv + 1 + ip - jj + jj * ab_dim1; + ab[i__5].r = temp.r, ab[i__5].i = temp.i; + } +/* L100: */ + } +/* L110: */ + } + +/* Update the relevant part of the trailing submatrix */ + + if (j2 > 0) { + +/* Update A12 */ + + i__3 = *ldab - 1; + i__4 = *ldab - 1; + ztrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j2, + &c_b1, &ab[kv + 1 + j * ab_dim1], &i__3, &ab[kv + + 1 - jb + (j + jb) * ab_dim1], &i__4); + + if (i2 > 0) { + +/* Update A22 */ + + z__1.r = -1., z__1.i = 0.; + i__3 = *ldab - 1; + i__4 = *ldab - 1; + i__5 = *ldab - 1; + zgemm_("No transpose", "No transpose", &i2, &j2, &jb, + &z__1, &ab[kv + 1 + jb + j * ab_dim1], &i__3, + &ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__4, + &c_b1, &ab[kv + 1 + (j + jb) * ab_dim1], & + i__5); + } + + if (i3 > 0) { + +/* Update A32 */ + + z__1.r = -1., z__1.i = 0.; + i__3 = *ldab - 1; + i__4 = *ldab - 1; + zgemm_("No transpose", "No transpose", &i3, &j2, &jb, + &z__1, work31, &c__65, &ab[kv + 1 - jb + (j + + jb) * ab_dim1], &i__3, &c_b1, &ab[kv + *kl + + 1 - jb + (j + jb) * ab_dim1], &i__4); + } + } + + if (j3 > 0) { + +/* Copy the lower triangle of A13 into the work array */ +/* WORK13 */ + + i__3 = j3; + for (jj = 1; jj <= i__3; ++jj) { + i__4 = jb; + for (ii = jj; ii <= i__4; ++ii) { + i__5 = ii + jj * 65 - 66; + i__6 = ii - jj + 1 + (jj + j + kv - 1) * ab_dim1; + work13[i__5].r = ab[i__6].r, work13[i__5].i = ab[ + i__6].i; +/* L120: */ + } +/* L130: */ + } + +/* Update A13 in the work array */ + + i__3 = *ldab - 1; + ztrsm_("Left", "Lower", "No transpose", "Unit", &jb, &j3, + &c_b1, &ab[kv + 1 + j * ab_dim1], &i__3, work13, & + c__65); + + if (i2 > 0) { + +/* Update A23 */ + + z__1.r = -1., z__1.i = 0.; + i__3 = *ldab - 1; + i__4 = *ldab - 1; + zgemm_("No transpose", "No transpose", &i2, &j3, &jb, + &z__1, &ab[kv + 1 + jb + j * ab_dim1], &i__3, + work13, &c__65, &c_b1, &ab[jb + 1 + (j + kv) * + ab_dim1], &i__4); + } + + if (i3 > 0) { + +/* Update A33 */ + + z__1.r = -1., z__1.i = 0.; + i__3 = *ldab - 1; + zgemm_("No transpose", "No transpose", &i3, &j3, &jb, + &z__1, work31, &c__65, work13, &c__65, &c_b1, + &ab[*kl + 1 + (j + kv) * ab_dim1], &i__3); + } + +/* Copy the lower triangle of A13 back into place */ + + i__3 = j3; + for (jj = 1; jj <= i__3; ++jj) { + i__4 = jb; + for (ii = jj; ii <= i__4; ++ii) { + i__5 = ii - jj + 1 + (jj + j + kv - 1) * ab_dim1; + i__6 = ii + jj * 65 - 66; + ab[i__5].r = work13[i__6].r, ab[i__5].i = work13[ + i__6].i; +/* L140: */ + } +/* L150: */ + } + } + } else { + +/* Adjust the pivot indices. */ + + i__3 = j + jb - 1; + for (i__ = j; i__ <= i__3; ++i__) { + ipiv[i__] = ipiv[i__] + j - 1; +/* L160: */ + } + } + +/* Partially undo the interchanges in the current block to */ +/* restore the upper triangular form of A31 and copy the upper */ +/* triangle of A31 back into place */ + + i__3 = j; + for (jj = j + jb - 1; jj >= i__3; --jj) { + jp = ipiv[jj] - jj + 1; + if (jp != 1) { + +/* Apply interchange to columns J to JJ-1 */ + + if (jp + jj - 1 < j + *kl) { + +/* The interchange does not affect A31 */ + + i__4 = jj - j; + i__5 = *ldab - 1; + i__6 = *ldab - 1; + zswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], & + i__5, &ab[kv + jp + jj - j + j * ab_dim1], & + i__6); + } else { + +/* The interchange does affect A31 */ + + i__4 = jj - j; + i__5 = *ldab - 1; + zswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], & + i__5, &work31[jp + jj - j - *kl - 1], &c__65); + } + } + +/* Copy the current column of A31 back into place */ + +/* Computing MIN */ + i__4 = i3, i__5 = jj - j + 1; + nw = f2cmin(i__4,i__5); + if (nw > 0) { + zcopy_(&nw, &work31[(jj - j + 1) * 65 - 65], &c__1, &ab[ + kv + *kl + 1 - jj + j + jj * ab_dim1], &c__1); + } +/* L170: */ + } +/* L180: */ + } + } + + return 0; + +/* End of ZGBTRF */ + +} /* zgbtrf_ */ + diff --git a/lapack-netlib/SRC/zgbtrs.c b/lapack-netlib/SRC/zgbtrs.c new file mode 100644 index 000000000..61bfbfa81 --- /dev/null +++ b/lapack-netlib/SRC/zgbtrs.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 ZGBTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGBTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, */ +/* INFO ) */ + +/* CHARACTER TRANS */ +/* INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 AB( LDAB, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGBTRS solves a system of linear equations */ +/* > A * X = B, A**T * X = B, or A**H * X = B */ +/* > with a general band matrix A using the LU factorization computed */ +/* > by ZGBTRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations. */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order 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] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is COMPLEX*16 array, dimension (LDAB,N) */ +/* > Details of the LU factorization of the band matrix A, as */ +/* > computed by ZGBTRF. U is stored as an upper triangular band */ +/* > matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */ +/* > the multipliers used during the factorization are stored in */ +/* > rows KL+KU+2 to 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices; for 1 <= i <= N, row i of the matrix was */ +/* > interchanged with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GBcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zgbtrs_(char *trans, integer *n, integer *kl, integer * + ku, integer *nrhs, doublecomplex *ab, integer *ldab, integer *ipiv, + doublecomplex *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, b_dim1, b_offset, i__1, i__2, i__3; + doublecomplex z__1; + + /* Local variables */ + integer i__, j, l; + extern logical lsame_(char *, char *); + logical lnoti; + extern /* Subroutine */ int zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *), + zgeru_(integer *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *) + , zswap_(integer *, doublecomplex *, integer *, doublecomplex *, + integer *), ztbsv_(char *, char *, char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + integer kd, lm; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zlacgv_( + integer *, doublecomplex *, integer *); + logical notran; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + notran = lsame_(trans, "N"); + if (! notran && ! lsame_(trans, "T") && ! lsame_( + trans, "C")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0) { + *info = -3; + } else if (*ku < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*ldab < (*kl << 1) + *ku + 1) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGBTRS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + + kd = *ku + *kl + 1; + lnoti = *kl > 0; + + if (notran) { + +/* Solve A*X = B. */ + +/* Solve L*X = B, overwriting B with X. */ + +/* L is represented as a product of permutations and unit lower */ +/* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1), */ +/* where each transformation L(i) is a rank-one modification of */ +/* the identity matrix. */ + + if (lnoti) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = *kl, i__3 = *n - j; + lm = f2cmin(i__2,i__3); + l = ipiv[j]; + if (l != j) { + zswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb); + } + z__1.r = -1., z__1.i = 0.; + zgeru_(&lm, nrhs, &z__1, &ab[kd + 1 + j * ab_dim1], &c__1, &b[ + j + b_dim1], ldb, &b[j + 1 + b_dim1], ldb); +/* L10: */ + } + } + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Solve U*X = B, overwriting B with X. */ + + i__2 = *kl + *ku; + ztbsv_("Upper", "No transpose", "Non-unit", n, &i__2, &ab[ + ab_offset], ldab, &b[i__ * b_dim1 + 1], &c__1); +/* L20: */ + } + + } else if (lsame_(trans, "T")) { + +/* Solve A**T * X = B. */ + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Solve U**T * X = B, overwriting B with X. */ + + i__2 = *kl + *ku; + ztbsv_("Upper", "Transpose", "Non-unit", n, &i__2, &ab[ab_offset], + ldab, &b[i__ * b_dim1 + 1], &c__1); +/* L30: */ + } + +/* Solve L**T * X = B, overwriting B with X. */ + + if (lnoti) { + for (j = *n - 1; j >= 1; --j) { +/* Computing MIN */ + i__1 = *kl, i__2 = *n - j; + lm = f2cmin(i__1,i__2); + z__1.r = -1., z__1.i = 0.; + zgemv_("Transpose", &lm, nrhs, &z__1, &b[j + 1 + b_dim1], ldb, + &ab[kd + 1 + j * ab_dim1], &c__1, &c_b1, &b[j + + b_dim1], ldb); + l = ipiv[j]; + if (l != j) { + zswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb); + } +/* L40: */ + } + } + + } else { + +/* Solve A**H * X = B. */ + + i__1 = *nrhs; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Solve U**H * X = B, overwriting B with X. */ + + i__2 = *kl + *ku; + ztbsv_("Upper", "Conjugate transpose", "Non-unit", n, &i__2, &ab[ + ab_offset], ldab, &b[i__ * b_dim1 + 1], &c__1); +/* L50: */ + } + +/* Solve L**H * X = B, overwriting B with X. */ + + if (lnoti) { + for (j = *n - 1; j >= 1; --j) { +/* Computing MIN */ + i__1 = *kl, i__2 = *n - j; + lm = f2cmin(i__1,i__2); + zlacgv_(nrhs, &b[j + b_dim1], ldb); + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &lm, nrhs, &z__1, &b[j + 1 + + b_dim1], ldb, &ab[kd + 1 + j * ab_dim1], &c__1, &c_b1, + &b[j + b_dim1], ldb); + zlacgv_(nrhs, &b[j + b_dim1], ldb); + l = ipiv[j]; + if (l != j) { + zswap_(nrhs, &b[l + b_dim1], ldb, &b[j + b_dim1], ldb); + } +/* L60: */ + } + } + } + return 0; + +/* End of ZGBTRS */ + +} /* zgbtrs_ */ + diff --git a/lapack-netlib/SRC/zgebak.c b/lapack-netlib/SRC/zgebak.c new file mode 100644 index 000000000..b275c5e6f --- /dev/null +++ b/lapack-netlib/SRC/zgebak.c @@ -0,0 +1,675 @@ +/* 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 ZGEBAK */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEBAK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV, */ +/* INFO ) */ + +/* CHARACTER JOB, SIDE */ +/* INTEGER IHI, ILO, INFO, LDV, M, N */ +/* DOUBLE PRECISION SCALE( * ) */ +/* COMPLEX*16 V( LDV, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEBAK forms the right or left eigenvectors of a complex general */ +/* > matrix by backward transformation on the computed eigenvectors of the */ +/* > balanced matrix output by ZGEBAL. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOB */ +/* > \verbatim */ +/* > JOB is CHARACTER*1 */ +/* > Specifies the type of backward transformation required: */ +/* > = 'N': do nothing, return immediately; */ +/* > = 'P': do backward transformation for permutation only; */ +/* > = 'S': do backward transformation for scaling only; */ +/* > = 'B': do backward transformations for both permutation and */ +/* > scaling. */ +/* > JOB must be the same as the argument JOB supplied to ZGEBAL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'R': V contains right eigenvectors; */ +/* > = 'L': V contains left eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of rows of the matrix V. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILO */ +/* > \verbatim */ +/* > ILO is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHI */ +/* > \verbatim */ +/* > IHI is INTEGER */ +/* > The integers ILO and IHI determined by ZGEBAL. */ +/* > 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SCALE */ +/* > \verbatim */ +/* > SCALE is DOUBLE PRECISION array, dimension (N) */ +/* > Details of the permutation and scaling factors, as returned */ +/* > by ZGEBAL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of columns of the matrix V. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] V */ +/* > \verbatim */ +/* > V is COMPLEX*16 array, dimension (LDV,M) */ +/* > On entry, the matrix of right or left eigenvectors to be */ +/* > transformed, as returned by ZHSEIN or ZTREVC. */ +/* > On exit, V is overwritten by the transformed eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. LDV >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GEcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zgebak_(char *job, char *side, integer *n, integer *ilo, + integer *ihi, doublereal *scale, integer *m, doublecomplex *v, + integer *ldv, integer *info) +{ + /* System generated locals */ + integer v_dim1, v_offset, i__1; + + /* Local variables */ + integer i__, k; + doublereal s; + extern logical lsame_(char *, char *); + logical leftv; + extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + integer ii; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zdscal_( + integer *, doublereal *, doublecomplex *, integer *); + logical rightv; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and Test the input parameters */ + + /* Parameter adjustments */ + --scale; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + + /* Function Body */ + rightv = lsame_(side, "R"); + leftv = lsame_(side, "L"); + + *info = 0; + if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S") + && ! lsame_(job, "B")) { + *info = -1; + } else if (! rightv && ! leftv) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ilo < 1 || *ilo > f2cmax(1,*n)) { + *info = -4; + } else if (*ihi < f2cmin(*ilo,*n) || *ihi > *n) { + *info = -5; + } else if (*m < 0) { + *info = -7; + } else if (*ldv < f2cmax(1,*n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEBAK", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + if (*m == 0) { + return 0; + } + if (lsame_(job, "N")) { + return 0; + } + + if (*ilo == *ihi) { + goto L30; + } + +/* Backward balance */ + + if (lsame_(job, "S") || lsame_(job, "B")) { + + if (rightv) { + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + s = scale[i__]; + zdscal_(m, &s, &v[i__ + v_dim1], ldv); +/* L10: */ + } + } + + if (leftv) { + i__1 = *ihi; + for (i__ = *ilo; i__ <= i__1; ++i__) { + s = 1. / scale[i__]; + zdscal_(m, &s, &v[i__ + v_dim1], ldv); +/* L20: */ + } + } + + } + +/* Backward permutation */ + +/* For I = ILO-1 step -1 until 1, */ +/* IHI+1 step 1 until N do -- */ + +L30: + if (lsame_(job, "P") || lsame_(job, "B")) { + if (rightv) { + i__1 = *n; + for (ii = 1; ii <= i__1; ++ii) { + i__ = ii; + if (i__ >= *ilo && i__ <= *ihi) { + goto L40; + } + if (i__ < *ilo) { + i__ = *ilo - ii; + } + k = (integer) scale[i__]; + if (k == i__) { + goto L40; + } + zswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv); +L40: + ; + } + } + + if (leftv) { + i__1 = *n; + for (ii = 1; ii <= i__1; ++ii) { + i__ = ii; + if (i__ >= *ilo && i__ <= *ihi) { + goto L50; + } + if (i__ < *ilo) { + i__ = *ilo - ii; + } + k = (integer) scale[i__]; + if (k == i__) { + goto L50; + } + zswap_(m, &v[i__ + v_dim1], ldv, &v[k + v_dim1], ldv); +L50: + ; + } + } + } + + return 0; + +/* End of ZGEBAK */ + +} /* zgebak_ */ + diff --git a/lapack-netlib/SRC/zgebal.c b/lapack-netlib/SRC/zgebal.c new file mode 100644 index 000000000..793ef2458 --- /dev/null +++ b/lapack-netlib/SRC/zgebal.c @@ -0,0 +1,844 @@ +/* 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 ZGEBAL */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEBAL + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO ) */ + +/* CHARACTER JOB */ +/* INTEGER IHI, ILO, INFO, LDA, N */ +/* DOUBLE PRECISION SCALE( * ) */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEBAL balances a general complex matrix A. This involves, first, */ +/* > permuting A by a similarity transformation to isolate eigenvalues */ +/* > in the first 1 to ILO-1 and last IHI+1 to N elements on the */ +/* > diagonal; and second, applying a diagonal similarity transformation */ +/* > to rows and columns ILO to IHI to make the rows and columns as */ +/* > close in norm as possible. Both steps are optional. */ +/* > */ +/* > Balancing may reduce the 1-norm of the matrix, and improve the */ +/* > accuracy of the computed eigenvalues and/or eigenvectors. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOB */ +/* > \verbatim */ +/* > JOB is CHARACTER*1 */ +/* > Specifies the operations to be performed on A: */ +/* > = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0 */ +/* > for i = 1,...,N; */ +/* > = 'P': permute only; */ +/* > = 'S': scale only; */ +/* > = 'B': both permute and scale. */ +/* > \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 input matrix A. */ +/* > On exit, A is overwritten by the balanced matrix. */ +/* > If JOB = 'N', A is not referenced. */ +/* > 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] ILO */ +/* > \verbatim */ +/* > ILO is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IHI */ +/* > \verbatim */ +/* > IHI is INTEGER */ +/* > ILO and IHI are set to INTEGER such that on exit */ +/* > A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N. */ +/* > If JOB = 'N' or 'S', ILO = 1 and IHI = N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE */ +/* > \verbatim */ +/* > SCALE is DOUBLE PRECISION array, dimension (N) */ +/* > Details of the permutations and scaling factors applied to */ +/* > A. If P(j) is the index of the row and column interchanged */ +/* > with row and column j and D(j) is the scaling factor */ +/* > applied to row and column j, then */ +/* > SCALE(j) = P(j) for j = 1,...,ILO-1 */ +/* > = D(j) for j = ILO,...,IHI */ +/* > = P(j) for j = IHI+1,...,N. */ +/* > The order in which the interchanges are made is N to IHI+1, */ +/* > then 1 to ILO-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 2017 */ + +/* > \ingroup complex16GEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The permutations consist of row and column interchanges which put */ +/* > the matrix in the form */ +/* > */ +/* > ( T1 X Y ) */ +/* > P A P = ( 0 B Z ) */ +/* > ( 0 0 T2 ) */ +/* > */ +/* > where T1 and T2 are upper triangular matrices whose eigenvalues lie */ +/* > along the diagonal. The column indices ILO and IHI mark the starting */ +/* > and ending columns of the submatrix B. Balancing consists of applying */ +/* > a diagonal similarity transformation inv(D) * B * D to make the */ +/* > 1-norms of each row of B and its corresponding column nearly equal. */ +/* > The output matrix is */ +/* > */ +/* > ( T1 X*D Y ) */ +/* > ( 0 inv(D)*B*D inv(D)*Z ). */ +/* > ( 0 0 T2 ) */ +/* > */ +/* > Information about the permutations P and the diagonal matrix D is */ +/* > returned in the vector SCALE. */ +/* > */ +/* > This subroutine is based on the EISPACK routine CBAL. */ +/* > */ +/* > Modified by Tzu-Yi Chen, Computer Science Division, University of */ +/* > California at Berkeley, USA */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgebal_(char *job, integer *n, doublecomplex *a, integer + *lda, integer *ilo, integer *ihi, doublereal *scale, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1, d__2; + + /* Local variables */ + integer iexc; + doublereal c__, f, g; + integer i__, j, k, l, m; + doublereal r__, s; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + doublereal sfmin1, sfmin2, sfmax1, sfmax2, ca; + extern doublereal dznrm2_(integer *, doublecomplex *, integer *); + doublereal ra; + extern doublereal dlamch_(char *); + extern logical disnan_(doublereal *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zdscal_( + integer *, doublereal *, doublecomplex *, integer *); + extern integer izamax_(integer *, doublecomplex *, integer *); + logical noconv; + integer ica, ira; + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --scale; + + /* Function Body */ + *info = 0; + if (! lsame_(job, "N") && ! lsame_(job, "P") && ! lsame_(job, "S") + && ! lsame_(job, "B")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEBAL", &i__1, (ftnlen)6); + return 0; + } + + k = 1; + l = *n; + + if (*n == 0) { + goto L210; + } + + if (lsame_(job, "N")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + scale[i__] = 1.; +/* L10: */ + } + goto L210; + } + + if (lsame_(job, "S")) { + goto L120; + } + +/* Permutation to isolate eigenvalues if possible */ + + goto L50; + +/* Row and column exchange. */ + +L20: + scale[m] = (doublereal) j; + if (j == m) { + goto L30; + } + + zswap_(&l, &a[j * a_dim1 + 1], &c__1, &a[m * a_dim1 + 1], &c__1); + i__1 = *n - k + 1; + zswap_(&i__1, &a[j + k * a_dim1], lda, &a[m + k * a_dim1], lda); + +L30: + switch (iexc) { + case 1: goto L40; + case 2: goto L80; + } + +/* Search for rows isolating an eigenvalue and push them down. */ + +L40: + if (l == 1) { + goto L210; + } + --l; + +L50: + for (j = l; j >= 1; --j) { + + i__1 = l; + for (i__ = 1; i__ <= i__1; ++i__) { + if (i__ == j) { + goto L60; + } + i__2 = j + i__ * a_dim1; + if (a[i__2].r != 0. || d_imag(&a[j + i__ * a_dim1]) != 0.) { + goto L70; + } +L60: + ; + } + + m = l; + iexc = 1; + goto L20; +L70: + ; + } + + goto L90; + +/* Search for columns isolating an eigenvalue and push them left. */ + +L80: + ++k; + +L90: + i__1 = l; + for (j = k; j <= i__1; ++j) { + + i__2 = l; + for (i__ = k; i__ <= i__2; ++i__) { + if (i__ == j) { + goto L100; + } + i__3 = i__ + j * a_dim1; + if (a[i__3].r != 0. || d_imag(&a[i__ + j * a_dim1]) != 0.) { + goto L110; + } +L100: + ; + } + + m = k; + iexc = 2; + goto L20; +L110: + ; + } + +L120: + i__1 = l; + for (i__ = k; i__ <= i__1; ++i__) { + scale[i__] = 1.; +/* L130: */ + } + + if (lsame_(job, "P")) { + goto L210; + } + +/* Balance the submatrix in rows K to L. */ + +/* Iterative loop for norm reduction */ + + sfmin1 = dlamch_("S") / dlamch_("P"); + sfmax1 = 1. / sfmin1; + sfmin2 = sfmin1 * 2.; + sfmax2 = 1. / sfmin2; +L140: + noconv = FALSE_; + + i__1 = l; + for (i__ = k; i__ <= i__1; ++i__) { + + i__2 = l - k + 1; + c__ = dznrm2_(&i__2, &a[k + i__ * a_dim1], &c__1); + i__2 = l - k + 1; + r__ = dznrm2_(&i__2, &a[i__ + k * a_dim1], lda); + ica = izamax_(&l, &a[i__ * a_dim1 + 1], &c__1); + ca = z_abs(&a[ica + i__ * a_dim1]); + i__2 = *n - k + 1; + ira = izamax_(&i__2, &a[i__ + k * a_dim1], lda); + ra = z_abs(&a[i__ + (ira + k - 1) * a_dim1]); + +/* Guard against zero C or R due to underflow. */ + + if (c__ == 0. || r__ == 0.) { + goto L200; + } + g = r__ / 2.; + f = 1.; + s = c__ + r__; +L160: +/* Computing MAX */ + d__1 = f2cmax(f,c__); +/* Computing MIN */ + d__2 = f2cmin(r__,g); + if (c__ >= g || f2cmax(d__1,ca) >= sfmax2 || f2cmin(d__2,ra) <= sfmin2) { + goto L170; + } + d__1 = c__ + f + ca + r__ + g + ra; + if (disnan_(&d__1)) { + +/* Exit if NaN to avoid infinite loop */ + + *info = -3; + i__2 = -(*info); + xerbla_("ZGEBAL", &i__2, (ftnlen)6); + return 0; + } + f *= 2.; + c__ *= 2.; + ca *= 2.; + r__ /= 2.; + g /= 2.; + ra /= 2.; + goto L160; + +L170: + g = c__ / 2.; +L180: +/* Computing MIN */ + d__1 = f2cmin(f,c__), d__1 = f2cmin(d__1,g); + if (g < r__ || f2cmax(r__,ra) >= sfmax2 || f2cmin(d__1,ca) <= sfmin2) { + goto L190; + } + f /= 2.; + c__ /= 2.; + g /= 2.; + ca /= 2.; + r__ *= 2.; + ra *= 2.; + goto L180; + +/* Now balance. */ + +L190: + if (c__ + r__ >= s * .95) { + goto L200; + } + if (f < 1. && scale[i__] < 1.) { + if (f * scale[i__] <= sfmin1) { + goto L200; + } + } + if (f > 1. && scale[i__] > 1.) { + if (scale[i__] >= sfmax1 / f) { + goto L200; + } + } + g = 1. / f; + scale[i__] *= f; + noconv = TRUE_; + + i__2 = *n - k + 1; + zdscal_(&i__2, &g, &a[i__ + k * a_dim1], lda); + zdscal_(&l, &f, &a[i__ * a_dim1 + 1], &c__1); + +L200: + ; + } + + if (noconv) { + goto L140; + } + +L210: + *ilo = k; + *ihi = l; + + return 0; + +/* End of ZGEBAL */ + +} /* zgebal_ */ + diff --git a/lapack-netlib/SRC/zgebd2.c b/lapack-netlib/SRC/zgebd2.c new file mode 100644 index 000000000..652a08751 --- /dev/null +++ b/lapack-netlib/SRC/zgebd2.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 ZGEBD2 reduces a general matrix to bidiagonal form using an unblocked algorithm. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEBD2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO ) */ + +/* INTEGER INFO, LDA, M, N */ +/* DOUBLE PRECISION D( * ), E( * ) */ +/* COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEBD2 reduces a complex general m by n matrix A to upper or lower */ +/* > real bidiagonal form B by a unitary transformation: Q**H * A * P = B. */ +/* > */ +/* > If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows in the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns in 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 general matrix to be reduced. */ +/* > On exit, */ +/* > if m >= n, the diagonal and the first superdiagonal are */ +/* > overwritten with the upper bidiagonal matrix B; the */ +/* > elements below the diagonal, with the array TAUQ, represent */ +/* > the unitary matrix Q as a product of elementary */ +/* > reflectors, and the elements above the first superdiagonal, */ +/* > with the array TAUP, represent the unitary matrix P as */ +/* > a product of elementary reflectors; */ +/* > if m < n, the diagonal and the first subdiagonal are */ +/* > overwritten with the lower bidiagonal matrix B; the */ +/* > elements below the first subdiagonal, with the array TAUQ, */ +/* > represent the unitary matrix Q as a product of */ +/* > elementary reflectors, and the elements above the diagonal, */ +/* > with the array TAUP, represent the unitary matrix P as */ +/* > a product of elementary reflectors. */ +/* > See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (f2cmin(M,N)) */ +/* > The diagonal elements of the bidiagonal matrix B: */ +/* > D(i) = A(i,i). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (f2cmin(M,N)-1) */ +/* > The off-diagonal elements of the bidiagonal matrix B: */ +/* > if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */ +/* > if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUQ */ +/* > \verbatim */ +/* > TAUQ is COMPLEX*16 array, dimension (f2cmin(M,N)) */ +/* > The scalar factors of the elementary reflectors which */ +/* > represent the unitary matrix Q. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUP */ +/* > \verbatim */ +/* > TAUP is COMPLEX*16 array, dimension (f2cmin(M,N)) */ +/* > The scalar factors of the elementary reflectors which */ +/* > represent the unitary matrix P. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (f2cmax(M,N)) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup complex16GEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrices Q and P are represented as products of elementary */ +/* > reflectors: */ +/* > */ +/* > If m >= n, */ +/* > */ +/* > Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */ +/* > */ +/* > Each H(i) and G(i) has the form: */ +/* > */ +/* > H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H */ +/* > */ +/* > where tauq and taup are complex scalars, and v and u are complex */ +/* > vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in */ +/* > A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in */ +/* > A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */ +/* > */ +/* > If m < n, */ +/* > */ +/* > Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */ +/* > */ +/* > Each H(i) and G(i) has the form: */ +/* > */ +/* > H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H */ +/* > */ +/* > where tauq and taup are complex scalars, v and u are complex vectors; */ +/* > v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i); */ +/* > u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n); */ +/* > tauq is stored in TAUQ(i) and taup in TAUP(i). */ +/* > */ +/* > The contents of A on exit are illustrated by the following examples: */ +/* > */ +/* > m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */ +/* > */ +/* > ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */ +/* > ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */ +/* > ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */ +/* > ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */ +/* > ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */ +/* > ( v1 v2 v3 v4 v5 ) */ +/* > */ +/* > where d and e denote diagonal and off-diagonal elements of B, vi */ +/* > denotes an element of the vector defining H(i), and ui an element of */ +/* > the vector defining G(i). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgebd2_(integer *m, integer *n, doublecomplex *a, + integer *lda, doublereal *d__, doublereal *e, doublecomplex *tauq, + doublecomplex *taup, doublecomplex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublecomplex z__1; + + /* Local variables */ + integer i__; + doublecomplex alpha; + extern /* Subroutine */ int zlarf_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *), xerbla_(char *, integer *, ftnlen), zlarfg_(integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *), zlacgv_(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 parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --d__; + --e; + --tauq; + --taup; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + if (*info < 0) { + i__1 = -(*info); + xerbla_("ZGEBD2", &i__1, (ftnlen)6); + return 0; + } + + if (*m >= *n) { + +/* Reduce to upper bidiagonal form */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */ + + i__2 = i__ + i__ * a_dim1; + alpha.r = a[i__2].r, alpha.i = a[i__2].i; + i__2 = *m - i__ + 1; +/* Computing MIN */ + i__3 = i__ + 1; + zlarfg_(&i__2, &alpha, &a[f2cmin(i__3,*m) + i__ * a_dim1], &c__1, & + tauq[i__]); + i__2 = i__; + d__[i__2] = alpha.r; + i__2 = i__ + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + +/* Apply H(i)**H to A(i:m,i+1:n) from the left */ + + if (i__ < *n) { + i__2 = *m - i__ + 1; + i__3 = *n - i__; + d_cnjg(&z__1, &tauq[i__]); + zlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, & + z__1, &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]); + } + i__2 = i__ + i__ * a_dim1; + i__3 = i__; + a[i__2].r = d__[i__3], a[i__2].i = 0.; + + if (i__ < *n) { + +/* Generate elementary reflector G(i) to annihilate */ +/* A(i,i+2:n) */ + + i__2 = *n - i__; + zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); + i__2 = i__ + (i__ + 1) * a_dim1; + alpha.r = a[i__2].r, alpha.i = a[i__2].i; + i__2 = *n - i__; +/* Computing MIN */ + i__3 = i__ + 2; + zlarfg_(&i__2, &alpha, &a[i__ + f2cmin(i__3,*n) * a_dim1], lda, & + taup[i__]); + i__2 = i__; + e[i__2] = alpha.r; + i__2 = i__ + (i__ + 1) * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + +/* Apply G(i) to A(i+1:m,i+1:n) from the right */ + + i__2 = *m - i__; + i__3 = *n - i__; + zlarf_("Right", &i__2, &i__3, &a[i__ + (i__ + 1) * a_dim1], + lda, &taup[i__], &a[i__ + 1 + (i__ + 1) * a_dim1], + lda, &work[1]); + i__2 = *n - i__; + zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); + i__2 = i__ + (i__ + 1) * a_dim1; + i__3 = i__; + a[i__2].r = e[i__3], a[i__2].i = 0.; + } else { + i__2 = i__; + taup[i__2].r = 0., taup[i__2].i = 0.; + } +/* L10: */ + } + } else { + +/* Reduce to lower bidiagonal form */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Generate elementary reflector G(i) to annihilate A(i,i+1:n) */ + + i__2 = *n - i__ + 1; + zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda); + i__2 = i__ + i__ * a_dim1; + alpha.r = a[i__2].r, alpha.i = a[i__2].i; + i__2 = *n - i__ + 1; +/* Computing MIN */ + i__3 = i__ + 1; + zlarfg_(&i__2, &alpha, &a[i__ + f2cmin(i__3,*n) * a_dim1], lda, & + taup[i__]); + i__2 = i__; + d__[i__2] = alpha.r; + i__2 = i__ + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + +/* Apply G(i) to A(i+1:m,i:n) from the right */ + + if (i__ < *m) { + i__2 = *m - i__; + i__3 = *n - i__ + 1; + zlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, & + taup[i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]); + } + i__2 = *n - i__ + 1; + zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda); + i__2 = i__ + i__ * a_dim1; + i__3 = i__; + a[i__2].r = d__[i__3], a[i__2].i = 0.; + + if (i__ < *m) { + +/* Generate elementary reflector H(i) to annihilate */ +/* A(i+2:m,i) */ + + i__2 = i__ + 1 + i__ * a_dim1; + alpha.r = a[i__2].r, alpha.i = a[i__2].i; + i__2 = *m - i__; +/* Computing MIN */ + i__3 = i__ + 2; + zlarfg_(&i__2, &alpha, &a[f2cmin(i__3,*m) + i__ * a_dim1], &c__1, + &tauq[i__]); + i__2 = i__; + e[i__2] = alpha.r; + i__2 = i__ + 1 + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + +/* Apply H(i)**H to A(i+1:m,i+1:n) from the left */ + + i__2 = *m - i__; + i__3 = *n - i__; + d_cnjg(&z__1, &tauq[i__]); + zlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], & + c__1, &z__1, &a[i__ + 1 + (i__ + 1) * a_dim1], lda, & + work[1]); + i__2 = i__ + 1 + i__ * a_dim1; + i__3 = i__; + a[i__2].r = e[i__3], a[i__2].i = 0.; + } else { + i__2 = i__; + tauq[i__2].r = 0., tauq[i__2].i = 0.; + } +/* L20: */ + } + } + return 0; + +/* End of ZGEBD2 */ + +} /* zgebd2_ */ + diff --git a/lapack-netlib/SRC/zgebrd.c b/lapack-netlib/SRC/zgebrd.c new file mode 100644 index 000000000..1e90261d0 --- /dev/null +++ b/lapack-netlib/SRC/zgebrd.c @@ -0,0 +1,796 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#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 ZGEBRD */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEBRD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK, */ +/* INFO ) */ + +/* INTEGER INFO, LDA, LWORK, M, N */ +/* DOUBLE PRECISION D( * ), E( * ) */ +/* COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEBRD reduces a general complex M-by-N matrix A to upper or lower */ +/* > bidiagonal form B by a unitary transformation: Q**H * A * P = B. */ +/* > */ +/* > If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows in the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns in 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 general matrix to be reduced. */ +/* > On exit, */ +/* > if m >= n, the diagonal and the first superdiagonal are */ +/* > overwritten with the upper bidiagonal matrix B; the */ +/* > elements below the diagonal, with the array TAUQ, represent */ +/* > the unitary matrix Q as a product of elementary */ +/* > reflectors, and the elements above the first superdiagonal, */ +/* > with the array TAUP, represent the unitary matrix P as */ +/* > a product of elementary reflectors; */ +/* > if m < n, the diagonal and the first subdiagonal are */ +/* > overwritten with the lower bidiagonal matrix B; the */ +/* > elements below the first subdiagonal, with the array TAUQ, */ +/* > represent the unitary matrix Q as a product of */ +/* > elementary reflectors, and the elements above the diagonal, */ +/* > with the array TAUP, represent the unitary matrix P as */ +/* > a product of elementary reflectors. */ +/* > See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (f2cmin(M,N)) */ +/* > The diagonal elements of the bidiagonal matrix B: */ +/* > D(i) = A(i,i). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (f2cmin(M,N)-1) */ +/* > The off-diagonal elements of the bidiagonal matrix B: */ +/* > if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1; */ +/* > if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUQ */ +/* > \verbatim */ +/* > TAUQ is COMPLEX*16 array, dimension (f2cmin(M,N)) */ +/* > The scalar factors of the elementary reflectors which */ +/* > represent the unitary matrix Q. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUP */ +/* > \verbatim */ +/* > TAUP is COMPLEX*16 array, dimension (f2cmin(M,N)) */ +/* > The scalar factors of the elementary reflectors which */ +/* > represent the unitary matrix P. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of the array WORK. LWORK >= f2cmax(1,M,N). */ +/* > For optimum performance LWORK >= (M+N)*NB, where NB */ +/* > is the optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup complex16GEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrices Q and P are represented as products of elementary */ +/* > reflectors: */ +/* > */ +/* > If m >= n, */ +/* > */ +/* > Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1) */ +/* > */ +/* > Each H(i) and G(i) has the form: */ +/* > */ +/* > H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H */ +/* > */ +/* > where tauq and taup are complex scalars, and v and u are complex */ +/* > vectors; v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in */ +/* > A(i+1:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in */ +/* > A(i,i+2:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */ +/* > */ +/* > If m < n, */ +/* > */ +/* > Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m) */ +/* > */ +/* > Each H(i) and G(i) has the form: */ +/* > */ +/* > H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H */ +/* > */ +/* > where tauq and taup are complex scalars, and v and u are complex */ +/* > vectors; v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in */ +/* > A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in */ +/* > A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */ +/* > */ +/* > The contents of A on exit are illustrated by the following examples: */ +/* > */ +/* > m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */ +/* > */ +/* > ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 ) */ +/* > ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 ) */ +/* > ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 ) */ +/* > ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 ) */ +/* > ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 ) */ +/* > ( v1 v2 v3 v4 v5 ) */ +/* > */ +/* > where d and e denote diagonal and off-diagonal elements of B, vi */ +/* > denotes an element of the vector defining H(i), and ui an element of */ +/* > the vector defining G(i). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgebrd_(integer *m, integer *n, doublecomplex *a, + integer *lda, doublereal *d__, doublereal *e, doublecomplex *tauq, + doublecomplex *taup, doublecomplex *work, integer *lwork, integer * + info) +{ + /* 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, nbmin, iinfo, minmn; + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *), zgebd2_(integer *, integer *, + doublecomplex *, integer *, doublereal *, doublereal *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *); + integer nb, nx, ws; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zlabrd_( + integer *, integer *, integer *, doublecomplex *, integer *, + doublereal *, doublereal *, doublecomplex *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer ldwrkx, ldwrky, lwkopt; + logical lquery; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --d__; + --e; + --tauq; + --taup; + --work; + + /* Function Body */ + *info = 0; +/* Computing MAX */ + i__1 = 1, i__2 = ilaenv_(&c__1, "ZGEBRD", " ", m, n, &c_n1, &c_n1, ( + ftnlen)6, (ftnlen)1); + nb = f2cmax(i__1,i__2); + lwkopt = (*m + *n) * nb; + d__1 = (doublereal) lwkopt; + work[1].r = d__1, work[1].i = 0.; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = f2cmax(1,*m); + if (*lwork < f2cmax(i__1,*n) && ! lquery) { + *info = -10; + } + } + if (*info < 0) { + i__1 = -(*info); + xerbla_("ZGEBRD", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + minmn = f2cmin(*m,*n); + if (minmn == 0) { + work[1].r = 1., work[1].i = 0.; + return 0; + } + + ws = f2cmax(*m,*n); + ldwrkx = *m; + ldwrky = *n; + + if (nb > 1 && nb < minmn) { + +/* Set the crossover point NX. */ + +/* Computing MAX */ + i__1 = nb, i__2 = ilaenv_(&c__3, "ZGEBRD", " ", m, n, &c_n1, &c_n1, ( + ftnlen)6, (ftnlen)1); + nx = f2cmax(i__1,i__2); + +/* Determine when to switch from blocked to unblocked code. */ + + if (nx < minmn) { + ws = (*m + *n) * nb; + if (*lwork < ws) { + +/* Not enough work space for the optimal NB, consider using */ +/* a smaller block size. */ + + nbmin = ilaenv_(&c__2, "ZGEBRD", " ", m, n, &c_n1, &c_n1, ( + ftnlen)6, (ftnlen)1); + if (*lwork >= (*m + *n) * nbmin) { + nb = *lwork / (*m + *n); + } else { + nb = 1; + nx = minmn; + } + } + } + } else { + nx = minmn; + } + + i__1 = minmn - nx; + i__2 = nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + +/* Reduce rows and columns i:i+ib-1 to bidiagonal form and return */ +/* the matrices X and Y which are needed to update the unreduced */ +/* part of the matrix */ + + i__3 = *m - i__ + 1; + i__4 = *n - i__ + 1; + zlabrd_(&i__3, &i__4, &nb, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[ + i__], &tauq[i__], &taup[i__], &work[1], &ldwrkx, &work[ldwrkx + * nb + 1], &ldwrky); + +/* Update the trailing submatrix A(i+ib:m,i+ib:n), using */ +/* an update of the form A := A - V*Y**H - X*U**H */ + + i__3 = *m - i__ - nb + 1; + i__4 = *n - i__ - nb + 1; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Conjugate transpose", &i__3, &i__4, &nb, & + z__1, &a[i__ + nb + i__ * a_dim1], lda, &work[ldwrkx * nb + + nb + 1], &ldwrky, &c_b1, &a[i__ + nb + (i__ + nb) * a_dim1], + lda); + i__3 = *m - i__ - nb + 1; + i__4 = *n - i__ - nb + 1; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "No transpose", &i__3, &i__4, &nb, &z__1, & + work[nb + 1], &ldwrkx, &a[i__ + (i__ + nb) * a_dim1], lda, & + c_b1, &a[i__ + nb + (i__ + nb) * a_dim1], lda); + +/* Copy diagonal and off-diagonal elements of B back into A */ + + if (*m >= *n) { + i__3 = i__ + nb - 1; + for (j = i__; j <= i__3; ++j) { + i__4 = j + j * a_dim1; + i__5 = j; + a[i__4].r = d__[i__5], a[i__4].i = 0.; + i__4 = j + (j + 1) * a_dim1; + i__5 = j; + a[i__4].r = e[i__5], a[i__4].i = 0.; +/* L10: */ + } + } else { + i__3 = i__ + nb - 1; + for (j = i__; j <= i__3; ++j) { + i__4 = j + j * a_dim1; + i__5 = j; + a[i__4].r = d__[i__5], a[i__4].i = 0.; + i__4 = j + 1 + j * a_dim1; + i__5 = j; + a[i__4].r = e[i__5], a[i__4].i = 0.; +/* L20: */ + } + } +/* L30: */ + } + +/* Use unblocked code to reduce the remainder of the matrix */ + + i__2 = *m - i__ + 1; + i__1 = *n - i__ + 1; + zgebd2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &d__[i__], &e[i__], & + tauq[i__], &taup[i__], &work[1], &iinfo); + work[1].r = (doublereal) ws, work[1].i = 0.; + return 0; + +/* End of ZGEBRD */ + +} /* zgebrd_ */ + diff --git a/lapack-netlib/SRC/zgecon.c b/lapack-netlib/SRC/zgecon.c new file mode 100644 index 000000000..a1b66b6a7 --- /dev/null +++ b/lapack-netlib/SRC/zgecon.c @@ -0,0 +1,660 @@ +/* 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 ZGECON */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGECON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, RWORK, */ +/* INFO ) */ + +/* CHARACTER NORM */ +/* INTEGER INFO, LDA, N */ +/* DOUBLE PRECISION ANORM, RCOND */ +/* DOUBLE PRECISION RWORK( * ) */ +/* COMPLEX*16 A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGECON estimates the reciprocal of the condition number of a general */ +/* > complex matrix A, in either the 1-norm or the infinity-norm, using */ +/* > the LU factorization computed by ZGETRF. */ +/* > */ +/* > An estimate is obtained for norm(inv(A)), and the reciprocal of the */ +/* > condition number is computed as */ +/* > RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies whether the 1-norm condition number or the */ +/* > infinity-norm condition number is required: */ +/* > = '1' or 'O': 1-norm; */ +/* > = 'I': Infinity-norm. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > The factors L and U from the factorization A = P*L*U */ +/* > as computed by ZGETRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ANORM */ +/* > \verbatim */ +/* > ANORM is DOUBLE PRECISION */ +/* > If NORM = '1' or 'O', the 1-norm of the original matrix A. */ +/* > If NORM = 'I', the infinity-norm of the original matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > The reciprocal of the condition number of the matrix A, */ +/* > computed as RCOND = 1/(norm(A) * norm(inv(A))). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GEcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zgecon_(char *norm, integer *n, doublecomplex *a, + integer *lda, doublereal *anorm, doublereal *rcond, doublecomplex * + work, doublereal *rwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + doublereal d__1, d__2; + + /* Local variables */ + integer kase, kase1; + doublereal scale; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *, + doublecomplex *, doublereal *, integer *, integer *); + extern doublereal dlamch_(char *); + doublereal sl; + integer ix; + doublereal su; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal ainvnm; + extern integer izamax_(integer *, doublecomplex *, integer *); + logical onenrm; + extern /* Subroutine */ int zdrscl_(integer *, doublereal *, + doublecomplex *, integer *); + char normin[1]; + doublereal smlnum; + extern /* Subroutine */ int zlatrs_(char *, char *, char *, char *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublereal *, doublereal *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --work; + --rwork; + + /* Function Body */ + *info = 0; + onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); + if (! onenrm && ! lsame_(norm, "I")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*anorm < 0.) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGECON", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + *rcond = 0.; + if (*n == 0) { + *rcond = 1.; + return 0; + } else if (*anorm == 0.) { + return 0; + } + + smlnum = dlamch_("Safe minimum"); + +/* Estimate the norm of inv(A). */ + + ainvnm = 0.; + *(unsigned char *)normin = 'N'; + if (onenrm) { + kase1 = 1; + } else { + kase1 = 2; + } + kase = 0; +L10: + zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == kase1) { + +/* Multiply by inv(L). */ + + zlatrs_("Lower", "No transpose", "Unit", normin, n, &a[a_offset], + lda, &work[1], &sl, &rwork[1], info); + +/* Multiply by inv(U). */ + + zlatrs_("Upper", "No transpose", "Non-unit", normin, n, &a[ + a_offset], lda, &work[1], &su, &rwork[*n + 1], info); + } else { + +/* Multiply by inv(U**H). */ + + zlatrs_("Upper", "Conjugate transpose", "Non-unit", normin, n, &a[ + a_offset], lda, &work[1], &su, &rwork[*n + 1], info); + +/* Multiply by inv(L**H). */ + + zlatrs_("Lower", "Conjugate transpose", "Unit", normin, n, &a[ + a_offset], lda, &work[1], &sl, &rwork[1], info); + } + +/* Divide X by 1/(SL*SU) if doing so will not cause overflow. */ + + scale = sl * su; + *(unsigned char *)normin = 'Y'; + if (scale != 1.) { + ix = izamax_(n, &work[1], &c__1); + i__1 = ix; + if (scale < ((d__1 = work[i__1].r, abs(d__1)) + (d__2 = d_imag(& + work[ix]), abs(d__2))) * smlnum || scale == 0.) { + goto L20; + } + zdrscl_(n, &scale, &work[1], &c__1); + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + *rcond = 1. / ainvnm / *anorm; + } + +L20: + return 0; + +/* End of ZGECON */ + +} /* zgecon_ */ + diff --git a/lapack-netlib/SRC/zgeequ.c b/lapack-netlib/SRC/zgeequ.c new file mode 100644 index 000000000..550f94b90 --- /dev/null +++ b/lapack-netlib/SRC/zgeequ.c @@ -0,0 +1,737 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#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 ZGEEQU */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEEQU + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, */ +/* INFO ) */ + +/* INTEGER INFO, LDA, M, N */ +/* DOUBLE PRECISION AMAX, COLCND, ROWCND */ +/* DOUBLE PRECISION C( * ), R( * ) */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEEQU computes row and column scalings intended to equilibrate an */ +/* > M-by-N matrix A and reduce its condition number. R returns the row */ +/* > scale factors and C the column scale factors, chosen to try to make */ +/* > the largest element in each row and column of the matrix B with */ +/* > elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. */ +/* > */ +/* > R(i) and C(j) are restricted to be between SMLNUM = smallest safe */ +/* > number and BIGNUM = largest safe number. Use of these scaling */ +/* > factors is not guaranteed to reduce the condition number of A but */ +/* > works well in practice. */ +/* > \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] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > The M-by-N matrix whose equilibration factors are */ +/* > to be computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] R */ +/* > \verbatim */ +/* > R is DOUBLE PRECISION array, dimension (M) */ +/* > If INFO = 0 or INFO > M, R contains the row scale factors */ +/* > for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N) */ +/* > If INFO = 0, C contains the column scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ROWCND */ +/* > \verbatim */ +/* > ROWCND is DOUBLE PRECISION */ +/* > If INFO = 0 or INFO > M, ROWCND contains the ratio of the */ +/* > smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */ +/* > AMAX is neither too large nor too small, it is not worth */ +/* > scaling by R. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] COLCND */ +/* > \verbatim */ +/* > COLCND is DOUBLE PRECISION */ +/* > If INFO = 0, COLCND contains the ratio of the smallest */ +/* > C(i) to the largest C(i). If COLCND >= 0.1, it is not */ +/* > worth scaling by C. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] AMAX */ +/* > \verbatim */ +/* > AMAX is DOUBLE PRECISION */ +/* > Absolute value of largest matrix element. If AMAX is very */ +/* > close to overflow or very close to underflow, the matrix */ +/* > should be scaled. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, and i is */ +/* > <= M: the i-th row of A is exactly zero */ +/* > > M: the (i-M)-th column of A is exactly zero */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GEcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zgeequ_(integer *m, integer *n, doublecomplex *a, + integer *lda, doublereal *r__, doublereal *c__, doublereal *rowcnd, + doublereal *colcnd, doublereal *amax, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + integer i__, j; + doublereal rcmin, rcmax; + extern doublereal dlamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum, smlnum; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --r__; + --c__; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEEQU", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + *rowcnd = 1.; + *colcnd = 1.; + *amax = 0.; + return 0; + } + +/* Get machine constants. */ + + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + +/* Compute row scale factors. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + r__[i__] = 0.; +/* L10: */ + } + +/* Find the maximum element in each row. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ + j * a_dim1; + d__3 = r__[i__], d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = + d_imag(&a[i__ + j * a_dim1]), abs(d__2)); + r__[i__] = f2cmax(d__3,d__4); +/* L20: */ + } +/* L30: */ + } + +/* Find the maximum and minimum scale factors. */ + + rcmin = bignum; + rcmax = 0.; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__1 = rcmax, d__2 = r__[i__]; + rcmax = f2cmax(d__1,d__2); +/* Computing MIN */ + d__1 = rcmin, d__2 = r__[i__]; + rcmin = f2cmin(d__1,d__2); +/* L40: */ + } + *amax = rcmax; + + if (rcmin == 0.) { + +/* Find the first zero scale factor and return an error code. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (r__[i__] == 0.) { + *info = i__; + return 0; + } +/* L50: */ + } + } else { + +/* Invert the scale factors. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MIN */ +/* Computing MAX */ + d__2 = r__[i__]; + d__1 = f2cmax(d__2,smlnum); + r__[i__] = 1. / f2cmin(d__1,bignum); +/* L60: */ + } + +/* Compute ROWCND = f2cmin(R(I)) / f2cmax(R(I)) */ + + *rowcnd = f2cmax(rcmin,smlnum) / f2cmin(rcmax,bignum); + } + +/* Compute column scale factors */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + c__[j] = 0.; +/* L70: */ + } + +/* Find the maximum element in each column, */ +/* assuming the row scaling computed above. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ + j * a_dim1; + d__3 = c__[j], d__4 = ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = + d_imag(&a[i__ + j * a_dim1]), abs(d__2))) * r__[i__]; + c__[j] = f2cmax(d__3,d__4); +/* L80: */ + } +/* L90: */ + } + +/* Find the maximum and minimum scale factors. */ + + rcmin = bignum; + rcmax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = rcmin, d__2 = c__[j]; + rcmin = f2cmin(d__1,d__2); +/* Computing MAX */ + d__1 = rcmax, d__2 = c__[j]; + rcmax = f2cmax(d__1,d__2); +/* L100: */ + } + + if (rcmin == 0.) { + +/* Find the first zero scale factor and return an error code. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (c__[j] == 0.) { + *info = *m + j; + return 0; + } +/* L110: */ + } + } else { + +/* Invert the scale factors. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ +/* Computing MAX */ + d__2 = c__[j]; + d__1 = f2cmax(d__2,smlnum); + c__[j] = 1. / f2cmin(d__1,bignum); +/* L120: */ + } + +/* Compute COLCND = f2cmin(C(J)) / f2cmax(C(J)) */ + + *colcnd = f2cmax(rcmin,smlnum) / f2cmin(rcmax,bignum); + } + + return 0; + +/* End of ZGEEQU */ + +} /* zgeequ_ */ + diff --git a/lapack-netlib/SRC/zgeequb.c b/lapack-netlib/SRC/zgeequb.c new file mode 100644 index 000000000..5d3d772ff --- /dev/null +++ b/lapack-netlib/SRC/zgeequb.c @@ -0,0 +1,757 @@ +/* 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 ZGEEQUB */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEEQUB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEEQUB( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, */ +/* INFO ) */ + +/* INTEGER INFO, LDA, M, N */ +/* DOUBLE PRECISION AMAX, COLCND, ROWCND */ +/* DOUBLE PRECISION C( * ), R( * ) */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEEQUB computes row and column scalings intended to equilibrate an */ +/* > M-by-N matrix A and reduce its condition number. R returns the row */ +/* > scale factors and C the column scale factors, chosen to try to make */ +/* > the largest element in each row and column of the matrix B with */ +/* > elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most */ +/* > the radix. */ +/* > */ +/* > R(i) and C(j) are restricted to be a power of the radix between */ +/* > SMLNUM = smallest safe number and BIGNUM = largest safe number. Use */ +/* > of these scaling factors is not guaranteed to reduce the condition */ +/* > number of A but works well in practice. */ +/* > */ +/* > This routine differs from ZGEEQU by restricting the scaling factors */ +/* > to a power of the radix. Barring over- and underflow, scaling by */ +/* > these factors introduces no additional rounding errors. However, the */ +/* > scaled entries' magnitudes are no longer approximately 1 but lie */ +/* > between sqrt(radix) and 1/sqrt(radix). */ +/* > \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] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > The M-by-N matrix whose equilibration factors are */ +/* > to be computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] R */ +/* > \verbatim */ +/* > R is DOUBLE PRECISION array, dimension (M) */ +/* > If INFO = 0 or INFO > M, R contains the row scale factors */ +/* > for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N) */ +/* > If INFO = 0, C contains the column scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ROWCND */ +/* > \verbatim */ +/* > ROWCND is DOUBLE PRECISION */ +/* > If INFO = 0 or INFO > M, ROWCND contains the ratio of the */ +/* > smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */ +/* > AMAX is neither too large nor too small, it is not worth */ +/* > scaling by R. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] COLCND */ +/* > \verbatim */ +/* > COLCND is DOUBLE PRECISION */ +/* > If INFO = 0, COLCND contains the ratio of the smallest */ +/* > C(i) to the largest C(i). If COLCND >= 0.1, it is not */ +/* > worth scaling by C. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] AMAX */ +/* > \verbatim */ +/* > AMAX is DOUBLE PRECISION */ +/* > Absolute value of largest matrix element. If AMAX is very */ +/* > close to overflow or very close to underflow, the matrix */ +/* > should be scaled. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, and i is */ +/* > <= M: the i-th row of A is exactly zero */ +/* > > M: the (i-M)-th column of A is exactly zero */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GEcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zgeequb_(integer *m, integer *n, doublecomplex *a, + integer *lda, doublereal *r__, doublereal *c__, doublereal *rowcnd, + doublereal *colcnd, doublereal *amax, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + integer i__, j; + doublereal radix, rcmin, rcmax; + extern doublereal dlamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum, logrdx, smlnum; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --r__; + --c__; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEEQUB", &i__1, (ftnlen)7); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0) { + *rowcnd = 1.; + *colcnd = 1.; + *amax = 0.; + return 0; + } + +/* Get machine constants. Assume SMLNUM is a power of the radix. */ + + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + radix = dlamch_("B"); + logrdx = log(radix); + +/* Compute row scale factors. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + r__[i__] = 0.; +/* L10: */ + } + +/* Find the maximum element in each row. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ + j * a_dim1; + d__3 = r__[i__], d__4 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = + d_imag(&a[i__ + j * a_dim1]), abs(d__2)); + r__[i__] = f2cmax(d__3,d__4); +/* L20: */ + } +/* L30: */ + } + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (r__[i__] > 0.) { + i__2 = (integer) (log(r__[i__]) / logrdx); + r__[i__] = pow_di(&radix, &i__2); + } + } + +/* Find the maximum and minimum scale factors. */ + + rcmin = bignum; + rcmax = 0.; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + d__1 = rcmax, d__2 = r__[i__]; + rcmax = f2cmax(d__1,d__2); +/* Computing MIN */ + d__1 = rcmin, d__2 = r__[i__]; + rcmin = f2cmin(d__1,d__2); +/* L40: */ + } + *amax = rcmax; + + if (rcmin == 0.) { + +/* Find the first zero scale factor and return an error code. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (r__[i__] == 0.) { + *info = i__; + return 0; + } +/* L50: */ + } + } else { + +/* Invert the scale factors. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MIN */ +/* Computing MAX */ + d__2 = r__[i__]; + d__1 = f2cmax(d__2,smlnum); + r__[i__] = 1. / f2cmin(d__1,bignum); +/* L60: */ + } + +/* Compute ROWCND = f2cmin(R(I)) / f2cmax(R(I)). */ + + *rowcnd = f2cmax(rcmin,smlnum) / f2cmin(rcmax,bignum); + } + +/* Compute column scale factors. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + c__[j] = 0.; +/* L70: */ + } + +/* Find the maximum element in each column, */ +/* assuming the row scaling computed above. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ + j * a_dim1; + d__3 = c__[j], d__4 = ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = + d_imag(&a[i__ + j * a_dim1]), abs(d__2))) * r__[i__]; + c__[j] = f2cmax(d__3,d__4); +/* L80: */ + } + if (c__[j] > 0.) { + i__2 = (integer) (log(c__[j]) / logrdx); + c__[j] = pow_di(&radix, &i__2); + } +/* L90: */ + } + +/* Find the maximum and minimum scale factors. */ + + rcmin = bignum; + rcmax = 0.; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + d__1 = rcmin, d__2 = c__[j]; + rcmin = f2cmin(d__1,d__2); +/* Computing MAX */ + d__1 = rcmax, d__2 = c__[j]; + rcmax = f2cmax(d__1,d__2); +/* L100: */ + } + + if (rcmin == 0.) { + +/* Find the first zero scale factor and return an error code. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (c__[j] == 0.) { + *info = *m + j; + return 0; + } +/* L110: */ + } + } else { + +/* Invert the scale factors. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ +/* Computing MAX */ + d__2 = c__[j]; + d__1 = f2cmax(d__2,smlnum); + c__[j] = 1. / f2cmin(d__1,bignum); +/* L120: */ + } + +/* Compute COLCND = f2cmin(C(J)) / f2cmax(C(J)). */ + + *colcnd = f2cmax(rcmin,smlnum) / f2cmin(rcmax,bignum); + } + + return 0; + +/* End of ZGEEQUB */ + +} /* zgeequb_ */ + diff --git a/lapack-netlib/SRC/zgees.c b/lapack-netlib/SRC/zgees.c new file mode 100644 index 000000000..4bc6a6deb --- /dev/null +++ b/lapack-netlib/SRC/zgees.c @@ -0,0 +1,859 @@ +/* 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 ZGEES computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors f +or GE matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEES + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, W, VS, */ +/* LDVS, WORK, LWORK, RWORK, BWORK, INFO ) */ + +/* CHARACTER JOBVS, SORT */ +/* INTEGER INFO, LDA, LDVS, LWORK, N, SDIM */ +/* LOGICAL BWORK( * ) */ +/* DOUBLE PRECISION RWORK( * ) */ +/* COMPLEX*16 A( LDA, * ), VS( LDVS, * ), W( * ), WORK( * ) */ +/* LOGICAL SELECT */ +/* EXTERNAL SELECT */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEES computes for an N-by-N complex nonsymmetric matrix A, the */ +/* > eigenvalues, the Schur form T, and, optionally, the matrix of Schur */ +/* > vectors Z. This gives the Schur factorization A = Z*T*(Z**H). */ +/* > */ +/* > Optionally, it also orders the eigenvalues on the diagonal of the */ +/* > Schur form so that selected eigenvalues are at the top left. */ +/* > The leading columns of Z then form an orthonormal basis for the */ +/* > invariant subspace corresponding to the selected eigenvalues. */ +/* > */ +/* > A complex matrix is in Schur form if it is upper triangular. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBVS */ +/* > \verbatim */ +/* > JOBVS is CHARACTER*1 */ +/* > = 'N': Schur vectors are not computed; */ +/* > = 'V': Schur vectors are computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SORT */ +/* > \verbatim */ +/* > SORT is CHARACTER*1 */ +/* > Specifies whether or not to order the eigenvalues on the */ +/* > diagonal of the Schur form. */ +/* > = 'N': Eigenvalues are not ordered: */ +/* > = 'S': Eigenvalues are ordered (see SELECT). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELECT */ +/* > \verbatim */ +/* > SELECT is a LOGICAL FUNCTION of one COMPLEX*16 argument */ +/* > SELECT must be declared EXTERNAL in the calling subroutine. */ +/* > If SORT = 'S', SELECT is used to select eigenvalues to order */ +/* > to the top left of the Schur form. */ +/* > IF SORT = 'N', SELECT is not referenced. */ +/* > The eigenvalue W(j) is selected if SELECT(W(j)) is true. */ +/* > \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 N-by-N matrix A. */ +/* > On exit, A has been overwritten by its Schur form T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SDIM */ +/* > \verbatim */ +/* > SDIM is INTEGER */ +/* > If SORT = 'N', SDIM = 0. */ +/* > If SORT = 'S', SDIM = number of eigenvalues for which */ +/* > SELECT is true. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is COMPLEX*16 array, dimension (N) */ +/* > W contains the computed eigenvalues, in the same order that */ +/* > they appear on the diagonal of the output Schur form T. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VS */ +/* > \verbatim */ +/* > VS is COMPLEX*16 array, dimension (LDVS,N) */ +/* > If JOBVS = 'V', VS contains the unitary matrix Z of Schur */ +/* > vectors. */ +/* > If JOBVS = 'N', VS is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVS */ +/* > \verbatim */ +/* > LDVS is INTEGER */ +/* > The leading dimension of the array VS. LDVS >= 1; if */ +/* > JOBVS = 'V', LDVS >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,2*N). */ +/* > For good performance, LWORK must generally be larger. */ +/* > */ +/* > 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] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BWORK */ +/* > \verbatim */ +/* > BWORK is LOGICAL array, dimension (N) */ +/* > Not referenced if SORT = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: if INFO = i, and i is */ +/* > <= N: the QR algorithm failed to compute all the */ +/* > eigenvalues; elements 1:ILO-1 and i+1:N of W */ +/* > contain those eigenvalues which have converged; */ +/* > if JOBVS = 'V', VS contains the matrix which */ +/* > reduces A to its partially converged Schur form. */ +/* > = N+1: the eigenvalues could not be reordered because */ +/* > some eigenvalues were too close to separate (the */ +/* > problem is very ill-conditioned); */ +/* > = N+2: after reordering, roundoff changed values of */ +/* > some complex eigenvalues so that leading */ +/* > eigenvalues in the Schur form no longer satisfy */ +/* > SELECT = .TRUE.. This could also be caused by */ +/* > underflow due to scaling. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GEeigen */ + +/* ===================================================================== */ +/* Subroutine */ int zgees_(char *jobvs, char *sort, L_fp select, integer *n, + doublecomplex *a, integer *lda, integer *sdim, doublecomplex *w, + doublecomplex *vs, integer *ldvs, doublecomplex *work, integer *lwork, + doublereal *rwork, logical *bwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2; + + /* Local variables */ + integer ibal; + doublereal anrm; + integer ierr, itau, iwrk, i__; + doublereal s; + integer icond, ieval; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), dlabad_(doublereal *, doublereal *); + logical scalea; + extern doublereal dlamch_(char *); + doublereal cscale; + extern /* Subroutine */ int zgebak_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublecomplex *, integer *, + integer *), zgebal_(char *, integer *, + doublecomplex *, integer *, integer *, integer *, doublereal *, + integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, + integer *, doublereal *); + doublereal bignum; + extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *), zlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublecomplex *, + integer *, integer *), zlacpy_(char *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *); + integer minwrk, maxwrk; + doublereal smlnum; + extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *); + integer hswork; + extern /* Subroutine */ int zunghr_(integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *); + logical wantst, lquery, wantvs; + extern /* Subroutine */ int ztrsen_(char *, char *, logical *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublereal *, doublereal *, + doublecomplex *, integer *, integer *); + integer ihi, ilo; + doublereal dum[1], eps, sep; + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --w; + vs_dim1 = *ldvs; + vs_offset = 1 + vs_dim1 * 1; + vs -= vs_offset; + --work; + --rwork; + --bwork; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + wantvs = lsame_(jobvs, "V"); + wantst = lsame_(sort, "S"); + if (! wantvs && ! lsame_(jobvs, "N")) { + *info = -1; + } else if (! wantst && ! lsame_(sort, "N")) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } else if (*ldvs < 1 || wantvs && *ldvs < *n) { + *info = -10; + } + +/* Compute workspace */ +/* (Note: Comments in the code beginning "Workspace:" describe the */ +/* minimal amount of workspace needed at that point in the code, */ +/* as well as the preferred amount for good performance. */ +/* CWorkspace refers to complex workspace, and RWorkspace to real */ +/* workspace. NB refers to the optimal block size for the */ +/* immediately following subroutine, as returned by ILAENV. */ +/* HSWORK refers to the workspace preferred by ZHSEQR, as */ +/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */ +/* the worst case.) */ + + if (*info == 0) { + if (*n == 0) { + minwrk = 1; + maxwrk = 1; + } else { + maxwrk = *n + *n * ilaenv_(&c__1, "ZGEHRD", " ", n, &c__1, n, & + c__0, (ftnlen)6, (ftnlen)1); + minwrk = *n << 1; + + zhseqr_("S", jobvs, n, &c__1, n, &a[a_offset], lda, &w[1], &vs[ + vs_offset], ldvs, &work[1], &c_n1, &ieval); + hswork = (integer) work[1].r; + + if (! wantvs) { + maxwrk = f2cmax(maxwrk,hswork); + } else { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "ZUNGHR", + " ", n, &c__1, n, &c_n1, (ftnlen)6, (ftnlen)1); + maxwrk = f2cmax(i__1,i__2); + maxwrk = f2cmax(maxwrk,hswork); + } + } + work[1].r = (doublereal) maxwrk, work[1].i = 0.; + + if (*lwork < minwrk && ! lquery) { + *info = -12; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEES ", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *sdim = 0; + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + smlnum = sqrt(smlnum) / eps; + bignum = 1. / smlnum; + +/* Scale A if f2cmax element outside range [SMLNUM,BIGNUM] */ + + anrm = zlange_("M", n, n, &a[a_offset], lda, dum); + scalea = FALSE_; + if (anrm > 0. && anrm < smlnum) { + scalea = TRUE_; + cscale = smlnum; + } else if (anrm > bignum) { + scalea = TRUE_; + cscale = bignum; + } + if (scalea) { + zlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, & + ierr); + } + +/* Permute the matrix to make it more nearly triangular */ +/* (CWorkspace: none) */ +/* (RWorkspace: need N) */ + + ibal = 1; + zgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &rwork[ibal], &ierr); + +/* Reduce to upper Hessenberg form */ +/* (CWorkspace: need 2*N, prefer N+N*NB) */ +/* (RWorkspace: none) */ + + itau = 1; + iwrk = *n + itau; + i__1 = *lwork - iwrk + 1; + zgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, + &ierr); + + if (wantvs) { + +/* Copy Householder vectors to VS */ + + zlacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs) + ; + +/* Generate unitary matrix in VS */ +/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */ +/* (RWorkspace: none) */ + + i__1 = *lwork - iwrk + 1; + zunghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk], + &i__1, &ierr); + } + + *sdim = 0; + +/* Perform QR iteration, accumulating Schur vectors in VS if desired */ +/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */ +/* (RWorkspace: none) */ + + iwrk = itau; + i__1 = *lwork - iwrk + 1; + zhseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vs[ + vs_offset], ldvs, &work[iwrk], &i__1, &ieval); + if (ieval > 0) { + *info = ieval; + } + +/* Sort eigenvalues if desired */ + + if (wantst && *info == 0) { + if (scalea) { + zlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &w[1], n, & + ierr); + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + bwork[i__] = (*select)(&w[i__]); +/* L10: */ + } + +/* Reorder eigenvalues and transform Schur vectors */ +/* (CWorkspace: none) */ +/* (RWorkspace: none) */ + + i__1 = *lwork - iwrk + 1; + ztrsen_("N", jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset], + ldvs, &w[1], sdim, &s, &sep, &work[iwrk], &i__1, &icond); + } + + if (wantvs) { + +/* Undo balancing */ +/* (CWorkspace: none) */ +/* (RWorkspace: need N) */ + + zgebak_("P", "R", n, &ilo, &ihi, &rwork[ibal], n, &vs[vs_offset], + ldvs, &ierr); + } + + if (scalea) { + +/* Undo scaling for the Schur form of A */ + + zlascl_("U", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, & + ierr); + i__1 = *lda + 1; + zcopy_(n, &a[a_offset], &i__1, &w[1], &c__1); + } + + work[1].r = (doublereal) maxwrk, work[1].i = 0.; + return 0; + +/* End of ZGEES */ + +} /* zgees_ */ + diff --git a/lapack-netlib/SRC/zgeesx.c b/lapack-netlib/SRC/zgeesx.c new file mode 100644 index 000000000..4cd51db03 --- /dev/null +++ b/lapack-netlib/SRC/zgeesx.c @@ -0,0 +1,942 @@ +/* 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 ZGEESX computes the eigenvalues, the Schur form, and, optionally, the matrix of Schur vectors +for GE matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEESX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM, W, */ +/* VS, LDVS, RCONDE, RCONDV, WORK, LWORK, RWORK, */ +/* BWORK, INFO ) */ + +/* CHARACTER JOBVS, SENSE, SORT */ +/* INTEGER INFO, LDA, LDVS, LWORK, N, SDIM */ +/* DOUBLE PRECISION RCONDE, RCONDV */ +/* LOGICAL BWORK( * ) */ +/* DOUBLE PRECISION RWORK( * ) */ +/* COMPLEX*16 A( LDA, * ), VS( LDVS, * ), W( * ), WORK( * ) */ +/* LOGICAL SELECT */ +/* EXTERNAL SELECT */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEESX computes for an N-by-N complex nonsymmetric matrix A, the */ +/* > eigenvalues, the Schur form T, and, optionally, the matrix of Schur */ +/* > vectors Z. This gives the Schur factorization A = Z*T*(Z**H). */ +/* > */ +/* > Optionally, it also orders the eigenvalues on the diagonal of the */ +/* > Schur form so that selected eigenvalues are at the top left; */ +/* > computes a reciprocal condition number for the average of the */ +/* > selected eigenvalues (RCONDE); and computes a reciprocal condition */ +/* > number for the right invariant subspace corresponding to the */ +/* > selected eigenvalues (RCONDV). The leading columns of Z form an */ +/* > orthonormal basis for this invariant subspace. */ +/* > */ +/* > For further explanation of the reciprocal condition numbers RCONDE */ +/* > and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where */ +/* > these quantities are called s and sep respectively). */ +/* > */ +/* > A complex matrix is in Schur form if it is upper triangular. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBVS */ +/* > \verbatim */ +/* > JOBVS is CHARACTER*1 */ +/* > = 'N': Schur vectors are not computed; */ +/* > = 'V': Schur vectors are computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SORT */ +/* > \verbatim */ +/* > SORT is CHARACTER*1 */ +/* > Specifies whether or not to order the eigenvalues on the */ +/* > diagonal of the Schur form. */ +/* > = 'N': Eigenvalues are not ordered; */ +/* > = 'S': Eigenvalues are ordered (see SELECT). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELECT */ +/* > \verbatim */ +/* > SELECT is a LOGICAL FUNCTION of one COMPLEX*16 argument */ +/* > SELECT must be declared EXTERNAL in the calling subroutine. */ +/* > If SORT = 'S', SELECT is used to select eigenvalues to order */ +/* > to the top left of the Schur form. */ +/* > If SORT = 'N', SELECT is not referenced. */ +/* > An eigenvalue W(j) is selected if SELECT(W(j)) is true. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SENSE */ +/* > \verbatim */ +/* > SENSE is CHARACTER*1 */ +/* > Determines which reciprocal condition numbers are computed. */ +/* > = 'N': None are computed; */ +/* > = 'E': Computed for average of selected eigenvalues only; */ +/* > = 'V': Computed for selected right invariant subspace only; */ +/* > = 'B': Computed for both. */ +/* > If SENSE = 'E', 'V' or 'B', SORT must equal 'S'. */ +/* > \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 N-by-N matrix A. */ +/* > On exit, A is overwritten by its Schur form T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SDIM */ +/* > \verbatim */ +/* > SDIM is INTEGER */ +/* > If SORT = 'N', SDIM = 0. */ +/* > If SORT = 'S', SDIM = number of eigenvalues for which */ +/* > SELECT is true. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is COMPLEX*16 array, dimension (N) */ +/* > W contains the computed eigenvalues, in the same order */ +/* > that they appear on the diagonal of the output Schur form T. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VS */ +/* > \verbatim */ +/* > VS is COMPLEX*16 array, dimension (LDVS,N) */ +/* > If JOBVS = 'V', VS contains the unitary matrix Z of Schur */ +/* > vectors. */ +/* > If JOBVS = 'N', VS is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVS */ +/* > \verbatim */ +/* > LDVS is INTEGER */ +/* > The leading dimension of the array VS. LDVS >= 1, and if */ +/* > JOBVS = 'V', LDVS >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCONDE */ +/* > \verbatim */ +/* > RCONDE is DOUBLE PRECISION */ +/* > If SENSE = 'E' or 'B', RCONDE contains the reciprocal */ +/* > condition number for the average of the selected eigenvalues. */ +/* > Not referenced if SENSE = 'N' or 'V'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCONDV */ +/* > \verbatim */ +/* > RCONDV is DOUBLE PRECISION */ +/* > If SENSE = 'V' or 'B', RCONDV contains the reciprocal */ +/* > condition number for the selected right invariant subspace. */ +/* > Not referenced if SENSE = 'N' or 'E'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,2*N). */ +/* > Also, if SENSE = 'E' or 'V' or 'B', LWORK >= 2*SDIM*(N-SDIM), */ +/* > where SDIM is the number of selected eigenvalues computed by */ +/* > this routine. Note that 2*SDIM*(N-SDIM) <= N*N/2. Note also */ +/* > that an error is only returned if LWORK < f2cmax(1,2*N), but if */ +/* > SENSE = 'E' or 'V' or 'B' this may not be large enough. */ +/* > For good performance, LWORK must generally be larger. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates upper bound on the optimal size of the */ +/* > array WORK, 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] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BWORK */ +/* > \verbatim */ +/* > BWORK is LOGICAL array, dimension (N) */ +/* > Not referenced if SORT = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: if INFO = i, and i is */ +/* > <= N: the QR algorithm failed to compute all the */ +/* > eigenvalues; elements 1:ILO-1 and i+1:N of W */ +/* > contain those eigenvalues which have converged; if */ +/* > JOBVS = 'V', VS contains the transformation which */ +/* > reduces A to its partially converged Schur form. */ +/* > = N+1: the eigenvalues could not be reordered because some */ +/* > eigenvalues were too close to separate (the problem */ +/* > is very ill-conditioned); */ +/* > = N+2: after reordering, roundoff changed values of some */ +/* > complex eigenvalues so that leading eigenvalues in */ +/* > the Schur form no longer satisfy SELECT=.TRUE. This */ +/* > could also be caused by underflow due to scaling. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16GEeigen */ + +/* ===================================================================== */ +/* Subroutine */ int zgeesx_(char *jobvs, char *sort, L_fp select, char * + sense, integer *n, doublecomplex *a, integer *lda, integer *sdim, + doublecomplex *w, doublecomplex *vs, integer *ldvs, doublereal * + rconde, doublereal *rcondv, doublecomplex *work, integer *lwork, + doublereal *rwork, logical *bwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, vs_dim1, vs_offset, i__1, i__2; + + /* Local variables */ + integer ibal; + doublereal anrm; + integer ierr, itau, iwrk, lwrk, i__, icond, ieval; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), dlabad_(doublereal *, doublereal *); + logical scalea; + extern doublereal dlamch_(char *); + doublereal cscale; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *), zgebak_(char *, char *, integer *, + integer *, integer *, doublereal *, integer *, doublecomplex *, + integer *, integer *), zgebal_(char *, integer *, + doublecomplex *, integer *, integer *, integer *, doublereal *, + integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, + integer *, doublereal *); + doublereal bignum; + extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *), zlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublecomplex *, + integer *, integer *); + logical wantsb, wantse; + extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + integer minwrk, maxwrk; + logical wantsn; + doublereal smlnum; + extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *); + integer hswork; + extern /* Subroutine */ int zunghr_(integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *); + logical wantst, lquery, wantsv, wantvs; + extern /* Subroutine */ int ztrsen_(char *, char *, logical *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublereal *, doublereal *, + doublecomplex *, integer *, integer *); + integer ihi, ilo; + doublereal dum[1], eps; + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --w; + vs_dim1 = *ldvs; + vs_offset = 1 + vs_dim1 * 1; + vs -= vs_offset; + --work; + --rwork; + --bwork; + + /* Function Body */ + *info = 0; + wantvs = lsame_(jobvs, "V"); + wantst = lsame_(sort, "S"); + wantsn = lsame_(sense, "N"); + wantse = lsame_(sense, "E"); + wantsv = lsame_(sense, "V"); + wantsb = lsame_(sense, "B"); + lquery = *lwork == -1; + + if (! wantvs && ! lsame_(jobvs, "N")) { + *info = -1; + } else if (! wantst && ! lsame_(sort, "N")) { + *info = -2; + } else if (! (wantsn || wantse || wantsv || wantsb) || ! wantst && ! + wantsn) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < f2cmax(1,*n)) { + *info = -7; + } else if (*ldvs < 1 || wantvs && *ldvs < *n) { + *info = -11; + } + +/* Compute workspace */ +/* (Note: Comments in the code beginning "Workspace:" describe the */ +/* minimal amount of real workspace needed at that point in the */ +/* code, as well as the preferred amount for good performance. */ +/* CWorkspace refers to complex workspace, and RWorkspace to real */ +/* workspace. NB refers to the optimal block size for the */ +/* immediately following subroutine, as returned by ILAENV. */ +/* HSWORK refers to the workspace preferred by ZHSEQR, as */ +/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */ +/* the worst case. */ +/* If SENSE = 'E', 'V' or 'B', then the amount of workspace needed */ +/* depends on SDIM, which is computed by the routine ZTRSEN later */ +/* in the code.) */ + + if (*info == 0) { + if (*n == 0) { + minwrk = 1; + lwrk = 1; + } else { + maxwrk = *n + *n * ilaenv_(&c__1, "ZGEHRD", " ", n, &c__1, n, & + c__0, (ftnlen)6, (ftnlen)1); + minwrk = *n << 1; + + zhseqr_("S", jobvs, n, &c__1, n, &a[a_offset], lda, &w[1], &vs[ + vs_offset], ldvs, &work[1], &c_n1, &ieval); + hswork = (integer) work[1].r; + + if (! wantvs) { + maxwrk = f2cmax(maxwrk,hswork); + } else { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "ZUNGHR", + " ", n, &c__1, n, &c_n1, (ftnlen)6, (ftnlen)1); + maxwrk = f2cmax(i__1,i__2); + maxwrk = f2cmax(maxwrk,hswork); + } + lwrk = maxwrk; + if (! wantsn) { +/* Computing MAX */ + i__1 = lwrk, i__2 = *n * *n / 2; + lwrk = f2cmax(i__1,i__2); + } + } + work[1].r = (doublereal) lwrk, work[1].i = 0.; + + if (*lwork < minwrk && ! lquery) { + *info = -15; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEESX", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *sdim = 0; + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + smlnum = sqrt(smlnum) / eps; + bignum = 1. / smlnum; + +/* Scale A if f2cmax element outside range [SMLNUM,BIGNUM] */ + + anrm = zlange_("M", n, n, &a[a_offset], lda, dum); + scalea = FALSE_; + if (anrm > 0. && anrm < smlnum) { + scalea = TRUE_; + cscale = smlnum; + } else if (anrm > bignum) { + scalea = TRUE_; + cscale = bignum; + } + if (scalea) { + zlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, & + ierr); + } + + +/* Permute the matrix to make it more nearly triangular */ +/* (CWorkspace: none) */ +/* (RWorkspace: need N) */ + + ibal = 1; + zgebal_("P", n, &a[a_offset], lda, &ilo, &ihi, &rwork[ibal], &ierr); + +/* Reduce to upper Hessenberg form */ +/* (CWorkspace: need 2*N, prefer N+N*NB) */ +/* (RWorkspace: none) */ + + itau = 1; + iwrk = *n + itau; + i__1 = *lwork - iwrk + 1; + zgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, + &ierr); + + if (wantvs) { + +/* Copy Householder vectors to VS */ + + zlacpy_("L", n, n, &a[a_offset], lda, &vs[vs_offset], ldvs) + ; + +/* Generate unitary matrix in VS */ +/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */ +/* (RWorkspace: none) */ + + i__1 = *lwork - iwrk + 1; + zunghr_(n, &ilo, &ihi, &vs[vs_offset], ldvs, &work[itau], &work[iwrk], + &i__1, &ierr); + } + + *sdim = 0; + +/* Perform QR iteration, accumulating Schur vectors in VS if desired */ +/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */ +/* (RWorkspace: none) */ + + iwrk = itau; + i__1 = *lwork - iwrk + 1; + zhseqr_("S", jobvs, n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vs[ + vs_offset], ldvs, &work[iwrk], &i__1, &ieval); + if (ieval > 0) { + *info = ieval; + } + +/* Sort eigenvalues if desired */ + + if (wantst && *info == 0) { + if (scalea) { + zlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &w[1], n, & + ierr); + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + bwork[i__] = (*select)(&w[i__]); +/* L10: */ + } + +/* Reorder eigenvalues, transform Schur vectors, and compute */ +/* reciprocal condition numbers */ +/* (CWorkspace: if SENSE is not 'N', need 2*SDIM*(N-SDIM) */ +/* otherwise, need none ) */ +/* (RWorkspace: none) */ + + i__1 = *lwork - iwrk + 1; + ztrsen_(sense, jobvs, &bwork[1], n, &a[a_offset], lda, &vs[vs_offset], + ldvs, &w[1], sdim, rconde, rcondv, &work[iwrk], &i__1, & + icond); + if (! wantsn) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = (*sdim << 1) * (*n - *sdim); + maxwrk = f2cmax(i__1,i__2); + } + if (icond == -14) { + +/* Not enough complex workspace */ + + *info = -15; + } + } + + if (wantvs) { + +/* Undo balancing */ +/* (CWorkspace: none) */ +/* (RWorkspace: need N) */ + + zgebak_("P", "R", n, &ilo, &ihi, &rwork[ibal], n, &vs[vs_offset], + ldvs, &ierr); + } + + if (scalea) { + +/* Undo scaling for the Schur form of A */ + + zlascl_("U", &c__0, &c__0, &cscale, &anrm, n, n, &a[a_offset], lda, & + ierr); + i__1 = *lda + 1; + zcopy_(n, &a[a_offset], &i__1, &w[1], &c__1); + if ((wantsv || wantsb) && *info == 0) { + dum[0] = *rcondv; + dlascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, & + c__1, &ierr); + *rcondv = dum[0]; + } + } + + work[1].r = (doublereal) maxwrk, work[1].i = 0.; + return 0; + +/* End of ZGEESX */ + +} /* zgeesx_ */ + diff --git a/lapack-netlib/SRC/zgeev.c b/lapack-netlib/SRC/zgeev.c new file mode 100644 index 000000000..9eee8d153 --- /dev/null +++ b/lapack-netlib/SRC/zgeev.c @@ -0,0 +1,999 @@ +/* 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 ZGEEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matr +ices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEEV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEEV( JOBVL, JOBVR, N, A, LDA, W, VL, LDVL, VR, LDVR, */ +/* WORK, LWORK, RWORK, INFO ) */ + +/* CHARACTER JOBVL, JOBVR */ +/* INTEGER INFO, LDA, LDVL, LDVR, LWORK, N */ +/* DOUBLE PRECISION RWORK( * ) */ +/* COMPLEX*16 A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), */ +/* $ W( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEEV computes for an N-by-N complex nonsymmetric matrix A, the */ +/* > eigenvalues and, optionally, the left and/or right eigenvectors. */ +/* > */ +/* > The right eigenvector v(j) of A satisfies */ +/* > A * v(j) = lambda(j) * v(j) */ +/* > where lambda(j) is its eigenvalue. */ +/* > The left eigenvector u(j) of A satisfies */ +/* > u(j)**H * A = lambda(j) * u(j)**H */ +/* > where u(j)**H denotes the conjugate transpose of u(j). */ +/* > */ +/* > The computed eigenvectors are normalized to have Euclidean norm */ +/* > equal to 1 and largest component real. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBVL */ +/* > \verbatim */ +/* > JOBVL is CHARACTER*1 */ +/* > = 'N': left eigenvectors of A are not computed; */ +/* > = 'V': left eigenvectors of are computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBVR */ +/* > \verbatim */ +/* > JOBVR is CHARACTER*1 */ +/* > = 'N': right eigenvectors of A are not computed; */ +/* > = 'V': right eigenvectors of A are computed. */ +/* > \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 N-by-N matrix A. */ +/* > On exit, A has been overwritten. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is COMPLEX*16 array, dimension (N) */ +/* > W contains the computed eigenvalues. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VL */ +/* > \verbatim */ +/* > VL is COMPLEX*16 array, dimension (LDVL,N) */ +/* > If JOBVL = 'V', the left eigenvectors u(j) are stored one */ +/* > after another in the columns of VL, in the same order */ +/* > as their eigenvalues. */ +/* > If JOBVL = 'N', VL is not referenced. */ +/* > u(j) = VL(:,j), the j-th column of VL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the array VL. LDVL >= 1; if */ +/* > JOBVL = 'V', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VR */ +/* > \verbatim */ +/* > VR is COMPLEX*16 array, dimension (LDVR,N) */ +/* > If JOBVR = 'V', the right eigenvectors v(j) are stored one */ +/* > after another in the columns of VR, in the same order */ +/* > as their eigenvalues. */ +/* > If JOBVR = 'N', VR is not referenced. */ +/* > v(j) = VR(:,j), the j-th column of VR. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the array VR. LDVR >= 1; if */ +/* > JOBVR = 'V', LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,2*N). */ +/* > For good performance, LWORK must generally be larger. */ +/* > */ +/* > 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] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: if INFO = i, the QR algorithm failed to compute all the */ +/* > eigenvalues, and no eigenvectors have been computed; */ +/* > elements i+1:N of W contain eigenvalues which have */ +/* > converged. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* @precisions fortran z -> c */ + +/* > \ingroup complex16GEeigen */ + +/* ===================================================================== */ +/* Subroutine */ int zgeev_(char *jobvl, char *jobvr, integer *n, + doublecomplex *a, integer *lda, doublecomplex *w, doublecomplex *vl, + integer *ldvl, doublecomplex *vr, integer *ldvr, doublecomplex *work, + integer *lwork, doublereal *rwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, + i__2, i__3; + doublereal d__1, d__2; + doublecomplex z__1, z__2; + + /* Local variables */ + integer ibal; + char side[1]; + doublereal anrm; + integer ierr, itau, iwrk, nout, i__, k; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *), dlabad_(doublereal *, doublereal *); + extern doublereal dznrm2_(integer *, doublecomplex *, integer *); + logical scalea; + extern doublereal dlamch_(char *); + doublereal cscale; + extern /* Subroutine */ int zgebak_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublecomplex *, integer *, + integer *), zgebal_(char *, integer *, + doublecomplex *, integer *, integer *, integer *, doublereal *, + integer *); + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + logical select[1]; + extern /* Subroutine */ int zdscal_(integer *, doublereal *, + doublecomplex *, integer *); + doublereal bignum; + extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, + integer *, doublereal *); + extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *), zlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublecomplex *, + integer *, integer *), zlacpy_(char *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *); + integer minwrk, maxwrk; + logical wantvl; + doublereal smlnum; + integer hswork, irwork; + extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *), zunghr_(integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *); + logical lquery, wantvr; + integer ihi; + extern /* Subroutine */ int ztrevc3_(char *, char *, logical *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, integer *, integer *, doublecomplex *, + integer *, doublereal *, integer *, integer *); + doublereal scl; + integer ilo; + doublereal dum[1], eps; + doublecomplex tmp; + integer lwork_trevc__; + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --w; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --work; + --rwork; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + wantvl = lsame_(jobvl, "V"); + wantvr = lsame_(jobvr, "V"); + if (! wantvl && ! lsame_(jobvl, "N")) { + *info = -1; + } else if (! wantvr && ! lsame_(jobvr, "N")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldvl < 1 || wantvl && *ldvl < *n) { + *info = -8; + } else if (*ldvr < 1 || wantvr && *ldvr < *n) { + *info = -10; + } + +/* Compute workspace */ +/* (Note: Comments in the code beginning "Workspace:" describe the */ +/* minimal amount of workspace needed at that point in the code, */ +/* as well as the preferred amount for good performance. */ +/* CWorkspace refers to complex workspace, and RWorkspace to real */ +/* workspace. NB refers to the optimal block size for the */ +/* immediately following subroutine, as returned by ILAENV. */ +/* HSWORK refers to the workspace preferred by ZHSEQR, as */ +/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */ +/* the worst case.) */ + + if (*info == 0) { + if (*n == 0) { + minwrk = 1; + maxwrk = 1; + } else { + maxwrk = *n + *n * ilaenv_(&c__1, "ZGEHRD", " ", n, &c__1, n, & + c__0, (ftnlen)6, (ftnlen)1); + minwrk = *n << 1; + if (wantvl) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "ZUNGHR", + " ", n, &c__1, n, &c_n1, (ftnlen)6, (ftnlen)1); + maxwrk = f2cmax(i__1,i__2); + ztrevc3_("L", "B", select, n, &a[a_offset], lda, &vl[ + vl_offset], ldvl, &vr[vr_offset], ldvr, n, &nout, & + work[1], &c_n1, &rwork[1], &c_n1, &ierr); + lwork_trevc__ = (integer) work[1].r; +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + lwork_trevc__; + maxwrk = f2cmax(i__1,i__2); + zhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vl[ + vl_offset], ldvl, &work[1], &c_n1, info); + } else if (wantvr) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "ZUNGHR", + " ", n, &c__1, n, &c_n1, (ftnlen)6, (ftnlen)1); + maxwrk = f2cmax(i__1,i__2); + ztrevc3_("R", "B", select, n, &a[a_offset], lda, &vl[ + vl_offset], ldvl, &vr[vr_offset], ldvr, n, &nout, & + work[1], &c_n1, &rwork[1], &c_n1, &ierr); + lwork_trevc__ = (integer) work[1].r; +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + lwork_trevc__; + maxwrk = f2cmax(i__1,i__2); + zhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[ + vr_offset], ldvr, &work[1], &c_n1, info); + } else { + zhseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[ + vr_offset], ldvr, &work[1], &c_n1, info); + } + hswork = (integer) work[1].r; +/* Computing MAX */ + i__1 = f2cmax(maxwrk,hswork); + maxwrk = f2cmax(i__1,minwrk); + } + work[1].r = (doublereal) maxwrk, work[1].i = 0.; + + if (*lwork < minwrk && ! lquery) { + *info = -12; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEEV ", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + smlnum = sqrt(smlnum) / eps; + bignum = 1. / smlnum; + +/* Scale A if f2cmax element outside range [SMLNUM,BIGNUM] */ + + anrm = zlange_("M", n, n, &a[a_offset], lda, dum); + scalea = FALSE_; + if (anrm > 0. && anrm < smlnum) { + scalea = TRUE_; + cscale = smlnum; + } else if (anrm > bignum) { + scalea = TRUE_; + cscale = bignum; + } + if (scalea) { + zlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, & + ierr); + } + +/* Balance the matrix */ +/* (CWorkspace: none) */ +/* (RWorkspace: need N) */ + + ibal = 1; + zgebal_("B", n, &a[a_offset], lda, &ilo, &ihi, &rwork[ibal], &ierr); + +/* Reduce to upper Hessenberg form */ +/* (CWorkspace: need 2*N, prefer N+N*NB) */ +/* (RWorkspace: none) */ + + itau = 1; + iwrk = itau + *n; + i__1 = *lwork - iwrk + 1; + zgehrd_(n, &ilo, &ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, + &ierr); + + if (wantvl) { + +/* Want left eigenvectors */ +/* Copy Householder vectors to VL */ + + *(unsigned char *)side = 'L'; + zlacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl) + ; + +/* Generate unitary matrix in VL */ +/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */ +/* (RWorkspace: none) */ + + i__1 = *lwork - iwrk + 1; + zunghr_(n, &ilo, &ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], + &i__1, &ierr); + +/* Perform QR iteration, accumulating Schur vectors in VL */ +/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */ +/* (RWorkspace: none) */ + + iwrk = itau; + i__1 = *lwork - iwrk + 1; + zhseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vl[ + vl_offset], ldvl, &work[iwrk], &i__1, info); + + if (wantvr) { + +/* Want left and right eigenvectors */ +/* Copy Schur vectors to VR */ + + *(unsigned char *)side = 'B'; + zlacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr); + } + + } else if (wantvr) { + +/* Want right eigenvectors */ +/* Copy Householder vectors to VR */ + + *(unsigned char *)side = 'R'; + zlacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr) + ; + +/* Generate unitary matrix in VR */ +/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */ +/* (RWorkspace: none) */ + + i__1 = *lwork - iwrk + 1; + zunghr_(n, &ilo, &ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], + &i__1, &ierr); + +/* Perform QR iteration, accumulating Schur vectors in VR */ +/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */ +/* (RWorkspace: none) */ + + iwrk = itau; + i__1 = *lwork - iwrk + 1; + zhseqr_("S", "V", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vr[ + vr_offset], ldvr, &work[iwrk], &i__1, info); + + } else { + +/* Compute eigenvalues only */ +/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */ +/* (RWorkspace: none) */ + + iwrk = itau; + i__1 = *lwork - iwrk + 1; + zhseqr_("E", "N", n, &ilo, &ihi, &a[a_offset], lda, &w[1], &vr[ + vr_offset], ldvr, &work[iwrk], &i__1, info); + } + +/* If INFO .NE. 0 from ZHSEQR, then quit */ + + if (*info != 0) { + goto L50; + } + + if (wantvl || wantvr) { + +/* Compute left and/or right eigenvectors */ +/* (CWorkspace: need 2*N, prefer N + 2*N*NB) */ +/* (RWorkspace: need 2*N) */ + + irwork = ibal + *n; + i__1 = *lwork - iwrk + 1; + ztrevc3_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], + ldvl, &vr[vr_offset], ldvr, n, &nout, &work[iwrk], &i__1, & + rwork[irwork], n, &ierr); + } + + if (wantvl) { + +/* Undo balancing of left eigenvectors */ +/* (CWorkspace: none) */ +/* (RWorkspace: need N) */ + + zgebak_("B", "L", n, &ilo, &ihi, &rwork[ibal], n, &vl[vl_offset], + ldvl, &ierr); + +/* Normalize left eigenvectors and make largest component real */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + scl = 1. / dznrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1); + zdscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1); + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + i__3 = k + i__ * vl_dim1; +/* Computing 2nd power */ + d__1 = vl[i__3].r; +/* Computing 2nd power */ + d__2 = d_imag(&vl[k + i__ * vl_dim1]); + rwork[irwork + k - 1] = d__1 * d__1 + d__2 * d__2; +/* $ AIMAG( VL( K, I ) )**2 */ +/* L10: */ + } + k = idamax_(n, &rwork[irwork], &c__1); + d_cnjg(&z__2, &vl[k + i__ * vl_dim1]); + d__1 = sqrt(rwork[irwork + k - 1]); + z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1; + tmp.r = z__1.r, tmp.i = z__1.i; + zscal_(n, &tmp, &vl[i__ * vl_dim1 + 1], &c__1); + i__2 = k + i__ * vl_dim1; + i__3 = k + i__ * vl_dim1; + d__1 = vl[i__3].r; + z__1.r = d__1, z__1.i = 0.; + vl[i__2].r = z__1.r, vl[i__2].i = z__1.i; +/* L20: */ + } + } + + if (wantvr) { + +/* Undo balancing of right eigenvectors */ +/* (CWorkspace: none) */ +/* (RWorkspace: need N) */ + + zgebak_("B", "R", n, &ilo, &ihi, &rwork[ibal], n, &vr[vr_offset], + ldvr, &ierr); + +/* Normalize right eigenvectors and make largest component real */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + scl = 1. / dznrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1); + zdscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1); + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + i__3 = k + i__ * vr_dim1; +/* Computing 2nd power */ + d__1 = vr[i__3].r; +/* Computing 2nd power */ + d__2 = d_imag(&vr[k + i__ * vr_dim1]); + rwork[irwork + k - 1] = d__1 * d__1 + d__2 * d__2; +/* $ AIMAG( VR( K, I ) )**2 */ +/* L30: */ + } + k = idamax_(n, &rwork[irwork], &c__1); + d_cnjg(&z__2, &vr[k + i__ * vr_dim1]); + d__1 = sqrt(rwork[irwork + k - 1]); + z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1; + tmp.r = z__1.r, tmp.i = z__1.i; + zscal_(n, &tmp, &vr[i__ * vr_dim1 + 1], &c__1); + i__2 = k + i__ * vr_dim1; + i__3 = k + i__ * vr_dim1; + d__1 = vr[i__3].r; + z__1.r = d__1, z__1.i = 0.; + vr[i__2].r = z__1.r, vr[i__2].i = z__1.i; +/* L40: */ + } + } + +/* Undo scaling if necessary */ + +L50: + if (scalea) { + i__1 = *n - *info; +/* Computing MAX */ + i__3 = *n - *info; + i__2 = f2cmax(i__3,1); + zlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[*info + 1] + , &i__2, &ierr); + if (*info > 0) { + i__1 = ilo - 1; + zlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[1], n, + &ierr); + } + } + + work[1].r = (doublereal) maxwrk, work[1].i = 0.; + return 0; + +/* End of ZGEEV */ + +} /* zgeev_ */ + diff --git a/lapack-netlib/SRC/zgeevx.c b/lapack-netlib/SRC/zgeevx.c new file mode 100644 index 000000000..ffe0b613d --- /dev/null +++ b/lapack-netlib/SRC/zgeevx.c @@ -0,0 +1,1175 @@ +/* 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 ZGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE mat +rices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEEVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, W, VL, */ +/* LDVL, VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, */ +/* RCONDV, WORK, LWORK, RWORK, INFO ) */ + +/* CHARACTER BALANC, JOBVL, JOBVR, SENSE */ +/* INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N */ +/* DOUBLE PRECISION ABNRM */ +/* DOUBLE PRECISION RCONDE( * ), RCONDV( * ), RWORK( * ), */ +/* $ SCALE( * ) */ +/* COMPLEX*16 A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ), */ +/* $ W( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEEVX computes for an N-by-N complex nonsymmetric matrix A, the */ +/* > eigenvalues and, optionally, the left and/or right eigenvectors. */ +/* > */ +/* > Optionally also, it computes a balancing transformation to improve */ +/* > the conditioning of the eigenvalues and eigenvectors (ILO, IHI, */ +/* > SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues */ +/* > (RCONDE), and reciprocal condition numbers for the right */ +/* > eigenvectors (RCONDV). */ +/* > */ +/* > The right eigenvector v(j) of A satisfies */ +/* > A * v(j) = lambda(j) * v(j) */ +/* > where lambda(j) is its eigenvalue. */ +/* > The left eigenvector u(j) of A satisfies */ +/* > u(j)**H * A = lambda(j) * u(j)**H */ +/* > where u(j)**H denotes the conjugate transpose of u(j). */ +/* > */ +/* > The computed eigenvectors are normalized to have Euclidean norm */ +/* > equal to 1 and largest component real. */ +/* > */ +/* > Balancing a matrix means permuting the rows and columns to make it */ +/* > more nearly upper triangular, and applying a diagonal similarity */ +/* > transformation D * A * D**(-1), where D is a diagonal matrix, to */ +/* > make its rows and columns closer in norm and the condition numbers */ +/* > of its eigenvalues and eigenvectors smaller. The computed */ +/* > reciprocal condition numbers correspond to the balanced matrix. */ +/* > Permuting rows and columns will not change the condition numbers */ +/* > (in exact arithmetic) but diagonal scaling will. For further */ +/* > explanation of balancing, see section 4.10.2 of the LAPACK */ +/* > Users' Guide. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] BALANC */ +/* > \verbatim */ +/* > BALANC is CHARACTER*1 */ +/* > Indicates how the input matrix should be diagonally scaled */ +/* > and/or permuted to improve the conditioning of its */ +/* > eigenvalues. */ +/* > = 'N': Do not diagonally scale or permute; */ +/* > = 'P': Perform permutations to make the matrix more nearly */ +/* > upper triangular. Do not diagonally scale; */ +/* > = 'S': Diagonally scale the matrix, ie. replace A by */ +/* > D*A*D**(-1), where D is a diagonal matrix chosen */ +/* > to make the rows and columns of A more equal in */ +/* > norm. Do not permute; */ +/* > = 'B': Both diagonally scale and permute A. */ +/* > */ +/* > Computed reciprocal condition numbers will be for the matrix */ +/* > after balancing and/or permuting. Permuting does not change */ +/* > condition numbers (in exact arithmetic), but balancing does. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBVL */ +/* > \verbatim */ +/* > JOBVL is CHARACTER*1 */ +/* > = 'N': left eigenvectors of A are not computed; */ +/* > = 'V': left eigenvectors of A are computed. */ +/* > If SENSE = 'E' or 'B', JOBVL must = 'V'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBVR */ +/* > \verbatim */ +/* > JOBVR is CHARACTER*1 */ +/* > = 'N': right eigenvectors of A are not computed; */ +/* > = 'V': right eigenvectors of A are computed. */ +/* > If SENSE = 'E' or 'B', JOBVR must = 'V'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SENSE */ +/* > \verbatim */ +/* > SENSE is CHARACTER*1 */ +/* > Determines which reciprocal condition numbers are computed. */ +/* > = 'N': None are computed; */ +/* > = 'E': Computed for eigenvalues only; */ +/* > = 'V': Computed for right eigenvectors only; */ +/* > = 'B': Computed for eigenvalues and right eigenvectors. */ +/* > */ +/* > If SENSE = 'E' or 'B', both left and right eigenvectors */ +/* > must also be computed (JOBVL = 'V' and JOBVR = 'V'). */ +/* > \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 N-by-N matrix A. */ +/* > On exit, A has been overwritten. If JOBVL = 'V' or */ +/* > JOBVR = 'V', A contains the Schur form of the balanced */ +/* > version of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is COMPLEX*16 array, dimension (N) */ +/* > W contains the computed eigenvalues. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VL */ +/* > \verbatim */ +/* > VL is COMPLEX*16 array, dimension (LDVL,N) */ +/* > If JOBVL = 'V', the left eigenvectors u(j) are stored one */ +/* > after another in the columns of VL, in the same order */ +/* > as their eigenvalues. */ +/* > If JOBVL = 'N', VL is not referenced. */ +/* > u(j) = VL(:,j), the j-th column of VL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the array VL. LDVL >= 1; if */ +/* > JOBVL = 'V', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VR */ +/* > \verbatim */ +/* > VR is COMPLEX*16 array, dimension (LDVR,N) */ +/* > If JOBVR = 'V', the right eigenvectors v(j) are stored one */ +/* > after another in the columns of VR, in the same order */ +/* > as their eigenvalues. */ +/* > If JOBVR = 'N', VR is not referenced. */ +/* > v(j) = VR(:,j), the j-th column of VR. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the array VR. LDVR >= 1; if */ +/* > JOBVR = 'V', LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ILO */ +/* > \verbatim */ +/* > ILO is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IHI */ +/* > \verbatim */ +/* > IHI is INTEGER */ +/* > ILO and IHI are integer values determined when A was */ +/* > balanced. The balanced A(i,j) = 0 if I > J and */ +/* > J = 1,...,ILO-1 or I = IHI+1,...,N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE */ +/* > \verbatim */ +/* > SCALE is DOUBLE PRECISION array, dimension (N) */ +/* > Details of the permutations and scaling factors applied */ +/* > when balancing A. If P(j) is the index of the row and column */ +/* > interchanged with row and column j, and D(j) is the scaling */ +/* > factor applied to row and column j, then */ +/* > SCALE(J) = P(J), for J = 1,...,ILO-1 */ +/* > = D(J), for J = ILO,...,IHI */ +/* > = P(J) for J = IHI+1,...,N. */ +/* > The order in which the interchanges are made is N to IHI+1, */ +/* > then 1 to ILO-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ABNRM */ +/* > \verbatim */ +/* > ABNRM is DOUBLE PRECISION */ +/* > The one-norm of the balanced matrix (the maximum */ +/* > of the sum of absolute values of elements of any column). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCONDE */ +/* > \verbatim */ +/* > RCONDE is DOUBLE PRECISION array, dimension (N) */ +/* > RCONDE(j) is the reciprocal condition number of the j-th */ +/* > eigenvalue. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCONDV */ +/* > \verbatim */ +/* > RCONDV is DOUBLE PRECISION array, dimension (N) */ +/* > RCONDV(j) is the reciprocal condition number of the j-th */ +/* > right eigenvector. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. If SENSE = 'N' or 'E', */ +/* > LWORK >= f2cmax(1,2*N), and if SENSE = 'V' or 'B', */ +/* > LWORK >= N*N+2*N. */ +/* > For good performance, LWORK must generally be larger. */ +/* > */ +/* > 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] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: if INFO = i, the QR algorithm failed to compute all the */ +/* > eigenvalues, and no eigenvectors or condition numbers */ +/* > have been computed; elements 1:ILO-1 and i+1:N of W */ +/* > contain eigenvalues which have converged. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* @precisions fortran z -> c */ + +/* > \ingroup complex16GEeigen */ + +/* ===================================================================== */ +/* Subroutine */ int zgeevx_(char *balanc, char *jobvl, char *jobvr, char * + sense, integer *n, doublecomplex *a, integer *lda, doublecomplex *w, + doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, + integer *ilo, integer *ihi, doublereal *scale, doublereal *abnrm, + doublereal *rconde, doublereal *rcondv, doublecomplex *work, integer * + lwork, doublereal *rwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, + i__2, i__3; + doublereal d__1, d__2; + doublecomplex z__1, z__2; + + /* Local variables */ + char side[1]; + doublereal anrm; + integer ierr, itau, iwrk, nout, i__, k, icond; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *), dlabad_(doublereal *, doublereal *); + extern doublereal dznrm2_(integer *, doublecomplex *, integer *); + logical scalea; + extern doublereal dlamch_(char *); + doublereal cscale; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *), zgebak_(char *, char *, integer *, + integer *, integer *, doublereal *, integer *, doublecomplex *, + integer *, integer *), zgebal_(char *, integer *, + doublecomplex *, integer *, integer *, integer *, doublereal *, + integer *); + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + logical select[1]; + extern /* Subroutine */ int zdscal_(integer *, doublereal *, + doublecomplex *, integer *); + doublereal bignum; + extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, + integer *, doublereal *); + extern /* Subroutine */ int zgehrd_(integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *), zlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublecomplex *, + integer *, integer *), zlacpy_(char *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *); + integer minwrk, maxwrk; + logical wantvl, wntsnb; + integer hswork; + logical wntsne; + doublereal smlnum; + extern /* Subroutine */ int zhseqr_(char *, char *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *); + logical lquery, wantvr; + extern /* Subroutine */ int ztrsna_(char *, char *, logical *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublereal *, doublereal *, integer *, + integer *, doublecomplex *, integer *, doublereal *, integer *), zunghr_(integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *); + logical wntsnn, wntsnv; + char job[1]; + extern /* Subroutine */ int ztrevc3_(char *, char *, logical *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, integer *, integer *, doublecomplex *, + integer *, doublereal *, integer *, integer *); + doublereal scl, dum[1], eps; + doublecomplex tmp; + integer lwork_trevc__; + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --w; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --scale; + --rconde; + --rcondv; + --work; + --rwork; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + wantvl = lsame_(jobvl, "V"); + wantvr = lsame_(jobvr, "V"); + wntsnn = lsame_(sense, "N"); + wntsne = lsame_(sense, "E"); + wntsnv = lsame_(sense, "V"); + wntsnb = lsame_(sense, "B"); + if (! (lsame_(balanc, "N") || lsame_(balanc, "S") || lsame_(balanc, "P") + || lsame_(balanc, "B"))) { + *info = -1; + } else if (! wantvl && ! lsame_(jobvl, "N")) { + *info = -2; + } else if (! wantvr && ! lsame_(jobvr, "N")) { + *info = -3; + } else if (! (wntsnn || wntsne || wntsnb || wntsnv) || (wntsne || wntsnb) + && ! (wantvl && wantvr)) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < f2cmax(1,*n)) { + *info = -7; + } else if (*ldvl < 1 || wantvl && *ldvl < *n) { + *info = -10; + } else if (*ldvr < 1 || wantvr && *ldvr < *n) { + *info = -12; + } + +/* Compute workspace */ +/* (Note: Comments in the code beginning "Workspace:" describe the */ +/* minimal amount of workspace needed at that point in the code, */ +/* as well as the preferred amount for good performance. */ +/* CWorkspace refers to complex workspace, and RWorkspace to real */ +/* workspace. NB refers to the optimal block size for the */ +/* immediately following subroutine, as returned by ILAENV. */ +/* HSWORK refers to the workspace preferred by ZHSEQR, as */ +/* calculated below. HSWORK is computed assuming ILO=1 and IHI=N, */ +/* the worst case.) */ + + if (*info == 0) { + if (*n == 0) { + minwrk = 1; + maxwrk = 1; + } else { + maxwrk = *n + *n * ilaenv_(&c__1, "ZGEHRD", " ", n, &c__1, n, & + c__0, (ftnlen)6, (ftnlen)1); + + if (wantvl) { + ztrevc3_("L", "B", select, n, &a[a_offset], lda, &vl[ + vl_offset], ldvl, &vr[vr_offset], ldvr, n, &nout, & + work[1], &c_n1, &rwork[1], &c_n1, &ierr); + lwork_trevc__ = (integer) work[1].r; + maxwrk = f2cmax(maxwrk,lwork_trevc__); + zhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vl[ + vl_offset], ldvl, &work[1], &c_n1, info); + } else if (wantvr) { + ztrevc3_("R", "B", select, n, &a[a_offset], lda, &vl[ + vl_offset], ldvl, &vr[vr_offset], ldvr, n, &nout, & + work[1], &c_n1, &rwork[1], &c_n1, &ierr); + lwork_trevc__ = (integer) work[1].r; + maxwrk = f2cmax(maxwrk,lwork_trevc__); + zhseqr_("S", "V", n, &c__1, n, &a[a_offset], lda, &w[1], &vr[ + vr_offset], ldvr, &work[1], &c_n1, info); + } else { + if (wntsnn) { + zhseqr_("E", "N", n, &c__1, n, &a[a_offset], lda, &w[1], & + vr[vr_offset], ldvr, &work[1], &c_n1, info); + } else { + zhseqr_("S", "N", n, &c__1, n, &a[a_offset], lda, &w[1], & + vr[vr_offset], ldvr, &work[1], &c_n1, info); + } + } + hswork = (integer) work[1].r; + + if (! wantvl && ! wantvr) { + minwrk = *n << 1; + if (! (wntsnn || wntsne)) { +/* Computing MAX */ + i__1 = minwrk, i__2 = *n * *n + (*n << 1); + minwrk = f2cmax(i__1,i__2); + } + maxwrk = f2cmax(maxwrk,hswork); + if (! (wntsnn || wntsne)) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n * *n + (*n << 1); + maxwrk = f2cmax(i__1,i__2); + } + } else { + minwrk = *n << 1; + if (! (wntsnn || wntsne)) { +/* Computing MAX */ + i__1 = minwrk, i__2 = *n * *n + (*n << 1); + minwrk = f2cmax(i__1,i__2); + } + maxwrk = f2cmax(maxwrk,hswork); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + (*n - 1) * ilaenv_(&c__1, "ZUNGHR", + " ", n, &c__1, n, &c_n1, (ftnlen)6, (ftnlen)1); + maxwrk = f2cmax(i__1,i__2); + if (! (wntsnn || wntsne)) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n * *n + (*n << 1); + maxwrk = f2cmax(i__1,i__2); + } +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n << 1; + maxwrk = f2cmax(i__1,i__2); + } + maxwrk = f2cmax(maxwrk,minwrk); + } + work[1].r = (doublereal) maxwrk, work[1].i = 0.; + + if (*lwork < minwrk && ! lquery) { + *info = -20; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEEVX", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + smlnum = sqrt(smlnum) / eps; + bignum = 1. / smlnum; + +/* Scale A if f2cmax element outside range [SMLNUM,BIGNUM] */ + + icond = 0; + anrm = zlange_("M", n, n, &a[a_offset], lda, dum); + scalea = FALSE_; + if (anrm > 0. && anrm < smlnum) { + scalea = TRUE_; + cscale = smlnum; + } else if (anrm > bignum) { + scalea = TRUE_; + cscale = bignum; + } + if (scalea) { + zlascl_("G", &c__0, &c__0, &anrm, &cscale, n, n, &a[a_offset], lda, & + ierr); + } + +/* Balance the matrix and compute ABNRM */ + + zgebal_(balanc, n, &a[a_offset], lda, ilo, ihi, &scale[1], &ierr); + *abnrm = zlange_("1", n, n, &a[a_offset], lda, dum); + if (scalea) { + dum[0] = *abnrm; + dlascl_("G", &c__0, &c__0, &cscale, &anrm, &c__1, &c__1, dum, &c__1, & + ierr); + *abnrm = dum[0]; + } + +/* Reduce to upper Hessenberg form */ +/* (CWorkspace: need 2*N, prefer N+N*NB) */ +/* (RWorkspace: none) */ + + itau = 1; + iwrk = itau + *n; + i__1 = *lwork - iwrk + 1; + zgehrd_(n, ilo, ihi, &a[a_offset], lda, &work[itau], &work[iwrk], &i__1, & + ierr); + + if (wantvl) { + +/* Want left eigenvectors */ +/* Copy Householder vectors to VL */ + + *(unsigned char *)side = 'L'; + zlacpy_("L", n, n, &a[a_offset], lda, &vl[vl_offset], ldvl) + ; + +/* Generate unitary matrix in VL */ +/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */ +/* (RWorkspace: none) */ + + i__1 = *lwork - iwrk + 1; + zunghr_(n, ilo, ihi, &vl[vl_offset], ldvl, &work[itau], &work[iwrk], & + i__1, &ierr); + +/* Perform QR iteration, accumulating Schur vectors in VL */ +/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */ +/* (RWorkspace: none) */ + + iwrk = itau; + i__1 = *lwork - iwrk + 1; + zhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &w[1], &vl[ + vl_offset], ldvl, &work[iwrk], &i__1, info); + + if (wantvr) { + +/* Want left and right eigenvectors */ +/* Copy Schur vectors to VR */ + + *(unsigned char *)side = 'B'; + zlacpy_("F", n, n, &vl[vl_offset], ldvl, &vr[vr_offset], ldvr); + } + + } else if (wantvr) { + +/* Want right eigenvectors */ +/* Copy Householder vectors to VR */ + + *(unsigned char *)side = 'R'; + zlacpy_("L", n, n, &a[a_offset], lda, &vr[vr_offset], ldvr) + ; + +/* Generate unitary matrix in VR */ +/* (CWorkspace: need 2*N-1, prefer N+(N-1)*NB) */ +/* (RWorkspace: none) */ + + i__1 = *lwork - iwrk + 1; + zunghr_(n, ilo, ihi, &vr[vr_offset], ldvr, &work[itau], &work[iwrk], & + i__1, &ierr); + +/* Perform QR iteration, accumulating Schur vectors in VR */ +/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */ +/* (RWorkspace: none) */ + + iwrk = itau; + i__1 = *lwork - iwrk + 1; + zhseqr_("S", "V", n, ilo, ihi, &a[a_offset], lda, &w[1], &vr[ + vr_offset], ldvr, &work[iwrk], &i__1, info); + + } else { + +/* Compute eigenvalues only */ +/* If condition numbers desired, compute Schur form */ + + if (wntsnn) { + *(unsigned char *)job = 'E'; + } else { + *(unsigned char *)job = 'S'; + } + +/* (CWorkspace: need 1, prefer HSWORK (see comments) ) */ +/* (RWorkspace: none) */ + + iwrk = itau; + i__1 = *lwork - iwrk + 1; + zhseqr_(job, "N", n, ilo, ihi, &a[a_offset], lda, &w[1], &vr[ + vr_offset], ldvr, &work[iwrk], &i__1, info); + } + +/* If INFO .NE. 0 from ZHSEQR, then quit */ + + if (*info != 0) { + goto L50; + } + + if (wantvl || wantvr) { + +/* Compute left and/or right eigenvectors */ +/* (CWorkspace: need 2*N, prefer N + 2*N*NB) */ +/* (RWorkspace: need N) */ + + i__1 = *lwork - iwrk + 1; + ztrevc3_(side, "B", select, n, &a[a_offset], lda, &vl[vl_offset], + ldvl, &vr[vr_offset], ldvr, n, &nout, &work[iwrk], &i__1, & + rwork[1], n, &ierr); + } + +/* Compute condition numbers if desired */ +/* (CWorkspace: need N*N+2*N unless SENSE = 'E') */ +/* (RWorkspace: need 2*N unless SENSE = 'E') */ + + if (! wntsnn) { + ztrsna_(sense, "A", select, n, &a[a_offset], lda, &vl[vl_offset], + ldvl, &vr[vr_offset], ldvr, &rconde[1], &rcondv[1], n, &nout, + &work[iwrk], n, &rwork[1], &icond); + } + + if (wantvl) { + +/* Undo balancing of left eigenvectors */ + + zgebak_(balanc, "L", n, ilo, ihi, &scale[1], n, &vl[vl_offset], ldvl, + &ierr); + +/* Normalize left eigenvectors and make largest component real */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + scl = 1. / dznrm2_(n, &vl[i__ * vl_dim1 + 1], &c__1); + zdscal_(n, &scl, &vl[i__ * vl_dim1 + 1], &c__1); + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + i__3 = k + i__ * vl_dim1; +/* Computing 2nd power */ + d__1 = vl[i__3].r; +/* Computing 2nd power */ + d__2 = d_imag(&vl[k + i__ * vl_dim1]); + rwork[k] = d__1 * d__1 + d__2 * d__2; +/* $ AIMAG( VL( K, I ) )**2 */ +/* L10: */ + } + k = idamax_(n, &rwork[1], &c__1); + d_cnjg(&z__2, &vl[k + i__ * vl_dim1]); + d__1 = sqrt(rwork[k]); + z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1; + tmp.r = z__1.r, tmp.i = z__1.i; + zscal_(n, &tmp, &vl[i__ * vl_dim1 + 1], &c__1); + i__2 = k + i__ * vl_dim1; + i__3 = k + i__ * vl_dim1; + d__1 = vl[i__3].r; + z__1.r = d__1, z__1.i = 0.; + vl[i__2].r = z__1.r, vl[i__2].i = z__1.i; +/* L20: */ + } + } + + if (wantvr) { + +/* Undo balancing of right eigenvectors */ + + zgebak_(balanc, "R", n, ilo, ihi, &scale[1], n, &vr[vr_offset], ldvr, + &ierr); + +/* Normalize right eigenvectors and make largest component real */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + scl = 1. / dznrm2_(n, &vr[i__ * vr_dim1 + 1], &c__1); + zdscal_(n, &scl, &vr[i__ * vr_dim1 + 1], &c__1); + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + i__3 = k + i__ * vr_dim1; +/* Computing 2nd power */ + d__1 = vr[i__3].r; +/* Computing 2nd power */ + d__2 = d_imag(&vr[k + i__ * vr_dim1]); + rwork[k] = d__1 * d__1 + d__2 * d__2; +/* $ AIMAG( VR( K, I ) )**2 */ +/* L30: */ + } + k = idamax_(n, &rwork[1], &c__1); + d_cnjg(&z__2, &vr[k + i__ * vr_dim1]); + d__1 = sqrt(rwork[k]); + z__1.r = z__2.r / d__1, z__1.i = z__2.i / d__1; + tmp.r = z__1.r, tmp.i = z__1.i; + zscal_(n, &tmp, &vr[i__ * vr_dim1 + 1], &c__1); + i__2 = k + i__ * vr_dim1; + i__3 = k + i__ * vr_dim1; + d__1 = vr[i__3].r; + z__1.r = d__1, z__1.i = 0.; + vr[i__2].r = z__1.r, vr[i__2].i = z__1.i; +/* L40: */ + } + } + +/* Undo scaling if necessary */ + +L50: + if (scalea) { + i__1 = *n - *info; +/* Computing MAX */ + i__3 = *n - *info; + i__2 = f2cmax(i__3,1); + zlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[*info + 1] + , &i__2, &ierr); + if (*info == 0) { + if ((wntsnv || wntsnb) && icond == 0) { + dlascl_("G", &c__0, &c__0, &cscale, &anrm, n, &c__1, &rcondv[ + 1], n, &ierr); + } + } else { + i__1 = *ilo - 1; + zlascl_("G", &c__0, &c__0, &cscale, &anrm, &i__1, &c__1, &w[1], n, + &ierr); + } + } + + work[1].r = (doublereal) maxwrk, work[1].i = 0.; + return 0; + +/* End of ZGEEVX */ + +} /* zgeevx_ */ + diff --git a/lapack-netlib/SRC/zgehd2.c b/lapack-netlib/SRC/zgehd2.c new file mode 100644 index 000000000..a71df0d50 --- /dev/null +++ b/lapack-netlib/SRC/zgehd2.c @@ -0,0 +1,633 @@ +/* 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 ZGEHD2 reduces a general square matrix to upper Hessenberg form using an unblocked algorithm. +*/ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEHD2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO ) */ + +/* INTEGER IHI, ILO, INFO, LDA, N */ +/* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEHD2 reduces a complex general matrix A to upper Hessenberg form H */ +/* > by a unitary similarity transformation: Q**H * A * Q = H . */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILO */ +/* > \verbatim */ +/* > ILO is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHI */ +/* > \verbatim */ +/* > IHI is INTEGER */ +/* > */ +/* > It is assumed that A is already upper triangular in rows */ +/* > and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */ +/* > set by a previous call to ZGEBAL; otherwise they should be */ +/* > set to 1 and N respectively. See Further Details. */ +/* > 1 <= ILO <= IHI <= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the n by n general matrix to be reduced. */ +/* > On exit, the upper triangle and the first subdiagonal of A */ +/* > are overwritten with the upper Hessenberg matrix H, and the */ +/* > elements below the first subdiagonal, with the array TAU, */ +/* > represent the unitary matrix Q as a product of elementary */ +/* > reflectors. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 array, dimension (N-1) */ +/* > The scalar factors of the elementary reflectors (see Further */ +/* > Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix Q is represented as a product of (ihi-ilo) elementary */ +/* > reflectors */ +/* > */ +/* > Q = H(ilo) H(ilo+1) . . . H(ihi-1). */ +/* > */ +/* > 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) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */ +/* > exit in A(i+2:ihi,i), and tau in TAU(i). */ +/* > */ +/* > The contents of A are illustrated by the following example, with */ +/* > n = 7, ilo = 2 and ihi = 6: */ +/* > */ +/* > on entry, on exit, */ +/* > */ +/* > ( a a a a a a a ) ( a a h h h h a ) */ +/* > ( a a a a a a ) ( a h h h h a ) */ +/* > ( a a a a a a ) ( h h h h h h ) */ +/* > ( a a a a a a ) ( v2 h h h h h ) */ +/* > ( a a a a a a ) ( v2 v3 h h h h ) */ +/* > ( a a a a a a ) ( v2 v3 v4 h h h ) */ +/* > ( a ) ( a ) */ +/* > */ +/* > where a denotes an element of the original matrix A, h denotes a */ +/* > modified element of the upper Hessenberg matrix H, and vi denotes an */ +/* > element of the vector defining H(i). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgehd2_(integer *n, integer *ilo, integer *ihi, + doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex * + work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublecomplex z__1; + + /* Local variables */ + integer i__; + doublecomplex alpha; + extern /* Subroutine */ int zlarf_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *), xerbla_(char *, integer *, ftnlen), zlarfg_(integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*ilo < 1 || *ilo > f2cmax(1,*n)) { + *info = -2; + } else if (*ihi < f2cmin(*ilo,*n) || *ihi > *n) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEHD2", &i__1, (ftnlen)6); + return 0; + } + + i__1 = *ihi - 1; + for (i__ = *ilo; i__ <= i__1; ++i__) { + +/* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i) */ + + i__2 = i__ + 1 + i__ * a_dim1; + alpha.r = a[i__2].r, alpha.i = a[i__2].i; + i__2 = *ihi - i__; +/* Computing MIN */ + i__3 = i__ + 2; + zlarfg_(&i__2, &alpha, &a[f2cmin(i__3,*n) + i__ * a_dim1], &c__1, &tau[ + i__]); + i__2 = i__ + 1 + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + +/* Apply H(i) to A(1:ihi,i+1:ihi) from the right */ + + i__2 = *ihi - i__; + zlarf_("Right", ihi, &i__2, &a[i__ + 1 + i__ * a_dim1], &c__1, &tau[ + i__], &a[(i__ + 1) * a_dim1 + 1], lda, &work[1]); + +/* Apply H(i)**H to A(i+1:ihi,i+1:n) from the left */ + + i__2 = *ihi - i__; + i__3 = *n - i__; + d_cnjg(&z__1, &tau[i__]); + zlarf_("Left", &i__2, &i__3, &a[i__ + 1 + i__ * a_dim1], &c__1, &z__1, + &a[i__ + 1 + (i__ + 1) * a_dim1], lda, &work[1]); + + i__2 = i__ + 1 + i__ * a_dim1; + a[i__2].r = alpha.r, a[i__2].i = alpha.i; +/* L10: */ + } + + return 0; + +/* End of ZGEHD2 */ + +} /* zgehd2_ */ + diff --git a/lapack-netlib/SRC/zgehrd.c b/lapack-netlib/SRC/zgehrd.c new file mode 100644 index 000000000..e7b334044 --- /dev/null +++ b/lapack-netlib/SRC/zgehrd.c @@ -0,0 +1,796 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#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 ZGEHRD */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEHRD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO ) */ + +/* INTEGER IHI, ILO, INFO, LDA, LWORK, N */ +/* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEHRD reduces a complex general matrix A to upper Hessenberg form H by */ +/* > an unitary similarity transformation: Q**H * A * Q = H . */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILO */ +/* > \verbatim */ +/* > ILO is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHI */ +/* > \verbatim */ +/* > IHI is INTEGER */ +/* > */ +/* > It is assumed that A is already upper triangular in rows */ +/* > and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */ +/* > set by a previous call to ZGEBAL; otherwise they should be */ +/* > set to 1 and N respectively. See Further Details. */ +/* > 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the N-by-N general matrix to be reduced. */ +/* > On exit, the upper triangle and the first subdiagonal of A */ +/* > are overwritten with the upper Hessenberg matrix H, and the */ +/* > elements below the first subdiagonal, with the array TAU, */ +/* > represent the unitary matrix Q as a product of elementary */ +/* > reflectors. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 array, dimension (N-1) */ +/* > The scalar factors of the elementary reflectors (see Further */ +/* > Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to */ +/* > zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (LWORK) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of the array WORK. LWORK >= f2cmax(1,N). */ +/* > For good performance, LWORK should generally be larger. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix Q is represented as a product of (ihi-ilo) elementary */ +/* > reflectors */ +/* > */ +/* > Q = H(ilo) H(ilo+1) . . . H(ihi-1). */ +/* > */ +/* > 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) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on */ +/* > exit in A(i+2:ihi,i), and tau in TAU(i). */ +/* > */ +/* > The contents of A are illustrated by the following example, with */ +/* > n = 7, ilo = 2 and ihi = 6: */ +/* > */ +/* > on entry, on exit, */ +/* > */ +/* > ( a a a a a a a ) ( a a h h h h a ) */ +/* > ( a a a a a a ) ( a h h h h a ) */ +/* > ( a a a a a a ) ( h h h h h h ) */ +/* > ( a a a a a a ) ( v2 h h h h h ) */ +/* > ( a a a a a a ) ( v2 v3 h h h h ) */ +/* > ( a a a a a a ) ( v2 v3 v4 h h h ) */ +/* > ( 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 file is a slight modification of LAPACK-3.0's DGEHRD */ +/* > subroutine incorporating improvements proposed by Quintana-Orti and */ +/* > Van de Geijn (2006). (See DLAHR2.) */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgehrd_(integer *n, integer *ilo, integer *ihi, + doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex * + work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + doublecomplex z__1; + + /* Local variables */ + integer i__, j, nbmin, iinfo; + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *), ztrmm_(char *, char *, char *, char *, + integer *, integer *, doublecomplex *, doublecomplex *, integer * + , doublecomplex *, integer *), + zaxpy_(integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *), zgehd2_(integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *), zlahr2_(integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *); + integer ib; + doublecomplex ei; + integer nb, nh, nx; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *, + integer *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + integer ldwork, lwkopt; + logical lquery; + integer iwt; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (*n < 0) { + *info = -1; + } else if (*ilo < 1 || *ilo > f2cmax(1,*n)) { + *info = -2; + } else if (*ihi < f2cmin(*ilo,*n) || *ihi > *n) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*lwork < f2cmax(1,*n) && ! lquery) { + *info = -8; + } + + if (*info == 0) { + +/* Compute the workspace requirements */ + +/* Computing MIN */ + i__1 = 64, i__2 = ilaenv_(&c__1, "ZGEHRD", " ", n, ilo, ihi, &c_n1, ( + ftnlen)6, (ftnlen)1); + nb = f2cmin(i__1,i__2); + lwkopt = *n * nb + 4160; + work[1].r = (doublereal) lwkopt, work[1].i = 0.; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEHRD", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero */ + + i__1 = *ilo - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + tau[i__2].r = 0., tau[i__2].i = 0.; +/* L10: */ + } + i__1 = *n - 1; + for (i__ = f2cmax(1,*ihi); i__ <= i__1; ++i__) { + i__2 = i__; + tau[i__2].r = 0., tau[i__2].i = 0.; +/* L20: */ + } + +/* Quick return if possible */ + + nh = *ihi - *ilo + 1; + if (nh <= 1) { + work[1].r = 1., work[1].i = 0.; + return 0; + } + +/* Determine the block size */ + +/* Computing MIN */ + i__1 = 64, i__2 = ilaenv_(&c__1, "ZGEHRD", " ", n, ilo, ihi, &c_n1, ( + ftnlen)6, (ftnlen)1); + nb = f2cmin(i__1,i__2); + nbmin = 2; + if (nb > 1 && nb < nh) { + +/* Determine when to cross over from blocked to unblocked code */ +/* (last block is always handled by unblocked code) */ + +/* Computing MAX */ + i__1 = nb, i__2 = ilaenv_(&c__3, "ZGEHRD", " ", n, ilo, ihi, &c_n1, ( + ftnlen)6, (ftnlen)1); + nx = f2cmax(i__1,i__2); + if (nx < nh) { + +/* Determine if workspace is large enough for blocked code */ + + if (*lwork < *n * nb + 4160) { + +/* Not enough workspace to use optimal NB: determine the */ +/* minimum value of NB, and reduce NB or force use of */ +/* unblocked code */ + +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "ZGEHRD", " ", n, ilo, ihi, & + c_n1, (ftnlen)6, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + if (*lwork >= *n * nbmin + 4160) { + nb = (*lwork - 4160) / *n; + } else { + nb = 1; + } + } + } + } + ldwork = *n; + + if (nb < nbmin || nb >= nh) { + +/* Use unblocked code below */ + + i__ = *ilo; + + } else { + +/* Use blocked code */ + + iwt = *n * nb + 1; + i__1 = *ihi - 1 - nx; + i__2 = nb; + for (i__ = *ilo; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = nb, i__4 = *ihi - i__; + ib = f2cmin(i__3,i__4); + +/* Reduce columns i:i+ib-1 to Hessenberg form, returning the */ +/* matrices V and T of the block reflector H = I - V*T*V**H */ +/* which performs the reduction, and also the matrix Y = A*V*T */ + + zlahr2_(ihi, &i__, &ib, &a[i__ * a_dim1 + 1], lda, &tau[i__], & + work[iwt], &c__65, &work[1], &ldwork); + +/* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the */ +/* right, computing A := A - Y * V**H. V(i+ib,ib-1) must be set */ +/* to 1 */ + + i__3 = i__ + ib + (i__ + ib - 1) * a_dim1; + ei.r = a[i__3].r, ei.i = a[i__3].i; + i__3 = i__ + ib + (i__ + ib - 1) * a_dim1; + a[i__3].r = 1., a[i__3].i = 0.; + i__3 = *ihi - i__ - ib + 1; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Conjugate transpose", ihi, &i__3, &ib, & + z__1, &work[1], &ldwork, &a[i__ + ib + i__ * a_dim1], lda, + &c_b2, &a[(i__ + ib) * a_dim1 + 1], lda); + i__3 = i__ + ib + (i__ + ib - 1) * a_dim1; + a[i__3].r = ei.r, a[i__3].i = ei.i; + +/* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the */ +/* right */ + + i__3 = ib - 1; + ztrmm_("Right", "Lower", "Conjugate transpose", "Unit", &i__, & + i__3, &c_b2, &a[i__ + 1 + i__ * a_dim1], lda, &work[1], & + ldwork); + i__3 = ib - 2; + for (j = 0; j <= i__3; ++j) { + z__1.r = -1., z__1.i = 0.; + zaxpy_(&i__, &z__1, &work[ldwork * j + 1], &c__1, &a[(i__ + j + + 1) * a_dim1 + 1], &c__1); +/* L30: */ + } + +/* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the */ +/* left */ + + i__3 = *ihi - i__; + i__4 = *n - i__ - ib + 1; + zlarfb_("Left", "Conjugate transpose", "Forward", "Columnwise", & + i__3, &i__4, &ib, &a[i__ + 1 + i__ * a_dim1], lda, &work[ + iwt], &c__65, &a[i__ + 1 + (i__ + ib) * a_dim1], lda, & + work[1], &ldwork); +/* L40: */ + } + } + +/* Use unblocked code to reduce the rest of the matrix */ + + zgehd2_(n, &i__, ihi, &a[a_offset], lda, &tau[1], &work[1], &iinfo); + work[1].r = (doublereal) lwkopt, work[1].i = 0.; + + return 0; + +/* End of ZGEHRD */ + +} /* zgehrd_ */ + diff --git a/lapack-netlib/SRC/zgejsv.c b/lapack-netlib/SRC/zgejsv.c new file mode 100644 index 000000000..1ac58d86a --- /dev/null +++ b/lapack-netlib/SRC/zgejsv.c @@ -0,0 +1,3434 @@ +/* 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 ZGEJSV */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEJSV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEJSV( JOBA, JOBU, JOBV, JOBR, JOBT, JOBP, */ +/* M, N, A, LDA, SVA, U, LDU, V, LDV, */ +/* CWORK, LWORK, RWORK, LRWORK, IWORK, INFO ) */ + +/* IMPLICIT NONE */ +/* INTEGER INFO, LDA, LDU, LDV, LWORK, M, N */ +/* COMPLEX*16 A( LDA, * ), U( LDU, * ), V( LDV, * ), CWORK( LWORK ) */ +/* DOUBLE PRECISION SVA( N ), RWORK( LRWORK ) */ +/* INTEGER IWORK( * ) */ +/* CHARACTER*1 JOBA, JOBP, JOBR, JOBT, JOBU, JOBV */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEJSV computes the singular value decomposition (SVD) of a complex M-by-N */ +/* > matrix [A], where M >= N. The SVD of [A] is written as */ +/* > */ +/* > [A] = [U] * [SIGMA] * [V]^*, */ +/* > */ +/* > where [SIGMA] is an N-by-N (M-by-N) matrix which is zero except for its N */ +/* > diagonal elements, [U] is an M-by-N (or M-by-M) unitary matrix, and */ +/* > [V] is an N-by-N unitary matrix. The diagonal elements of [SIGMA] are */ +/* > the singular values of [A]. The columns of [U] and [V] are the left and */ +/* > the right singular vectors of [A], respectively. The matrices [U] and [V] */ +/* > are computed and stored in the arrays U and V, respectively. The diagonal */ +/* > of [SIGMA] is computed and stored in the array SVA. */ +/* > \endverbatim */ +/* > */ +/* > Arguments: */ +/* > ========== */ +/* > */ +/* > \param[in] JOBA */ +/* > \verbatim */ +/* > JOBA is CHARACTER*1 */ +/* > Specifies the level of accuracy: */ +/* > = 'C': This option works well (high relative accuracy) if A = B * D, */ +/* > with well-conditioned B and arbitrary diagonal matrix D. */ +/* > The accuracy cannot be spoiled by COLUMN scaling. The */ +/* > accuracy of the computed output depends on the condition of */ +/* > B, and the procedure aims at the best theoretical accuracy. */ +/* > The relative error max_{i=1:N}|d sigma_i| / sigma_i is */ +/* > bounded by f(M,N)*epsilon* cond(B), independent of D. */ +/* > The input matrix is preprocessed with the QRF with column */ +/* > pivoting. This initial preprocessing and preconditioning by */ +/* > a rank revealing QR factorization is common for all values of */ +/* > JOBA. Additional actions are specified as follows: */ +/* > = 'E': Computation as with 'C' with an additional estimate of the */ +/* > condition number of B. It provides a realistic error bound. */ +/* > = 'F': If A = D1 * C * D2 with ill-conditioned diagonal scalings */ +/* > D1, D2, and well-conditioned matrix C, this option gives */ +/* > higher accuracy than the 'C' option. If the structure of the */ +/* > input matrix is not known, and relative accuracy is */ +/* > desirable, then this option is advisable. The input matrix A */ +/* > is preprocessed with QR factorization with FULL (row and */ +/* > column) pivoting. */ +/* > = 'G': Computation as with 'F' with an additional estimate of the */ +/* > condition number of B, where A=B*D. If A has heavily weighted */ +/* > rows, then using this condition number gives too pessimistic */ +/* > error bound. */ +/* > = 'A': Small singular values are not well determined by the data */ +/* > and are considered as noisy; the matrix is treated as */ +/* > numerically rank deficient. The error in the computed */ +/* > singular values is bounded by f(m,n)*epsilon*||A||. */ +/* > The computed SVD A = U * S * V^* restores A up to */ +/* > f(m,n)*epsilon*||A||. */ +/* > This gives the procedure the licence to discard (set to zero) */ +/* > all singular values below N*epsilon*||A||. */ +/* > = 'R': Similar as in 'A'. Rank revealing property of the initial */ +/* > QR factorization is used do reveal (using triangular factor) */ +/* > a gap sigma_{r+1} < epsilon * sigma_r in which case the */ +/* > numerical RANK is declared to be r. The SVD is computed with */ +/* > absolute error bounds, but more accurately than with 'A'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBU */ +/* > \verbatim */ +/* > JOBU is CHARACTER*1 */ +/* > Specifies whether to compute the columns of U: */ +/* > = 'U': N columns of U are returned in the array U. */ +/* > = 'F': full set of M left sing. vectors is returned in the array U. */ +/* > = 'W': U may be used as workspace of length M*N. See the description */ +/* > of U. */ +/* > = 'N': U is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBV */ +/* > \verbatim */ +/* > JOBV is CHARACTER*1 */ +/* > Specifies whether to compute the matrix V: */ +/* > = 'V': N columns of V are returned in the array V; Jacobi rotations */ +/* > are not explicitly accumulated. */ +/* > = 'J': N columns of V are returned in the array V, but they are */ +/* > computed as the product of Jacobi rotations, if JOBT = 'N'. */ +/* > = 'W': V may be used as workspace of length N*N. See the description */ +/* > of V. */ +/* > = 'N': V is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBR */ +/* > \verbatim */ +/* > JOBR is CHARACTER*1 */ +/* > Specifies the RANGE for the singular values. Issues the licence to */ +/* > set to zero small positive singular values if they are outside */ +/* > specified range. If A .NE. 0 is scaled so that the largest singular */ +/* > value of c*A is around SQRT(BIG), BIG=DLAMCH('O'), then JOBR issues */ +/* > the licence to kill columns of A whose norm in c*A is less than */ +/* > SQRT(SFMIN) (for JOBR = 'R'), or less than SMALL=SFMIN/EPSLN, */ +/* > where SFMIN=DLAMCH('S'), EPSLN=DLAMCH('E'). */ +/* > = 'N': Do not kill small columns of c*A. This option assumes that */ +/* > BLAS and QR factorizations and triangular solvers are */ +/* > implemented to work in that range. If the condition of A */ +/* > is greater than BIG, use ZGESVJ. */ +/* > = 'R': RESTRICTED range for sigma(c*A) is [SQRT(SFMIN), SQRT(BIG)] */ +/* > (roughly, as described above). This option is recommended. */ +/* > =========================== */ +/* > For computing the singular values in the FULL range [SFMIN,BIG] */ +/* > use ZGESVJ. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBT */ +/* > \verbatim */ +/* > JOBT is CHARACTER*1 */ +/* > If the matrix is square then the procedure may determine to use */ +/* > transposed A if A^* seems to be better with respect to convergence. */ +/* > If the matrix is not square, JOBT is ignored. */ +/* > The decision is based on two values of entropy over the adjoint */ +/* > orbit of A^* * A. See the descriptions of WORK(6) and WORK(7). */ +/* > = 'T': transpose if entropy test indicates possibly faster */ +/* > convergence of Jacobi process if A^* is taken as input. If A is */ +/* > replaced with A^*, then the row pivoting is included automatically. */ +/* > = 'N': do not speculate. */ +/* > The option 'T' can be used to compute only the singular values, or */ +/* > the full SVD (U, SIGMA and V). For only one set of singular vectors */ +/* > (U or V), the caller should provide both U and V, as one of the */ +/* > matrices is used as workspace if the matrix A is transposed. */ +/* > The implementer can easily remove this constraint and make the */ +/* > code more complicated. See the descriptions of U and V. */ +/* > In general, this option is considered experimental, and 'N'; should */ +/* > be preferred. This is subject to changes in the future. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBP */ +/* > \verbatim */ +/* > JOBP is CHARACTER*1 */ +/* > Issues the licence to introduce structured perturbations to drown */ +/* > denormalized numbers. This licence should be active if the */ +/* > denormals are poorly implemented, causing slow computation, */ +/* > especially in cases of fast convergence (!). For details see [1,2]. */ +/* > For the sake of simplicity, this perturbations are included only */ +/* > when the full SVD or only the singular values are requested. The */ +/* > implementer/user can easily add the perturbation for the cases of */ +/* > computing one set of singular vectors. */ +/* > = 'P': introduce perturbation */ +/* > = 'N': do not perturb */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the input matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the input matrix A. M >= N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, 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[out] SVA */ +/* > \verbatim */ +/* > SVA is DOUBLE PRECISION array, dimension (N) */ +/* > On exit, */ +/* > - For WORK(1)/WORK(2) = ONE: The singular values of A. During the */ +/* > computation SVA contains Euclidean column norms of the */ +/* > iterated matrices in the array A. */ +/* > - For WORK(1) .NE. WORK(2): The singular values of A are */ +/* > (WORK(1)/WORK(2)) * SVA(1:N). This factored form is used if */ +/* > sigma_max(A) overflows or if small singular values have been */ +/* > saved from underflow by scaling the input matrix A. */ +/* > - If JOBR='R' then some of the singular values may be returned */ +/* > as exact zeros obtained by "set to zero" because they are */ +/* > below the numerical rank threshold or are denormalized numbers. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] U */ +/* > \verbatim */ +/* > U is COMPLEX*16 array, dimension ( LDU, N ) */ +/* > If JOBU = 'U', then U contains on exit the M-by-N matrix of */ +/* > the left singular vectors. */ +/* > If JOBU = 'F', then U contains on exit the M-by-M matrix of */ +/* > the left singular vectors, including an ONB */ +/* > of the orthogonal complement of the Range(A). */ +/* > If JOBU = 'W' .AND. (JOBV = 'V' .AND. JOBT = 'T' .AND. M = N), */ +/* > then U is used as workspace if the procedure */ +/* > replaces A with A^*. In that case, [V] is computed */ +/* > in U as left singular vectors of A^* and then */ +/* > copied back to the V array. This 'W' option is just */ +/* > a reminder to the caller that in this case U is */ +/* > reserved as workspace of length N*N. */ +/* > If JOBU = 'N' U is not referenced, unless JOBT='T'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > The leading dimension of the array U, LDU >= 1. */ +/* > IF JOBU = 'U' or 'F' or 'W', then LDU >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is COMPLEX*16 array, dimension ( LDV, N ) */ +/* > If JOBV = 'V', 'J' then V contains on exit the N-by-N matrix of */ +/* > the right singular vectors; */ +/* > If JOBV = 'W', AND (JOBU = 'U' AND JOBT = 'T' AND M = N), */ +/* > then V is used as workspace if the pprocedure */ +/* > replaces A with A^*. In that case, [U] is computed */ +/* > in V as right singular vectors of A^* and then */ +/* > copied back to the U array. This 'W' option is just */ +/* > a reminder to the caller that in this case V is */ +/* > reserved as workspace of length N*N. */ +/* > If JOBV = 'N' V is not referenced, unless JOBT='T'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V, LDV >= 1. */ +/* > If JOBV = 'V' or 'J' or 'W', then LDV >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CWORK */ +/* > \verbatim */ +/* > CWORK is COMPLEX*16 array, dimension (MAX(2,LWORK)) */ +/* > If the call to ZGEJSV is a workspace query (indicated by LWORK=-1 or */ +/* > LRWORK=-1), then on exit CWORK(1) contains the required length of */ +/* > CWORK for the job parameters used in the call. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > Length of CWORK to confirm proper allocation of workspace. */ +/* > LWORK depends on the job: */ +/* > */ +/* > 1. If only SIGMA is needed ( JOBU = 'N', JOBV = 'N' ) and */ +/* > 1.1 .. no scaled condition estimate required (JOBA.NE.'E'.AND.JOBA.NE.'G'): */ +/* > LWORK >= 2*N+1. This is the minimal requirement. */ +/* > ->> For optimal performance (blocked code) the optimal value */ +/* > is LWORK >= N + (N+1)*NB. Here NB is the optimal */ +/* > block size for ZGEQP3 and ZGEQRF. */ +/* > In general, optimal LWORK is computed as */ +/* > LWORK >= f2cmax(N+LWORK(ZGEQP3),N+LWORK(ZGEQRF), LWORK(ZGESVJ)). */ +/* > 1.2. .. an estimate of the scaled condition number of A is */ +/* > required (JOBA='E', or 'G'). In this case, LWORK the minimal */ +/* > requirement is LWORK >= N*N + 2*N. */ +/* > ->> For optimal performance (blocked code) the optimal value */ +/* > is LWORK >= f2cmax(N+(N+1)*NB, N*N+2*N)=N**2+2*N. */ +/* > In general, the optimal length LWORK is computed as */ +/* > LWORK >= f2cmax(N+LWORK(ZGEQP3),N+LWORK(ZGEQRF), LWORK(ZGESVJ), */ +/* > N*N+LWORK(ZPOCON)). */ +/* > 2. If SIGMA and the right singular vectors are needed (JOBV = 'V'), */ +/* > (JOBU = 'N') */ +/* > 2.1 .. no scaled condition estimate requested (JOBE = 'N'): */ +/* > -> the minimal requirement is LWORK >= 3*N. */ +/* > -> For optimal performance, */ +/* > LWORK >= f2cmax(N+(N+1)*NB, 2*N+N*NB)=2*N+N*NB, */ +/* > where NB is the optimal block size for ZGEQP3, ZGEQRF, ZGELQ, */ +/* > ZUNMLQ. In general, the optimal length LWORK is computed as */ +/* > LWORK >= f2cmax(N+LWORK(ZGEQP3), N+LWORK(ZGESVJ), */ +/* > N+LWORK(ZGELQF), 2*N+LWORK(ZGEQRF), N+LWORK(ZUNMLQ)). */ +/* > 2.2 .. an estimate of the scaled condition number of A is */ +/* > required (JOBA='E', or 'G'). */ +/* > -> the minimal requirement is LWORK >= 3*N. */ +/* > -> For optimal performance, */ +/* > LWORK >= f2cmax(N+(N+1)*NB, 2*N,2*N+N*NB)=2*N+N*NB, */ +/* > where NB is the optimal block size for ZGEQP3, ZGEQRF, ZGELQ, */ +/* > ZUNMLQ. In general, the optimal length LWORK is computed as */ +/* > LWORK >= f2cmax(N+LWORK(ZGEQP3), LWORK(ZPOCON), N+LWORK(ZGESVJ), */ +/* > N+LWORK(ZGELQF), 2*N+LWORK(ZGEQRF), N+LWORK(ZUNMLQ)). */ +/* > 3. If SIGMA and the left singular vectors are needed */ +/* > 3.1 .. no scaled condition estimate requested (JOBE = 'N'): */ +/* > -> the minimal requirement is LWORK >= 3*N. */ +/* > -> For optimal performance: */ +/* > if JOBU = 'U' :: LWORK >= f2cmax(3*N, N+(N+1)*NB, 2*N+N*NB)=2*N+N*NB, */ +/* > where NB is the optimal block size for ZGEQP3, ZGEQRF, ZUNMQR. */ +/* > In general, the optimal length LWORK is computed as */ +/* > LWORK >= f2cmax(N+LWORK(ZGEQP3), 2*N+LWORK(ZGEQRF), N+LWORK(ZUNMQR)). */ +/* > 3.2 .. an estimate of the scaled condition number of A is */ +/* > required (JOBA='E', or 'G'). */ +/* > -> the minimal requirement is LWORK >= 3*N. */ +/* > -> For optimal performance: */ +/* > if JOBU = 'U' :: LWORK >= f2cmax(3*N, N+(N+1)*NB, 2*N+N*NB)=2*N+N*NB, */ +/* > where NB is the optimal block size for ZGEQP3, ZGEQRF, ZUNMQR. */ +/* > In general, the optimal length LWORK is computed as */ +/* > LWORK >= f2cmax(N+LWORK(ZGEQP3),N+LWORK(ZPOCON), */ +/* > 2*N+LWORK(ZGEQRF), N+LWORK(ZUNMQR)). */ +/* > 4. If the full SVD is needed: (JOBU = 'U' or JOBU = 'F') and */ +/* > 4.1. if JOBV = 'V' */ +/* > the minimal requirement is LWORK >= 5*N+2*N*N. */ +/* > 4.2. if JOBV = 'J' the minimal requirement is */ +/* > LWORK >= 4*N+N*N. */ +/* > In both cases, the allocated CWORK can accommodate blocked runs */ +/* > of ZGEQP3, ZGEQRF, ZGELQF, SUNMQR, ZUNMLQ. */ +/* > */ +/* > If the call to ZGEJSV is a workspace query (indicated by LWORK=-1 or */ +/* > LRWORK=-1), then on exit CWORK(1) contains the optimal and CWORK(2) contains the */ +/* > minimal length of CWORK for the job parameters used in the call. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (MAX(7,LWORK)) */ +/* > On exit, */ +/* > RWORK(1) = Determines the scaling factor SCALE = RWORK(2) / RWORK(1) */ +/* > such that SCALE*SVA(1:N) are the computed singular values */ +/* > of A. (See the description of SVA().) */ +/* > RWORK(2) = See the description of RWORK(1). */ +/* > RWORK(3) = SCONDA is an estimate for the condition number of */ +/* > column equilibrated A. (If JOBA = 'E' or 'G') */ +/* > SCONDA is an estimate of SQRT(||(R^* * R)^(-1)||_1). */ +/* > It is computed using SPOCON. It holds */ +/* > N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA */ +/* > where R is the triangular factor from the QRF of A. */ +/* > However, if R is truncated and the numerical rank is */ +/* > determined to be strictly smaller than N, SCONDA is */ +/* > returned as -1, thus indicating that the smallest */ +/* > singular values might be lost. */ +/* > */ +/* > If full SVD is needed, the following two condition numbers are */ +/* > useful for the analysis of the algorithm. They are provied for */ +/* > a developer/implementer who is familiar with the details of */ +/* > the method. */ +/* > */ +/* > RWORK(4) = an estimate of the scaled condition number of the */ +/* > triangular factor in the first QR factorization. */ +/* > RWORK(5) = an estimate of the scaled condition number of the */ +/* > triangular factor in the second QR factorization. */ +/* > The following two parameters are computed if JOBT = 'T'. */ +/* > They are provided for a developer/implementer who is familiar */ +/* > with the details of the method. */ +/* > RWORK(6) = the entropy of A^* * A :: this is the Shannon entropy */ +/* > of diag(A^* * A) / Trace(A^* * A) taken as point in the */ +/* > probability simplex. */ +/* > RWORK(7) = the entropy of A * A^*. (See the description of RWORK(6).) */ +/* > If the call to ZGEJSV is a workspace query (indicated by LWORK=-1 or */ +/* > LRWORK=-1), then on exit RWORK(1) contains the required length of */ +/* > RWORK for the job parameters used in the call. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LRWORK */ +/* > \verbatim */ +/* > LRWORK is INTEGER */ +/* > Length of RWORK to confirm proper allocation of workspace. */ +/* > LRWORK depends on the job: */ +/* > */ +/* > 1. If only the singular values are requested i.e. if */ +/* > LSAME(JOBU,'N') .AND. LSAME(JOBV,'N') */ +/* > then: */ +/* > 1.1. If LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G'), */ +/* > then: LRWORK = f2cmax( 7, 2 * M ). */ +/* > 1.2. Otherwise, LRWORK = f2cmax( 7, N ). */ +/* > 2. If singular values with the right singular vectors are requested */ +/* > i.e. if */ +/* > (LSAME(JOBV,'V').OR.LSAME(JOBV,'J')) .AND. */ +/* > .NOT.(LSAME(JOBU,'U').OR.LSAME(JOBU,'F')) */ +/* > then: */ +/* > 2.1. If LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G'), */ +/* > then LRWORK = f2cmax( 7, 2 * M ). */ +/* > 2.2. Otherwise, LRWORK = f2cmax( 7, N ). */ +/* > 3. If singular values with the left singular vectors are requested, i.e. if */ +/* > (LSAME(JOBU,'U').OR.LSAME(JOBU,'F')) .AND. */ +/* > .NOT.(LSAME(JOBV,'V').OR.LSAME(JOBV,'J')) */ +/* > then: */ +/* > 3.1. If LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G'), */ +/* > then LRWORK = f2cmax( 7, 2 * M ). */ +/* > 3.2. Otherwise, LRWORK = f2cmax( 7, N ). */ +/* > 4. If singular values with both the left and the right singular vectors */ +/* > are requested, i.e. if */ +/* > (LSAME(JOBU,'U').OR.LSAME(JOBU,'F')) .AND. */ +/* > (LSAME(JOBV,'V').OR.LSAME(JOBV,'J')) */ +/* > then: */ +/* > 4.1. If LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G'), */ +/* > then LRWORK = f2cmax( 7, 2 * M ). */ +/* > 4.2. Otherwise, LRWORK = f2cmax( 7, N ). */ +/* > */ +/* > If, on entry, LRWORK = -1 or LWORK=-1, a workspace query is assumed and */ +/* > the length of RWORK is returned in RWORK(1). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, of dimension at least 4, that further depends */ +/* > on the job: */ +/* > */ +/* > 1. If only the singular values are requested then: */ +/* > If ( LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G') ) */ +/* > then the length of IWORK is N+M; otherwise the length of IWORK is N. */ +/* > 2. If the singular values and the right singular vectors are requested then: */ +/* > If ( LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G') ) */ +/* > then the length of IWORK is N+M; otherwise the length of IWORK is N. */ +/* > 3. If the singular values and the left singular vectors are requested then: */ +/* > If ( LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G') ) */ +/* > then the length of IWORK is N+M; otherwise the length of IWORK is N. */ +/* > 4. If the singular values with both the left and the right singular vectors */ +/* > are requested, then: */ +/* > 4.1. If LSAME(JOBV,'J') the length of IWORK is determined as follows: */ +/* > If ( LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G') ) */ +/* > then the length of IWORK is N+M; otherwise the length of IWORK is N. */ +/* > 4.2. If LSAME(JOBV,'V') the length of IWORK is determined as follows: */ +/* > If ( LSAME(JOBT,'T') .OR. LSAME(JOBA,'F') .OR. LSAME(JOBA,'G') ) */ +/* > then the length of IWORK is 2*N+M; otherwise the length of IWORK is 2*N. */ +/* > */ +/* > On exit, */ +/* > IWORK(1) = the numerical rank determined after the initial */ +/* > QR factorization with pivoting. See the descriptions */ +/* > of JOBA and JOBR. */ +/* > IWORK(2) = the number of the computed nonzero singular values */ +/* > IWORK(3) = if nonzero, a warning message: */ +/* > If IWORK(3) = 1 then some of the column norms of A */ +/* > were denormalized floats. The requested high accuracy */ +/* > is not warranted by the data. */ +/* > IWORK(4) = 1 or -1. If IWORK(4) = 1, then the procedure used A^* to */ +/* > do the job as specified by the JOB parameters. */ +/* > If the call to ZGEJSV is a workspace query (indicated by LWORK = -1 or */ +/* > LRWORK = -1), then on exit IWORK(1) contains the required length of */ +/* > IWORK for the job parameters used in the call. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > < 0: if INFO = -i, then the i-th argument had an illegal value. */ +/* > = 0: successful exit; */ +/* > > 0: ZGEJSV did not converge in the maximal allowed number */ +/* > of sweeps. The computed values may be inaccurate. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16GEsing */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEJSV implements a preconditioned Jacobi SVD algorithm. It uses ZGEQP3, */ +/* > ZGEQRF, and ZGELQF as preprocessors and preconditioners. Optionally, an */ +/* > additional row pivoting can be used as a preprocessor, which in some */ +/* > cases results in much higher accuracy. An example is matrix A with the */ +/* > structure A = D1 * C * D2, where D1, D2 are arbitrarily ill-conditioned */ +/* > diagonal matrices and C is well-conditioned matrix. In that case, complete */ +/* > pivoting in the first QR factorizations provides accuracy dependent on the */ +/* > condition number of C, and independent of D1, D2. Such higher accuracy is */ +/* > not completely understood theoretically, but it works well in practice. */ +/* > Further, if A can be written as A = B*D, with well-conditioned B and some */ +/* > diagonal D, then the high accuracy is guaranteed, both theoretically and */ +/* > in software, independent of D. For more details see [1], [2]. */ +/* > The computational range for the singular values can be the full range */ +/* > ( UNDERFLOW,OVERFLOW ), provided that the machine arithmetic and the BLAS */ +/* > & LAPACK routines called by ZGEJSV are implemented to work in that range. */ +/* > If that is not the case, then the restriction for safe computation with */ +/* > the singular values in the range of normalized IEEE numbers is that the */ +/* > spectral condition number kappa(A)=sigma_max(A)/sigma_min(A) does not */ +/* > overflow. This code (ZGEJSV) is best used in this restricted range, */ +/* > meaning that singular values of magnitude below ||A||_2 / DLAMCH('O') are */ +/* > returned as zeros. See JOBR for details on this. */ +/* > Further, this implementation is somewhat slower than the one described */ +/* > in [1,2] due to replacement of some non-LAPACK components, and because */ +/* > the choice of some tuning parameters in the iterative part (ZGESVJ) is */ +/* > left to the implementer on a particular machine. */ +/* > The rank revealing QR factorization (in this code: ZGEQP3) should be */ +/* > implemented as in [3]. We have a new version of ZGEQP3 under development */ +/* > that is more robust than the current one in LAPACK, with a cleaner cut in */ +/* > rank deficient cases. It will be available in the SIGMA library [4]. */ +/* > If M is much larger than N, it is obvious that the initial QRF with */ +/* > column pivoting can be preprocessed by the QRF without pivoting. That */ +/* > well known trick is not used in ZGEJSV because in some cases heavy row */ +/* > weighting can be treated with complete pivoting. The overhead in cases */ +/* > M much larger than N is then only due to pivoting, but the benefits in */ +/* > terms of accuracy have prevailed. The implementer/user can incorporate */ +/* > this extra QRF step easily. The implementer can also improve data movement */ +/* > (matrix transpose, matrix copy, matrix transposed copy) - this */ +/* > implementation of ZGEJSV uses only the simplest, naive data movement. */ +/* > \endverbatim */ + +/* > \par Contributor: */ +/* ================== */ +/* > */ +/* > Zlatko Drmac, Department of Mathematics, Faculty of Science, */ +/* > University of Zagreb (Zagreb, Croatia); drmac@math.hr */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > \verbatim */ +/* > */ +/* > [1] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm I. */ +/* > SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1322-1342. */ +/* > LAPACK Working note 169. */ +/* > [2] Z. Drmac and K. Veselic: New fast and accurate Jacobi SVD algorithm II. */ +/* > SIAM J. Matrix Anal. Appl. Vol. 35, No. 2 (2008), pp. 1343-1362. */ +/* > LAPACK Working note 170. */ +/* > [3] Z. Drmac and Z. Bujanovic: On the failure of rank-revealing QR */ +/* > factorization software - a case study. */ +/* > ACM Trans. Math. Softw. Vol. 35, No 2 (2008), pp. 1-28. */ +/* > LAPACK Working note 176. */ +/* > [4] Z. Drmac: SIGMA - mathematical software library for accurate SVD, PSV, */ +/* > QSVD, (H,K)-SVD computations. */ +/* > Department of Mathematics, University of Zagreb, 2008, 2016. */ +/* > \endverbatim */ + +/* > \par Bugs, examples and comments: */ +/* ================================= */ +/* > */ +/* > Please report all bugs and send interesting examples and/or comments to */ +/* > drmac@math.hr. Thank you. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgejsv_(char *joba, char *jobu, char *jobv, char *jobr, + char *jobt, char *jobp, integer *m, integer *n, doublecomplex *a, + integer *lda, doublereal *sva, doublecomplex *u, integer *ldu, + doublecomplex *v, integer *ldv, doublecomplex *cwork, integer *lwork, + doublereal *rwork, integer *lrwork, integer *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_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; + doublecomplex z__1; + + /* Local variables */ + integer lwrk_zgesvj__; + logical defr; + doublereal aapp, aaqq; + integer lwrk_zunmlq__, lwrk_zunmqr__; + logical kill; + integer ierr, lwrk_zgeqp3n__; + doublereal temp1; + integer lwunmqrm, lwqp3, p, q; + logical jracc; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + integer lwrk_zgesvju__, lwrk_zgesvjv__; + extern logical lsame_(char *, char *); + integer lwrk_zunmqrm__; + doublecomplex ctemp; + doublereal entra, small; + integer iwoff; + doublereal sfmin; + logical lsvec; + doublereal epsln; + logical rsvec; + integer lwcon, lwlqf, lwqrf, n1; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zswap_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *); + logical l2aber; + extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *, + integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *); + doublereal condr1, condr2, uscal1, uscal2; + logical l2kill, l2rank, l2tran, l2pert; + extern /* Subroutine */ int zgeqp3_(integer *, integer *, doublecomplex *, + integer *, integer *, doublecomplex *, doublecomplex *, integer * + , doublereal *, integer *); + extern doublereal dznrm2_(integer *, doublecomplex *, integer *); + integer lrwqp3; + extern doublereal dlamch_(char *); + integer nr; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *); + extern integer idamax_(integer *, doublereal *, integer *); + doublereal scalem, sconda; + logical goscal; + doublereal aatmin, aatmax; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical noscal; + extern /* Subroutine */ int zdscal_(integer *, doublereal *, + doublecomplex *, integer *), zlacgv_(integer *, doublecomplex *, + integer *), dlassq_(integer *, doublereal *, integer *, + doublereal *, doublereal *); + extern integer izamax_(integer *, doublecomplex *, integer *); + extern /* Subroutine */ int zgelqf_(integer *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *, integer * + ), zlascl_(char *, integer *, integer *, doublereal *, doublereal + *, integer *, integer *, doublecomplex *, integer *, integer *); + doublereal entrat; + logical almort; + doublecomplex cdummy[1]; + extern /* Subroutine */ int zgeqrf_(integer *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *, integer * + ); + doublereal maxprj; + extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *), + zlaset_(char *, integer *, integer *, doublecomplex *, + doublecomplex *, doublecomplex *, integer *); + logical errest; + integer lrwcon; + extern /* Subroutine */ int zlapmr_(logical *, integer *, integer *, + doublecomplex *, integer *, integer *); + logical transp; + integer minwrk, lwsvdj; + extern /* Subroutine */ int zpocon_(char *, integer *, doublecomplex *, + integer *, doublereal *, doublereal *, doublecomplex *, + doublereal *, integer *), zgesvj_(char *, char *, char *, + integer *, integer *, doublecomplex *, integer *, doublereal *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *, + doublereal *, integer *, integer *); + doublereal rdummy[1]; + extern /* Subroutine */ int zlassq_(integer *, doublecomplex *, integer *, + doublereal *, doublereal *); + logical lquery; + extern /* Subroutine */ int zlaswp_(integer *, doublecomplex *, integer *, + integer *, integer *, integer *, integer *); + logical rowpiv; + integer optwrk; + extern /* Subroutine */ int zungqr_(integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *), zunmlq_(char *, char *, integer *, integer + *, integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *), zunmqr_(char *, char *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *); + doublereal big, cond_ok__, xsc; + integer lwrk_zgeqp3__; + doublereal big1; + integer warning, numrank, miniwrk, minrwrk, lrwsvdj, lwunmlq, lwsvdjv, + lwunmqr, lwrk_zgelqf__, lwrk_zgeqrf__; + + +/* -- 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 */ + --sva; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + --cwork; + --rwork; + --iwork; + + /* Function Body */ + lsvec = lsame_(jobu, "U") || lsame_(jobu, "F"); + jracc = lsame_(jobv, "J"); + rsvec = lsame_(jobv, "V") || jracc; + rowpiv = lsame_(joba, "F") || lsame_(joba, "G"); + l2rank = lsame_(joba, "R"); + l2aber = lsame_(joba, "A"); + errest = lsame_(joba, "E") || lsame_(joba, "G"); + l2tran = lsame_(jobt, "T") && *m == *n; + l2kill = lsame_(jobr, "R"); + defr = lsame_(jobr, "N"); + l2pert = lsame_(jobp, "P"); + + lquery = *lwork == -1 || *lrwork == -1; + + if (! (rowpiv || l2rank || l2aber || errest || lsame_(joba, "C"))) { + *info = -1; + } else if (! (lsvec || lsame_(jobu, "N") || lsame_( + jobu, "W") && rsvec && l2tran)) { + *info = -2; + } else if (! (rsvec || lsame_(jobv, "N") || lsame_( + jobv, "W") && lsvec && l2tran)) { + *info = -3; + } else if (! (l2kill || defr)) { + *info = -4; + } else if (! (lsame_(jobt, "T") || lsame_(jobt, + "N"))) { + *info = -5; + } else if (! (l2pert || lsame_(jobp, "N"))) { + *info = -6; + } else if (*m < 0) { + *info = -7; + } else if (*n < 0 || *n > *m) { + *info = -8; + } else if (*lda < *m) { + *info = -10; + } else if (lsvec && *ldu < *m) { + *info = -13; + } else if (rsvec && *ldv < *n) { + *info = -15; + } else { +/* #:) */ + *info = 0; + } + + if (*info == 0) { +/* [[The expressions for computing the minimal and the optimal */ +/* values of LCWORK, LRWORK are written with a lot of redundancy and */ +/* can be simplified. However, this verbose form is useful for */ +/* maintenance and modifications of the code.]] */ + +/* ZGEQRF of an N x N matrix, ZGELQF of an N x N matrix, */ +/* ZUNMLQ for computing N x N matrix, ZUNMQR for computing N x N */ +/* matrix, ZUNMQR for computing M x N matrix, respectively. */ + lwqp3 = *n + 1; + lwqrf = f2cmax(1,*n); + lwlqf = f2cmax(1,*n); + lwunmlq = f2cmax(1,*n); + lwunmqr = f2cmax(1,*n); + lwunmqrm = f2cmax(1,*m); + lwcon = *n << 1; +/* without and with explicit accumulation of Jacobi rotations */ +/* Computing MAX */ + i__1 = *n << 1; + lwsvdj = f2cmax(i__1,1); +/* Computing MAX */ + i__1 = *n << 1; + lwsvdjv = f2cmax(i__1,1); + lrwqp3 = *n << 1; + lrwcon = *n; + lrwsvdj = *n; + if (lquery) { + zgeqp3_(m, n, &a[a_offset], lda, &iwork[1], cdummy, cdummy, &c_n1, + rdummy, &ierr); + lwrk_zgeqp3__ = (integer) cdummy[0].r; + zgeqrf_(n, n, &a[a_offset], lda, cdummy, cdummy, &c_n1, &ierr); + lwrk_zgeqrf__ = (integer) cdummy[0].r; + zgelqf_(n, n, &a[a_offset], lda, cdummy, cdummy, &c_n1, &ierr); + lwrk_zgelqf__ = (integer) cdummy[0].r; + } + minwrk = 2; + optwrk = 2; + miniwrk = *n; + if (! (lsvec || rsvec)) { +/* only the singular values are requested */ + if (errest) { +/* Computing MAX */ +/* Computing 2nd power */ + i__3 = *n; + i__1 = *n + lwqp3, i__2 = i__3 * i__3 + lwcon, i__1 = f2cmax( + i__1,i__2), i__2 = *n + lwqrf, i__1 = f2cmax(i__1,i__2); + minwrk = f2cmax(i__1,lwsvdj); + } else { +/* Computing MAX */ + i__1 = *n + lwqp3, i__2 = *n + lwqrf, i__1 = f2cmax(i__1,i__2); + minwrk = f2cmax(i__1,lwsvdj); + } + if (lquery) { + zgesvj_("L", "N", "N", n, n, &a[a_offset], lda, &sva[1], n, & + v[v_offset], ldv, cdummy, &c_n1, rdummy, &c_n1, &ierr); + lwrk_zgesvj__ = (integer) cdummy[0].r; + if (errest) { +/* Computing MAX */ +/* Computing 2nd power */ + i__3 = *n; + i__1 = *n + lwrk_zgeqp3__, i__2 = i__3 * i__3 + lwcon, + i__1 = f2cmax(i__1,i__2), i__2 = *n + lwrk_zgeqrf__, + i__1 = f2cmax(i__1,i__2); + optwrk = f2cmax(i__1,lwrk_zgesvj__); + } else { +/* Computing MAX */ + i__1 = *n + lwrk_zgeqp3__, i__2 = *n + lwrk_zgeqrf__, + i__1 = f2cmax(i__1,i__2); + optwrk = f2cmax(i__1,lwrk_zgesvj__); + } + } + if (l2tran || rowpiv) { + if (errest) { +/* Computing MAX */ + i__1 = 7, i__2 = *m << 1, i__1 = f2cmax(i__1,i__2), i__1 = + f2cmax(i__1,lrwqp3), i__1 = f2cmax(i__1,lrwcon); + minrwrk = f2cmax(i__1,lrwsvdj); + } else { +/* Computing MAX */ + i__1 = 7, i__2 = *m << 1, i__1 = f2cmax(i__1,i__2), i__1 = + f2cmax(i__1,lrwqp3); + minrwrk = f2cmax(i__1,lrwsvdj); + } + } else { + if (errest) { +/* Computing MAX */ + i__1 = f2cmax(7,lrwqp3), i__1 = f2cmax(i__1,lrwcon); + minrwrk = f2cmax(i__1,lrwsvdj); + } else { +/* Computing MAX */ + i__1 = f2cmax(7,lrwqp3); + minrwrk = f2cmax(i__1,lrwsvdj); + } + } + if (rowpiv || l2tran) { + miniwrk += *m; + } + } else if (rsvec && ! lsvec) { +/* singular values and the right singular vectors are requested */ + if (errest) { +/* Computing MAX */ + i__1 = *n + lwqp3, i__1 = f2cmax(i__1,lwcon), i__1 = f2cmax(i__1, + lwsvdj), i__2 = *n + lwlqf, i__1 = f2cmax(i__1,i__2), + i__2 = (*n << 1) + lwqrf, i__1 = f2cmax(i__1,i__2), i__2 + = *n + lwsvdj, i__1 = f2cmax(i__1,i__2), i__2 = *n + + lwunmlq; + minwrk = f2cmax(i__1,i__2); + } else { +/* Computing MAX */ + i__1 = *n + lwqp3, i__1 = f2cmax(i__1,lwsvdj), i__2 = *n + lwlqf, + i__1 = f2cmax(i__1,i__2), i__2 = (*n << 1) + lwqrf, + i__1 = f2cmax(i__1,i__2), i__2 = *n + lwsvdj, i__1 = f2cmax( + i__1,i__2), i__2 = *n + lwunmlq; + minwrk = f2cmax(i__1,i__2); + } + if (lquery) { + zgesvj_("L", "U", "N", n, n, &u[u_offset], ldu, &sva[1], n, & + a[a_offset], lda, cdummy, &c_n1, rdummy, &c_n1, &ierr); + lwrk_zgesvj__ = (integer) cdummy[0].r; + zunmlq_("L", "C", n, n, n, &a[a_offset], lda, cdummy, &v[ + v_offset], ldv, cdummy, &c_n1, &ierr); + lwrk_zunmlq__ = (integer) cdummy[0].r; + if (errest) { +/* Computing MAX */ + i__1 = *n + lwrk_zgeqp3__, i__1 = f2cmax(i__1,lwcon), i__1 = + f2cmax(i__1,lwrk_zgesvj__), i__2 = *n + + lwrk_zgelqf__, i__1 = f2cmax(i__1,i__2), i__2 = (*n + << 1) + lwrk_zgeqrf__, i__1 = f2cmax(i__1,i__2), + i__2 = *n + lwrk_zgesvj__, i__1 = f2cmax(i__1,i__2), + i__2 = *n + lwrk_zunmlq__; + optwrk = f2cmax(i__1,i__2); + } else { +/* Computing MAX */ + i__1 = *n + lwrk_zgeqp3__, i__1 = f2cmax(i__1,lwrk_zgesvj__), + i__2 = *n + lwrk_zgelqf__, i__1 = f2cmax(i__1,i__2), + i__2 = (*n << 1) + lwrk_zgeqrf__, i__1 = f2cmax( + i__1,i__2), i__2 = *n + lwrk_zgesvj__, i__1 = f2cmax( + i__1,i__2), i__2 = *n + lwrk_zunmlq__; + optwrk = f2cmax(i__1,i__2); + } + } + if (l2tran || rowpiv) { + if (errest) { +/* Computing MAX */ + i__1 = 7, i__2 = *m << 1, i__1 = f2cmax(i__1,i__2), i__1 = + f2cmax(i__1,lrwqp3), i__1 = f2cmax(i__1,lrwsvdj); + minrwrk = f2cmax(i__1,lrwcon); + } else { +/* Computing MAX */ + i__1 = 7, i__2 = *m << 1, i__1 = f2cmax(i__1,i__2), i__1 = + f2cmax(i__1,lrwqp3); + minrwrk = f2cmax(i__1,lrwsvdj); + } + } else { + if (errest) { +/* Computing MAX */ + i__1 = f2cmax(7,lrwqp3), i__1 = f2cmax(i__1,lrwsvdj); + minrwrk = f2cmax(i__1,lrwcon); + } else { +/* Computing MAX */ + i__1 = f2cmax(7,lrwqp3); + minrwrk = f2cmax(i__1,lrwsvdj); + } + } + if (rowpiv || l2tran) { + miniwrk += *m; + } + } else if (lsvec && ! rsvec) { +/* singular values and the left singular vectors are requested */ + if (errest) { +/* Computing MAX */ + i__1 = f2cmax(lwqp3,lwcon), i__2 = *n + lwqrf, i__1 = f2cmax(i__1, + i__2), i__1 = f2cmax(i__1,lwsvdj); + minwrk = *n + f2cmax(i__1,lwunmqrm); + } else { +/* Computing MAX */ + i__1 = lwqp3, i__2 = *n + lwqrf, i__1 = f2cmax(i__1,i__2), i__1 = + f2cmax(i__1,lwsvdj); + minwrk = *n + f2cmax(i__1,lwunmqrm); + } + if (lquery) { + zgesvj_("L", "U", "N", n, n, &u[u_offset], ldu, &sva[1], n, & + a[a_offset], lda, cdummy, &c_n1, rdummy, &c_n1, &ierr); + lwrk_zgesvj__ = (integer) cdummy[0].r; + zunmqr_("L", "N", m, n, n, &a[a_offset], lda, cdummy, &u[ + u_offset], ldu, cdummy, &c_n1, &ierr); + lwrk_zunmqrm__ = (integer) cdummy[0].r; + if (errest) { +/* Computing MAX */ + i__1 = f2cmax(lwrk_zgeqp3__,lwcon), i__2 = *n + + lwrk_zgeqrf__, i__1 = f2cmax(i__1,i__2), i__1 = f2cmax( + i__1,lwrk_zgesvj__); + optwrk = *n + f2cmax(i__1,lwrk_zunmqrm__); + } else { +/* Computing MAX */ + i__1 = lwrk_zgeqp3__, i__2 = *n + lwrk_zgeqrf__, i__1 = + f2cmax(i__1,i__2), i__1 = f2cmax(i__1,lwrk_zgesvj__); + optwrk = *n + f2cmax(i__1,lwrk_zunmqrm__); + } + } + if (l2tran || rowpiv) { + if (errest) { +/* Computing MAX */ + i__1 = 7, i__2 = *m << 1, i__1 = f2cmax(i__1,i__2), i__1 = + f2cmax(i__1,lrwqp3), i__1 = f2cmax(i__1,lrwsvdj); + minrwrk = f2cmax(i__1,lrwcon); + } else { +/* Computing MAX */ + i__1 = 7, i__2 = *m << 1, i__1 = f2cmax(i__1,i__2), i__1 = + f2cmax(i__1,lrwqp3); + minrwrk = f2cmax(i__1,lrwsvdj); + } + } else { + if (errest) { +/* Computing MAX */ + i__1 = f2cmax(7,lrwqp3), i__1 = f2cmax(i__1,lrwsvdj); + minrwrk = f2cmax(i__1,lrwcon); + } else { +/* Computing MAX */ + i__1 = f2cmax(7,lrwqp3); + minrwrk = f2cmax(i__1,lrwsvdj); + } + } + if (rowpiv || l2tran) { + miniwrk += *m; + } + } else { +/* full SVD is requested */ + if (! jracc) { + if (errest) { +/* Computing MAX */ +/* Computing 2nd power */ + i__3 = *n; +/* Computing 2nd power */ + i__4 = *n; +/* Computing 2nd power */ + i__5 = *n; +/* Computing 2nd power */ + i__6 = *n; +/* Computing 2nd power */ + i__7 = *n; +/* Computing 2nd power */ + i__8 = *n; +/* Computing 2nd power */ + i__9 = *n; +/* Computing 2nd power */ + i__10 = *n; +/* Computing 2nd power */ + i__11 = *n; + i__1 = *n + lwqp3, i__2 = *n + lwcon, i__1 = f2cmax(i__1, + i__2), i__2 = (*n << 1) + i__3 * i__3 + lwcon, + i__1 = f2cmax(i__1,i__2), i__2 = (*n << 1) + lwqrf, + i__1 = f2cmax(i__1,i__2), i__2 = (*n << 1) + lwqp3, + i__1 = f2cmax(i__1,i__2), i__2 = (*n << 1) + i__4 * + i__4 + *n + lwlqf, i__1 = f2cmax(i__1,i__2), i__2 = ( + *n << 1) + i__5 * i__5 + *n + i__6 * i__6 + lwcon, + i__1 = f2cmax(i__1,i__2), i__2 = (*n << 1) + i__7 * + i__7 + *n + lwsvdj, i__1 = f2cmax(i__1,i__2), i__2 = + (*n << 1) + i__8 * i__8 + *n + lwsvdjv, i__1 = + f2cmax(i__1,i__2), i__2 = (*n << 1) + i__9 * i__9 + * + n + lwunmqr, i__1 = f2cmax(i__1,i__2), i__2 = (*n << + 1) + i__10 * i__10 + *n + lwunmlq, i__1 = f2cmax( + i__1,i__2), i__2 = *n + i__11 * i__11 + lwsvdj, + i__1 = f2cmax(i__1,i__2), i__2 = *n + lwunmqrm; + minwrk = f2cmax(i__1,i__2); + } else { +/* Computing MAX */ +/* Computing 2nd power */ + i__3 = *n; +/* Computing 2nd power */ + i__4 = *n; +/* Computing 2nd power */ + i__5 = *n; +/* Computing 2nd power */ + i__6 = *n; +/* Computing 2nd power */ + i__7 = *n; +/* Computing 2nd power */ + i__8 = *n; +/* Computing 2nd power */ + i__9 = *n; +/* Computing 2nd power */ + i__10 = *n; +/* Computing 2nd power */ + i__11 = *n; + i__1 = *n + lwqp3, i__2 = (*n << 1) + i__3 * i__3 + lwcon, + i__1 = f2cmax(i__1,i__2), i__2 = (*n << 1) + lwqrf, + i__1 = f2cmax(i__1,i__2), i__2 = (*n << 1) + lwqp3, + i__1 = f2cmax(i__1,i__2), i__2 = (*n << 1) + i__4 * + i__4 + *n + lwlqf, i__1 = f2cmax(i__1,i__2), i__2 = ( + *n << 1) + i__5 * i__5 + *n + i__6 * i__6 + lwcon, + i__1 = f2cmax(i__1,i__2), i__2 = (*n << 1) + i__7 * + i__7 + *n + lwsvdj, i__1 = f2cmax(i__1,i__2), i__2 = + (*n << 1) + i__8 * i__8 + *n + lwsvdjv, i__1 = + f2cmax(i__1,i__2), i__2 = (*n << 1) + i__9 * i__9 + * + n + lwunmqr, i__1 = f2cmax(i__1,i__2), i__2 = (*n << + 1) + i__10 * i__10 + *n + lwunmlq, i__1 = f2cmax( + i__1,i__2), i__2 = *n + i__11 * i__11 + lwsvdj, + i__1 = f2cmax(i__1,i__2), i__2 = *n + lwunmqrm; + minwrk = f2cmax(i__1,i__2); + } + miniwrk += *n; + if (rowpiv || l2tran) { + miniwrk += *m; + } + } else { + if (errest) { +/* Computing MAX */ +/* Computing 2nd power */ + i__3 = *n; +/* Computing 2nd power */ + i__4 = *n; + i__1 = *n + lwqp3, i__2 = *n + lwcon, i__1 = f2cmax(i__1, + i__2), i__2 = (*n << 1) + lwqrf, i__1 = f2cmax(i__1, + i__2), i__2 = (*n << 1) + i__3 * i__3 + lwsvdjv, + i__1 = f2cmax(i__1,i__2), i__2 = (*n << 1) + i__4 * + i__4 + *n + lwunmqr, i__1 = f2cmax(i__1,i__2), i__2 = + *n + lwunmqrm; + minwrk = f2cmax(i__1,i__2); + } else { +/* Computing MAX */ +/* Computing 2nd power */ + i__3 = *n; +/* Computing 2nd power */ + i__4 = *n; + i__1 = *n + lwqp3, i__2 = (*n << 1) + lwqrf, i__1 = f2cmax( + i__1,i__2), i__2 = (*n << 1) + i__3 * i__3 + + lwsvdjv, i__1 = f2cmax(i__1,i__2), i__2 = (*n << 1) + + i__4 * i__4 + *n + lwunmqr, i__1 = f2cmax(i__1, + i__2), i__2 = *n + lwunmqrm; + minwrk = f2cmax(i__1,i__2); + } + if (rowpiv || l2tran) { + miniwrk += *m; + } + } + if (lquery) { + zunmqr_("L", "N", m, n, n, &a[a_offset], lda, cdummy, &u[ + u_offset], ldu, cdummy, &c_n1, &ierr); + lwrk_zunmqrm__ = (integer) cdummy[0].r; + zunmqr_("L", "N", n, n, n, &a[a_offset], lda, cdummy, &u[ + u_offset], ldu, cdummy, &c_n1, &ierr); + lwrk_zunmqr__ = (integer) cdummy[0].r; + if (! jracc) { + zgeqp3_(n, n, &a[a_offset], lda, &iwork[1], cdummy, + cdummy, &c_n1, rdummy, &ierr); + lwrk_zgeqp3n__ = (integer) cdummy[0].r; + zgesvj_("L", "U", "N", n, n, &u[u_offset], ldu, &sva[1], + n, &v[v_offset], ldv, cdummy, &c_n1, rdummy, & + c_n1, &ierr); + lwrk_zgesvj__ = (integer) cdummy[0].r; + zgesvj_("U", "U", "N", n, n, &u[u_offset], ldu, &sva[1], + n, &v[v_offset], ldv, cdummy, &c_n1, rdummy, & + c_n1, &ierr); + lwrk_zgesvju__ = (integer) cdummy[0].r; + zgesvj_("L", "U", "V", n, n, &u[u_offset], ldu, &sva[1], + n, &v[v_offset], ldv, cdummy, &c_n1, rdummy, & + c_n1, &ierr); + lwrk_zgesvjv__ = (integer) cdummy[0].r; + zunmlq_("L", "C", n, n, n, &a[a_offset], lda, cdummy, &v[ + v_offset], ldv, cdummy, &c_n1, &ierr); + lwrk_zunmlq__ = (integer) cdummy[0].r; + if (errest) { +/* Computing MAX */ +/* Computing 2nd power */ + i__3 = *n; +/* Computing 2nd power */ + i__4 = *n; +/* Computing 2nd power */ + i__5 = *n; +/* Computing 2nd power */ + i__6 = *n; +/* Computing 2nd power */ + i__7 = *n; +/* Computing 2nd power */ + i__8 = *n; +/* Computing 2nd power */ + i__9 = *n; +/* Computing 2nd power */ + i__10 = *n; +/* Computing 2nd power */ + i__11 = *n; + i__1 = *n + lwrk_zgeqp3__, i__2 = *n + lwcon, i__1 = + f2cmax(i__1,i__2), i__2 = (*n << 1) + i__3 * + i__3 + lwcon, i__1 = f2cmax(i__1,i__2), i__2 = (* + n << 1) + lwrk_zgeqrf__, i__1 = f2cmax(i__1,i__2) + , i__2 = (*n << 1) + lwrk_zgeqp3n__, i__1 = + f2cmax(i__1,i__2), i__2 = (*n << 1) + i__4 * + i__4 + *n + lwrk_zgelqf__, i__1 = f2cmax(i__1, + i__2), i__2 = (*n << 1) + i__5 * i__5 + *n + + i__6 * i__6 + lwcon, i__1 = f2cmax(i__1,i__2), + i__2 = (*n << 1) + i__7 * i__7 + *n + + lwrk_zgesvj__, i__1 = f2cmax(i__1,i__2), i__2 = ( + *n << 1) + i__8 * i__8 + *n + lwrk_zgesvjv__, + i__1 = f2cmax(i__1,i__2), i__2 = (*n << 1) + + i__9 * i__9 + *n + lwrk_zunmqr__, i__1 = f2cmax( + i__1,i__2), i__2 = (*n << 1) + i__10 * i__10 + + *n + lwrk_zunmlq__, i__1 = f2cmax(i__1,i__2), + i__2 = *n + i__11 * i__11 + lwrk_zgesvju__, + i__1 = f2cmax(i__1,i__2), i__2 = *n + + lwrk_zunmqrm__; + optwrk = f2cmax(i__1,i__2); + } else { +/* Computing MAX */ +/* Computing 2nd power */ + i__3 = *n; +/* Computing 2nd power */ + i__4 = *n; +/* Computing 2nd power */ + i__5 = *n; +/* Computing 2nd power */ + i__6 = *n; +/* Computing 2nd power */ + i__7 = *n; +/* Computing 2nd power */ + i__8 = *n; +/* Computing 2nd power */ + i__9 = *n; +/* Computing 2nd power */ + i__10 = *n; +/* Computing 2nd power */ + i__11 = *n; + i__1 = *n + lwrk_zgeqp3__, i__2 = (*n << 1) + i__3 * + i__3 + lwcon, i__1 = f2cmax(i__1,i__2), i__2 = (* + n << 1) + lwrk_zgeqrf__, i__1 = f2cmax(i__1,i__2) + , i__2 = (*n << 1) + lwrk_zgeqp3n__, i__1 = + f2cmax(i__1,i__2), i__2 = (*n << 1) + i__4 * + i__4 + *n + lwrk_zgelqf__, i__1 = f2cmax(i__1, + i__2), i__2 = (*n << 1) + i__5 * i__5 + *n + + i__6 * i__6 + lwcon, i__1 = f2cmax(i__1,i__2), + i__2 = (*n << 1) + i__7 * i__7 + *n + + lwrk_zgesvj__, i__1 = f2cmax(i__1,i__2), i__2 = ( + *n << 1) + i__8 * i__8 + *n + lwrk_zgesvjv__, + i__1 = f2cmax(i__1,i__2), i__2 = (*n << 1) + + i__9 * i__9 + *n + lwrk_zunmqr__, i__1 = f2cmax( + i__1,i__2), i__2 = (*n << 1) + i__10 * i__10 + + *n + lwrk_zunmlq__, i__1 = f2cmax(i__1,i__2), + i__2 = *n + i__11 * i__11 + lwrk_zgesvju__, + i__1 = f2cmax(i__1,i__2), i__2 = *n + + lwrk_zunmqrm__; + optwrk = f2cmax(i__1,i__2); + } + } else { + zgesvj_("L", "U", "V", n, n, &u[u_offset], ldu, &sva[1], + n, &v[v_offset], ldv, cdummy, &c_n1, rdummy, & + c_n1, &ierr); + lwrk_zgesvjv__ = (integer) cdummy[0].r; + zunmqr_("L", "N", n, n, n, cdummy, n, cdummy, &v[v_offset] + , ldv, cdummy, &c_n1, &ierr) + ; + lwrk_zunmqr__ = (integer) cdummy[0].r; + zunmqr_("L", "N", m, n, n, &a[a_offset], lda, cdummy, &u[ + u_offset], ldu, cdummy, &c_n1, &ierr); + lwrk_zunmqrm__ = (integer) cdummy[0].r; + if (errest) { +/* Computing MAX */ +/* Computing 2nd power */ + i__3 = *n; +/* Computing 2nd power */ + i__4 = *n; +/* Computing 2nd power */ + i__5 = *n; + i__1 = *n + lwrk_zgeqp3__, i__2 = *n + lwcon, i__1 = + f2cmax(i__1,i__2), i__2 = (*n << 1) + + lwrk_zgeqrf__, i__1 = f2cmax(i__1,i__2), i__2 = ( + *n << 1) + i__3 * i__3, i__1 = f2cmax(i__1,i__2), + i__2 = (*n << 1) + i__4 * i__4 + + lwrk_zgesvjv__, i__1 = f2cmax(i__1,i__2), i__2 = + (*n << 1) + i__5 * i__5 + *n + lwrk_zunmqr__, + i__1 = f2cmax(i__1,i__2), i__2 = *n + + lwrk_zunmqrm__; + optwrk = f2cmax(i__1,i__2); + } else { +/* Computing MAX */ +/* Computing 2nd power */ + i__3 = *n; +/* Computing 2nd power */ + i__4 = *n; +/* Computing 2nd power */ + i__5 = *n; + i__1 = *n + lwrk_zgeqp3__, i__2 = (*n << 1) + + lwrk_zgeqrf__, i__1 = f2cmax(i__1,i__2), i__2 = ( + *n << 1) + i__3 * i__3, i__1 = f2cmax(i__1,i__2), + i__2 = (*n << 1) + i__4 * i__4 + + lwrk_zgesvjv__, i__1 = f2cmax(i__1,i__2), i__2 = + (*n << 1) + i__5 * i__5 + *n + lwrk_zunmqr__, + i__1 = f2cmax(i__1,i__2), i__2 = *n + + lwrk_zunmqrm__; + optwrk = f2cmax(i__1,i__2); + } + } + } + if (l2tran || rowpiv) { +/* Computing MAX */ + i__1 = 7, i__2 = *m << 1, i__1 = f2cmax(i__1,i__2), i__1 = f2cmax( + i__1,lrwqp3), i__1 = f2cmax(i__1,lrwsvdj); + minrwrk = f2cmax(i__1,lrwcon); + } else { +/* Computing MAX */ + i__1 = f2cmax(7,lrwqp3), i__1 = f2cmax(i__1,lrwsvdj); + minrwrk = f2cmax(i__1,lrwcon); + } + } + minwrk = f2cmax(2,minwrk); + optwrk = f2cmax(minwrk,optwrk); + if (*lwork < minwrk && ! lquery) { + *info = -17; + } + if (*lrwork < minrwrk && ! lquery) { + *info = -19; + } + } + + if (*info != 0) { +/* #:( */ + i__1 = -(*info); + xerbla_("ZGEJSV", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + cwork[1].r = (doublereal) optwrk, cwork[1].i = 0.; + cwork[2].r = (doublereal) minwrk, cwork[2].i = 0.; + rwork[1] = (doublereal) minrwrk; + iwork[1] = f2cmax(4,miniwrk); + return 0; + } + +/* Quick return for void matrix (Y3K safe) */ +/* #:) */ + if (*m == 0 || *n == 0) { + iwork[1] = 0; + iwork[2] = 0; + iwork[3] = 0; + iwork[4] = 0; + rwork[1] = 0.; + rwork[2] = 0.; + rwork[3] = 0.; + rwork[4] = 0.; + rwork[5] = 0.; + rwork[6] = 0.; + rwork[7] = 0.; + return 0; + } + +/* Determine whether the matrix U should be M x N or M x M */ + + if (lsvec) { + n1 = *n; + if (lsame_(jobu, "F")) { + n1 = *m; + } + } + +/* Set numerical parameters */ + +/* ! NOTE: Make sure DLAMCH() does not fail on the target architecture. */ + + epsln = dlamch_("Epsilon"); + sfmin = dlamch_("SafeMinimum"); + small = sfmin / epsln; + big = dlamch_("O"); +/* BIG = ONE / SFMIN */ + +/* Initialize SVA(1:N) = diag( ||A e_i||_2 )_1^N */ + +/* (!) If necessary, scale SVA() to protect the largest norm from */ +/* overflow. It is possible that this scaling pushes the smallest */ +/* column norm left from the underflow threshold (extreme case). */ + + scalem = 1. / sqrt((doublereal) (*m) * (doublereal) (*n)); + noscal = TRUE_; + goscal = TRUE_; + i__1 = *n; + for (p = 1; p <= i__1; ++p) { + aapp = 0.; + aaqq = 1.; + zlassq_(m, &a[p * a_dim1 + 1], &c__1, &aapp, &aaqq); + if (aapp > big) { + *info = -9; + i__2 = -(*info); + xerbla_("ZGEJSV", &i__2, (ftnlen)6); + return 0; + } + aaqq = sqrt(aaqq); + if (aapp < big / aaqq && noscal) { + sva[p] = aapp * aaqq; + } else { + noscal = FALSE_; + sva[p] = aapp * (aaqq * scalem); + if (goscal) { + goscal = FALSE_; + i__2 = p - 1; + dscal_(&i__2, &scalem, &sva[1], &c__1); + } + } +/* L1874: */ + } + + if (noscal) { + scalem = 1.; + } + + aapp = 0.; + aaqq = big; + i__1 = *n; + for (p = 1; p <= i__1; ++p) { +/* Computing MAX */ + d__1 = aapp, d__2 = sva[p]; + aapp = f2cmax(d__1,d__2); + if (sva[p] != 0.) { +/* Computing MIN */ + d__1 = aaqq, d__2 = sva[p]; + aaqq = f2cmin(d__1,d__2); + } +/* L4781: */ + } + +/* Quick return for zero M x N matrix */ +/* #:) */ + if (aapp == 0.) { + if (lsvec) { + zlaset_("G", m, &n1, &c_b1, &c_b2, &u[u_offset], ldu); + } + if (rsvec) { + zlaset_("G", n, n, &c_b1, &c_b2, &v[v_offset], ldv); + } + rwork[1] = 1.; + rwork[2] = 1.; + if (errest) { + rwork[3] = 1.; + } + if (lsvec && rsvec) { + rwork[4] = 1.; + rwork[5] = 1.; + } + if (l2tran) { + rwork[6] = 0.; + rwork[7] = 0.; + } + iwork[1] = 0; + iwork[2] = 0; + iwork[3] = 0; + iwork[4] = -1; + return 0; + } + +/* Issue warning if denormalized column norms detected. Override the */ +/* high relative accuracy request. Issue licence to kill nonzero columns */ +/* (set them to zero) whose norm is less than sigma_max / BIG (roughly). */ +/* #:( */ + warning = 0; + if (aaqq <= sfmin) { + l2rank = TRUE_; + l2kill = TRUE_; + warning = 1; + } + +/* Quick return for one-column matrix */ +/* #:) */ + if (*n == 1) { + + if (lsvec) { + zlascl_("G", &c__0, &c__0, &sva[1], &scalem, m, &c__1, &a[a_dim1 + + 1], lda, &ierr); + zlacpy_("A", m, &c__1, &a[a_offset], lda, &u[u_offset], ldu); +/* computing all M left singular vectors of the M x 1 matrix */ + if (n1 != *n) { + i__1 = *lwork - *n; + zgeqrf_(m, n, &u[u_offset], ldu, &cwork[1], &cwork[*n + 1], & + i__1, &ierr); + i__1 = *lwork - *n; + zungqr_(m, &n1, &c__1, &u[u_offset], ldu, &cwork[1], &cwork[* + n + 1], &i__1, &ierr); + zcopy_(m, &a[a_dim1 + 1], &c__1, &u[u_dim1 + 1], &c__1); + } + } + if (rsvec) { + i__1 = v_dim1 + 1; + v[i__1].r = 1., v[i__1].i = 0.; + } + if (sva[1] < big * scalem) { + sva[1] /= scalem; + scalem = 1.; + } + rwork[1] = 1. / scalem; + rwork[2] = 1.; + if (sva[1] != 0.) { + iwork[1] = 1; + if (sva[1] / scalem >= sfmin) { + iwork[2] = 1; + } else { + iwork[2] = 0; + } + } else { + iwork[1] = 0; + iwork[2] = 0; + } + iwork[3] = 0; + iwork[4] = -1; + if (errest) { + rwork[3] = 1.; + } + if (lsvec && rsvec) { + rwork[4] = 1.; + rwork[5] = 1.; + } + if (l2tran) { + rwork[6] = 0.; + rwork[7] = 0.; + } + return 0; + + } + + transp = FALSE_; + + aatmax = -1.; + aatmin = big; + if (rowpiv || l2tran) { + +/* Compute the row norms, needed to determine row pivoting sequence */ +/* (in the case of heavily row weighted A, row pivoting is strongly */ +/* advised) and to collect information needed to compare the */ +/* structures of A * A^* and A^* * A (in the case L2TRAN.EQ..TRUE.). */ + + if (l2tran) { + i__1 = *m; + for (p = 1; p <= i__1; ++p) { + xsc = 0.; + temp1 = 1.; + zlassq_(n, &a[p + a_dim1], lda, &xsc, &temp1); +/* ZLASSQ gets both the ell_2 and the ell_infinity norm */ +/* in one pass through the vector */ + rwork[*m + p] = xsc * scalem; + rwork[p] = xsc * (scalem * sqrt(temp1)); +/* Computing MAX */ + d__1 = aatmax, d__2 = rwork[p]; + aatmax = f2cmax(d__1,d__2); + if (rwork[p] != 0.) { +/* Computing MIN */ + d__1 = aatmin, d__2 = rwork[p]; + aatmin = f2cmin(d__1,d__2); + } +/* L1950: */ + } + } else { + i__1 = *m; + for (p = 1; p <= i__1; ++p) { + rwork[*m + p] = scalem * z_abs(&a[p + izamax_(n, &a[p + + a_dim1], lda) * a_dim1]); +/* Computing MAX */ + d__1 = aatmax, d__2 = rwork[*m + p]; + aatmax = f2cmax(d__1,d__2); +/* Computing MIN */ + d__1 = aatmin, d__2 = rwork[*m + p]; + aatmin = f2cmin(d__1,d__2); +/* L1904: */ + } + } + + } + +/* For square matrix A try to determine whether A^* would be better */ +/* input for the preconditioned Jacobi SVD, with faster convergence. */ +/* The decision is based on an O(N) function of the vector of column */ +/* and row norms of A, based on the Shannon entropy. This should give */ +/* the right choice in most cases when the difference actually matters. */ +/* It may fail and pick the slower converging side. */ + + entra = 0.; + entrat = 0.; + if (l2tran) { + + xsc = 0.; + temp1 = 1.; + dlassq_(n, &sva[1], &c__1, &xsc, &temp1); + temp1 = 1. / temp1; + + entra = 0.; + i__1 = *n; + for (p = 1; p <= i__1; ++p) { +/* Computing 2nd power */ + d__1 = sva[p] / xsc; + big1 = d__1 * d__1 * temp1; + if (big1 != 0.) { + entra += big1 * log(big1); + } +/* L1113: */ + } + entra = -entra / log((doublereal) (*n)); + +/* Now, SVA().^2/Trace(A^* * A) is a point in the probability simplex. */ +/* It is derived from the diagonal of A^* * A. Do the same with the */ +/* diagonal of A * A^*, compute the entropy of the corresponding */ +/* probability distribution. Note that A * A^* and A^* * A have the */ +/* same trace. */ + + entrat = 0.; + i__1 = *m; + for (p = 1; p <= i__1; ++p) { +/* Computing 2nd power */ + d__1 = rwork[p] / xsc; + big1 = d__1 * d__1 * temp1; + if (big1 != 0.) { + entrat += big1 * log(big1); + } +/* L1114: */ + } + entrat = -entrat / log((doublereal) (*m)); + +/* Analyze the entropies and decide A or A^*. Smaller entropy */ +/* usually means better input for the algorithm. */ + + transp = entrat < entra; + +/* If A^* is better than A, take the adjoint of A. This is allowed */ +/* only for square matrices, M=N. */ + if (transp) { +/* In an optimal implementation, this trivial transpose */ +/* should be replaced with faster transpose. */ + i__1 = *n - 1; + for (p = 1; p <= i__1; ++p) { + i__2 = p + p * a_dim1; + d_cnjg(&z__1, &a[p + p * a_dim1]); + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = *n; + for (q = p + 1; q <= i__2; ++q) { + d_cnjg(&z__1, &a[q + p * a_dim1]); + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__3 = q + p * a_dim1; + d_cnjg(&z__1, &a[p + q * a_dim1]); + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = p + q * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; +/* L1116: */ + } +/* L1115: */ + } + i__1 = *n + *n * a_dim1; + d_cnjg(&z__1, &a[*n + *n * a_dim1]); + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + i__1 = *n; + for (p = 1; p <= i__1; ++p) { + rwork[*m + p] = sva[p]; + sva[p] = rwork[p]; +/* previously computed row 2-norms are now column 2-norms */ +/* of the transposed matrix */ +/* L1117: */ + } + temp1 = aapp; + aapp = aatmax; + aatmax = temp1; + temp1 = aaqq; + aaqq = aatmin; + aatmin = temp1; + kill = lsvec; + lsvec = rsvec; + rsvec = kill; + if (lsvec) { + n1 = *n; + } + + rowpiv = TRUE_; + } + + } +/* END IF L2TRAN */ + +/* Scale the matrix so that its maximal singular value remains less */ +/* than SQRT(BIG) -- the matrix is scaled so that its maximal column */ +/* has Euclidean norm equal to SQRT(BIG/N). The only reason to keep */ +/* SQRT(BIG) instead of BIG is the fact that ZGEJSV uses LAPACK and */ +/* BLAS routines that, in some implementations, are not capable of */ +/* working in the full interval [SFMIN,BIG] and that they may provoke */ +/* overflows in the intermediate results. If the singular values spread */ +/* from SFMIN to BIG, then ZGESVJ will compute them. So, in that case, */ +/* one should use ZGESVJ instead of ZGEJSV. */ +/* >> change in the April 2016 update: allow bigger range, i.e. the */ +/* largest column is allowed up to BIG/N and ZGESVJ will do the rest. */ + big1 = sqrt(big); + temp1 = sqrt(big / (doublereal) (*n)); +/* TEMP1 = BIG/DBLE(N) */ + + dlascl_("G", &c__0, &c__0, &aapp, &temp1, n, &c__1, &sva[1], n, &ierr); + if (aaqq > aapp * sfmin) { + aaqq = aaqq / aapp * temp1; + } else { + aaqq = aaqq * temp1 / aapp; + } + temp1 *= scalem; + zlascl_("G", &c__0, &c__0, &aapp, &temp1, m, n, &a[a_offset], lda, &ierr); + +/* To undo scaling at the end of this procedure, multiply the */ +/* computed singular values with USCAL2 / USCAL1. */ + + uscal1 = temp1; + uscal2 = aapp; + + if (l2kill) { +/* L2KILL enforces computation of nonzero singular values in */ +/* the restricted range of condition number of the initial A, */ +/* sigma_max(A) / sigma_min(A) approx. SQRT(BIG)/SQRT(SFMIN). */ + xsc = sqrt(sfmin); + } else { + xsc = small; + +/* Now, if the condition number of A is too big, */ +/* sigma_max(A) / sigma_min(A) .GT. SQRT(BIG/N) * EPSLN / SFMIN, */ +/* as a precaution measure, the full SVD is computed using ZGESVJ */ +/* with accumulated Jacobi rotations. This provides numerically */ +/* more robust computation, at the cost of slightly increased run */ +/* time. Depending on the concrete implementation of BLAS and LAPACK */ +/* (i.e. how they behave in presence of extreme ill-conditioning) the */ +/* implementor may decide to remove this switch. */ + if (aaqq < sqrt(sfmin) && lsvec && rsvec) { + jracc = TRUE_; + } + + } + if (aaqq < xsc) { + i__1 = *n; + for (p = 1; p <= i__1; ++p) { + if (sva[p] < xsc) { + zlaset_("A", m, &c__1, &c_b1, &c_b1, &a[p * a_dim1 + 1], lda); + sva[p] = 0.; + } +/* L700: */ + } + } + +/* Preconditioning using QR factorization with pivoting */ + + if (rowpiv) { +/* Optional row permutation (Bjoerck row pivoting): */ +/* A result by Cox and Higham shows that the Bjoerck's */ +/* row pivoting combined with standard column pivoting */ +/* has similar effect as Powell-Reid complete pivoting. */ +/* The ell-infinity norms of A are made nonincreasing. */ + if (lsvec && rsvec && ! jracc) { + iwoff = *n << 1; + } else { + iwoff = *n; + } + i__1 = *m - 1; + for (p = 1; p <= i__1; ++p) { + i__2 = *m - p + 1; + q = idamax_(&i__2, &rwork[*m + p], &c__1) + p - 1; + iwork[iwoff + p] = q; + if (p != q) { + temp1 = rwork[*m + p]; + rwork[*m + p] = rwork[*m + q]; + rwork[*m + q] = temp1; + } +/* L1952: */ + } + i__1 = *m - 1; + zlaswp_(n, &a[a_offset], lda, &c__1, &i__1, &iwork[iwoff + 1], &c__1); + } + +/* End of the preparation phase (scaling, optional sorting and */ +/* transposing, optional flushing of small columns). */ + +/* Preconditioning */ + +/* If the full SVD is needed, the right singular vectors are computed */ +/* from a matrix equation, and for that we need theoretical analysis */ +/* of the Businger-Golub pivoting. So we use ZGEQP3 as the first RR QRF. */ +/* In all other cases the first RR QRF can be chosen by other criteria */ +/* (eg speed by replacing global with restricted window pivoting, such */ +/* as in xGEQPX from TOMS # 782). Good results will be obtained using */ +/* xGEQPX with properly (!) chosen numerical parameters. */ +/* Any improvement of ZGEQP3 improves overal performance of ZGEJSV. */ + +/* A * P1 = Q1 * [ R1^* 0]^*: */ + i__1 = *n; + for (p = 1; p <= i__1; ++p) { + iwork[p] = 0; +/* L1963: */ + } + i__1 = *lwork - *n; + zgeqp3_(m, n, &a[a_offset], lda, &iwork[1], &cwork[1], &cwork[*n + 1], & + i__1, &rwork[1], &ierr); + +/* The upper triangular matrix R1 from the first QRF is inspected for */ +/* rank deficiency and possibilities for deflation, or possible */ +/* ill-conditioning. Depending on the user specified flag L2RANK, */ +/* the procedure explores possibilities to reduce the numerical */ +/* rank by inspecting the computed upper triangular factor. If */ +/* L2RANK or L2ABER are up, then ZGEJSV will compute the SVD of */ +/* A + dA, where ||dA|| <= f(M,N)*EPSLN. */ + + nr = 1; + if (l2aber) { +/* Standard absolute error bound suffices. All sigma_i with */ +/* sigma_i < N*EPSLN*||A|| are flushed to zero. This is an */ +/* aggressive enforcement of lower numerical rank by introducing a */ +/* backward error of the order of N*EPSLN*||A||. */ + temp1 = sqrt((doublereal) (*n)) * epsln; + i__1 = *n; + for (p = 2; p <= i__1; ++p) { + if (z_abs(&a[p + p * a_dim1]) >= temp1 * z_abs(&a[a_dim1 + 1])) { + ++nr; + } else { + goto L3002; + } +/* L3001: */ + } +L3002: + ; + } else if (l2rank) { +/* Sudden drop on the diagonal of R1 is used as the criterion for */ +/* close-to-rank-deficient. */ + temp1 = sqrt(sfmin); + i__1 = *n; + for (p = 2; p <= i__1; ++p) { + if (z_abs(&a[p + p * a_dim1]) < epsln * z_abs(&a[p - 1 + (p - 1) * + a_dim1]) || z_abs(&a[p + p * a_dim1]) < small || l2kill + && z_abs(&a[p + p * a_dim1]) < temp1) { + goto L3402; + } + ++nr; +/* L3401: */ + } +L3402: + + ; + } else { +/* The goal is high relative accuracy. However, if the matrix */ +/* has high scaled condition number the relative accuracy is in */ +/* general not feasible. Later on, a condition number estimator */ +/* will be deployed to estimate the scaled condition number. */ +/* Here we just remove the underflowed part of the triangular */ +/* factor. This prevents the situation in which the code is */ +/* working hard to get the accuracy not warranted by the data. */ + temp1 = sqrt(sfmin); + i__1 = *n; + for (p = 2; p <= i__1; ++p) { + if (z_abs(&a[p + p * a_dim1]) < small || l2kill && z_abs(&a[p + p + * a_dim1]) < temp1) { + goto L3302; + } + ++nr; +/* L3301: */ + } +L3302: + + ; + } + + almort = FALSE_; + if (nr == *n) { + maxprj = 1.; + i__1 = *n; + for (p = 2; p <= i__1; ++p) { + temp1 = z_abs(&a[p + p * a_dim1]) / sva[iwork[p]]; + maxprj = f2cmin(maxprj,temp1); +/* L3051: */ + } +/* Computing 2nd power */ + d__1 = maxprj; + if (d__1 * d__1 >= 1. - (doublereal) (*n) * epsln) { + almort = TRUE_; + } + } + + + sconda = -1.; + condr1 = -1.; + condr2 = -1.; + + if (errest) { + if (*n == nr) { + if (rsvec) { + zlacpy_("U", n, n, &a[a_offset], lda, &v[v_offset], ldv); + i__1 = *n; + for (p = 1; p <= i__1; ++p) { + temp1 = sva[iwork[p]]; + d__1 = 1. / temp1; + zdscal_(&p, &d__1, &v[p * v_dim1 + 1], &c__1); +/* L3053: */ + } + if (lsvec) { + zpocon_("U", n, &v[v_offset], ldv, &c_b141, &temp1, & + cwork[*n + 1], &rwork[1], &ierr); + } else { + zpocon_("U", n, &v[v_offset], ldv, &c_b141, &temp1, & + cwork[1], &rwork[1], &ierr); + } + + } else if (lsvec) { + zlacpy_("U", n, n, &a[a_offset], lda, &u[u_offset], ldu); + i__1 = *n; + for (p = 1; p <= i__1; ++p) { + temp1 = sva[iwork[p]]; + d__1 = 1. / temp1; + zdscal_(&p, &d__1, &u[p * u_dim1 + 1], &c__1); +/* L3054: */ + } + zpocon_("U", n, &u[u_offset], ldu, &c_b141, &temp1, &cwork[*n + + 1], &rwork[1], &ierr); + } else { + zlacpy_("U", n, n, &a[a_offset], lda, &cwork[1], n) + ; +/* [] CALL ZLACPY( 'U', N, N, A, LDA, CWORK(N+1), N ) */ +/* Change: here index shifted by N to the left, CWORK(1:N) */ +/* not needed for SIGMA only computation */ + i__1 = *n; + for (p = 1; p <= i__1; ++p) { + temp1 = sva[iwork[p]]; +/* [] CALL ZDSCAL( p, ONE/TEMP1, CWORK(N+(p-1)*N+1), 1 ) */ + d__1 = 1. / temp1; + zdscal_(&p, &d__1, &cwork[(p - 1) * *n + 1], &c__1); +/* L3052: */ + } +/* [] CALL ZPOCON( 'U', N, CWORK(N+1), N, ONE, TEMP1, */ +/* [] $ CWORK(N+N*N+1), RWORK, IERR ) */ + zpocon_("U", n, &cwork[1], n, &c_b141, &temp1, &cwork[*n * *n + + 1], &rwork[1], &ierr); + + } + if (temp1 != 0.) { + sconda = 1. / sqrt(temp1); + } else { + sconda = -1.; + } +/* SCONDA is an estimate of SQRT(||(R^* * R)^(-1)||_1). */ +/* N^(-1/4) * SCONDA <= ||R^(-1)||_2 <= N^(1/4) * SCONDA */ + } else { + sconda = -1.; + } + } + + z_div(&z__1, &a[a_dim1 + 1], &a[nr + nr * a_dim1]); + l2pert = l2pert && z_abs(&z__1) > sqrt(big1); +/* If there is no violent scaling, artificial perturbation is not needed. */ + +/* Phase 3: */ + + if (! (rsvec || lsvec)) { + +/* Singular Values only */ + +/* Computing MIN */ + i__2 = *n - 1; + i__1 = f2cmin(i__2,nr); + for (p = 1; p <= i__1; ++p) { + i__2 = *n - p; + zcopy_(&i__2, &a[p + (p + 1) * a_dim1], lda, &a[p + 1 + p * + a_dim1], &c__1); + i__2 = *n - p + 1; + zlacgv_(&i__2, &a[p + p * a_dim1], &c__1); +/* L1946: */ + } + if (nr == *n) { + i__1 = *n + *n * a_dim1; + d_cnjg(&z__1, &a[*n + *n * a_dim1]); + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + } + +/* The following two DO-loops introduce small relative perturbation */ +/* into the strict upper triangle of the lower triangular matrix. */ +/* Small entries below the main diagonal are also changed. */ +/* This modification is useful if the computing environment does not */ +/* provide/allow FLUSH TO ZERO underflow, for it prevents many */ +/* annoying denormalized numbers in case of strongly scaled matrices. */ +/* The perturbation is structured so that it does not introduce any */ +/* new perturbation of the singular values, and it does not destroy */ +/* the job done by the preconditioner. */ +/* The licence for this perturbation is in the variable L2PERT, which */ +/* should be .FALSE. if FLUSH TO ZERO underflow is active. */ + + if (! almort) { + + if (l2pert) { +/* XSC = SQRT(SMALL) */ + xsc = epsln / (doublereal) (*n); + i__1 = nr; + for (q = 1; q <= i__1; ++q) { + d__1 = xsc * z_abs(&a[q + q * a_dim1]); + z__1.r = d__1, z__1.i = 0.; + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__2 = *n; + for (p = 1; p <= i__2; ++p) { + if (p > q && z_abs(&a[p + q * a_dim1]) <= temp1 || p < + q) { + i__3 = p + q * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; + } +/* $ A(p,q) = TEMP1 * ( A(p,q) / ABS(A(p,q)) ) */ +/* L4949: */ + } +/* L4947: */ + } + } else { + i__1 = nr - 1; + i__2 = nr - 1; + zlaset_("U", &i__1, &i__2, &c_b1, &c_b1, &a[(a_dim1 << 1) + 1] + , lda); + } + + + i__1 = *lwork - *n; + zgeqrf_(n, &nr, &a[a_offset], lda, &cwork[1], &cwork[*n + 1], & + i__1, &ierr); + + i__1 = nr - 1; + for (p = 1; p <= i__1; ++p) { + i__2 = nr - p; + zcopy_(&i__2, &a[p + (p + 1) * a_dim1], lda, &a[p + 1 + p * + a_dim1], &c__1); + i__2 = nr - p + 1; + zlacgv_(&i__2, &a[p + p * a_dim1], &c__1); +/* L1948: */ + } + + } + +/* Row-cyclic Jacobi SVD algorithm with column pivoting */ + +/* to drown denormals */ + if (l2pert) { +/* XSC = SQRT(SMALL) */ + xsc = epsln / (doublereal) (*n); + i__1 = nr; + for (q = 1; q <= i__1; ++q) { + d__1 = xsc * z_abs(&a[q + q * a_dim1]); + z__1.r = d__1, z__1.i = 0.; + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__2 = nr; + for (p = 1; p <= i__2; ++p) { + if (p > q && z_abs(&a[p + q * a_dim1]) <= temp1 || p < q) + { + i__3 = p + q * a_dim1; + a[i__3].r = ctemp.r, a[i__3].i = ctemp.i; + } +/* $ A(p,q) = TEMP1 * ( A(p,q) / ABS(A(p,q)) ) */ +/* L1949: */ + } +/* L1947: */ + } + } else { + i__1 = nr - 1; + i__2 = nr - 1; + zlaset_("U", &i__1, &i__2, &c_b1, &c_b1, &a[(a_dim1 << 1) + 1], + lda); + } + +/* triangular matrix (plus perturbation which is ignored in */ +/* the part which destroys triangular form (confusing?!)) */ + + zgesvj_("L", "N", "N", &nr, &nr, &a[a_offset], lda, &sva[1], n, &v[ + v_offset], ldv, &cwork[1], lwork, &rwork[1], lrwork, info); + + scalem = rwork[1]; + numrank = i_dnnt(&rwork[2]); + + + } else if (rsvec && ! lsvec && ! jracc || jracc && ! lsvec && nr != *n) { + +/* -> Singular Values and Right Singular Vectors <- */ + + if (almort) { + + i__1 = nr; + for (p = 1; p <= i__1; ++p) { + i__2 = *n - p + 1; + zcopy_(&i__2, &a[p + p * a_dim1], lda, &v[p + p * v_dim1], & + c__1); + i__2 = *n - p + 1; + zlacgv_(&i__2, &v[p + p * v_dim1], &c__1); +/* L1998: */ + } + i__1 = nr - 1; + i__2 = nr - 1; + zlaset_("U", &i__1, &i__2, &c_b1, &c_b1, &v[(v_dim1 << 1) + 1], + ldv); + + zgesvj_("L", "U", "N", n, &nr, &v[v_offset], ldv, &sva[1], &nr, & + a[a_offset], lda, &cwork[1], lwork, &rwork[1], lrwork, + info); + scalem = rwork[1]; + numrank = i_dnnt(&rwork[2]); + } else { + +/* accumulated product of Jacobi rotations, three are perfect ) */ + + i__1 = nr - 1; + i__2 = nr - 1; + zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &a[a_dim1 + 2], lda); + i__1 = *lwork - *n; + zgelqf_(&nr, n, &a[a_offset], lda, &cwork[1], &cwork[*n + 1], & + i__1, &ierr); + zlacpy_("L", &nr, &nr, &a[a_offset], lda, &v[v_offset], ldv); + i__1 = nr - 1; + i__2 = nr - 1; + zlaset_("U", &i__1, &i__2, &c_b1, &c_b1, &v[(v_dim1 << 1) + 1], + ldv); + i__1 = *lwork - (*n << 1); + zgeqrf_(&nr, &nr, &v[v_offset], ldv, &cwork[*n + 1], &cwork[(*n << + 1) + 1], &i__1, &ierr); + i__1 = nr; + for (p = 1; p <= i__1; ++p) { + i__2 = nr - p + 1; + zcopy_(&i__2, &v[p + p * v_dim1], ldv, &v[p + p * v_dim1], & + c__1); + i__2 = nr - p + 1; + zlacgv_(&i__2, &v[p + p * v_dim1], &c__1); +/* L8998: */ + } + i__1 = nr - 1; + i__2 = nr - 1; + zlaset_("U", &i__1, &i__2, &c_b1, &c_b1, &v[(v_dim1 << 1) + 1], + ldv); + + i__1 = *lwork - *n; + zgesvj_("L", "U", "N", &nr, &nr, &v[v_offset], ldv, &sva[1], &nr, + &u[u_offset], ldu, &cwork[*n + 1], &i__1, &rwork[1], + lrwork, info); + scalem = rwork[1]; + numrank = i_dnnt(&rwork[2]); + if (nr < *n) { + i__1 = *n - nr; + zlaset_("A", &i__1, &nr, &c_b1, &c_b1, &v[nr + 1 + v_dim1], + ldv); + i__1 = *n - nr; + zlaset_("A", &nr, &i__1, &c_b1, &c_b1, &v[(nr + 1) * v_dim1 + + 1], ldv); + i__1 = *n - nr; + i__2 = *n - nr; + zlaset_("A", &i__1, &i__2, &c_b1, &c_b2, &v[nr + 1 + (nr + 1) + * v_dim1], ldv); + } + + i__1 = *lwork - *n; + zunmlq_("L", "C", n, n, &nr, &a[a_offset], lda, &cwork[1], &v[ + v_offset], ldv, &cwork[*n + 1], &i__1, &ierr); + + } +/* DO 8991 p = 1, N */ +/* CALL ZCOPY( N, V(p,1), LDV, A(IWORK(p),1), LDA ) */ +/* 8991 CONTINUE */ +/* CALL ZLACPY( 'All', N, N, A, LDA, V, LDV ) */ + zlapmr_(&c_false, n, n, &v[v_offset], ldv, &iwork[1]); + + if (transp) { + zlacpy_("A", n, n, &v[v_offset], ldv, &u[u_offset], ldu); + } + + } else if (jracc && ! lsvec && nr == *n) { + + i__1 = *n - 1; + i__2 = *n - 1; + zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &a[a_dim1 + 2], lda); + + zgesvj_("U", "N", "V", n, n, &a[a_offset], lda, &sva[1], n, &v[ + v_offset], ldv, &cwork[1], lwork, &rwork[1], lrwork, info); + scalem = rwork[1]; + numrank = i_dnnt(&rwork[2]); + zlapmr_(&c_false, n, n, &v[v_offset], ldv, &iwork[1]); + + } else if (lsvec && ! rsvec) { + + +/* Jacobi rotations in the Jacobi iterations. */ + i__1 = nr; + for (p = 1; p <= i__1; ++p) { + i__2 = *n - p + 1; + zcopy_(&i__2, &a[p + p * a_dim1], lda, &u[p + p * u_dim1], &c__1); + i__2 = *n - p + 1; + zlacgv_(&i__2, &u[p + p * u_dim1], &c__1); +/* L1965: */ + } + i__1 = nr - 1; + i__2 = nr - 1; + zlaset_("U", &i__1, &i__2, &c_b1, &c_b1, &u[(u_dim1 << 1) + 1], ldu); + + i__1 = *lwork - (*n << 1); + zgeqrf_(n, &nr, &u[u_offset], ldu, &cwork[*n + 1], &cwork[(*n << 1) + + 1], &i__1, &ierr); + + i__1 = nr - 1; + for (p = 1; p <= i__1; ++p) { + i__2 = nr - p; + zcopy_(&i__2, &u[p + (p + 1) * u_dim1], ldu, &u[p + 1 + p * + u_dim1], &c__1); + i__2 = *n - p + 1; + zlacgv_(&i__2, &u[p + p * u_dim1], &c__1); +/* L1967: */ + } + i__1 = nr - 1; + i__2 = nr - 1; + zlaset_("U", &i__1, &i__2, &c_b1, &c_b1, &u[(u_dim1 << 1) + 1], ldu); + + i__1 = *lwork - *n; + zgesvj_("L", "U", "N", &nr, &nr, &u[u_offset], ldu, &sva[1], &nr, &a[ + a_offset], lda, &cwork[*n + 1], &i__1, &rwork[1], lrwork, + info); + scalem = rwork[1]; + numrank = i_dnnt(&rwork[2]); + + if (nr < *m) { + i__1 = *m - nr; + zlaset_("A", &i__1, &nr, &c_b1, &c_b1, &u[nr + 1 + u_dim1], ldu); + if (nr < n1) { + i__1 = n1 - nr; + zlaset_("A", &nr, &i__1, &c_b1, &c_b1, &u[(nr + 1) * u_dim1 + + 1], ldu); + i__1 = *m - nr; + i__2 = n1 - nr; + zlaset_("A", &i__1, &i__2, &c_b1, &c_b2, &u[nr + 1 + (nr + 1) + * u_dim1], ldu); + } + } + + i__1 = *lwork - *n; + zunmqr_("L", "N", m, &n1, n, &a[a_offset], lda, &cwork[1], &u[ + u_offset], ldu, &cwork[*n + 1], &i__1, &ierr); + + if (rowpiv) { + i__1 = *m - 1; + zlaswp_(&n1, &u[u_offset], ldu, &c__1, &i__1, &iwork[iwoff + 1], & + c_n1); + } + + i__1 = n1; + for (p = 1; p <= i__1; ++p) { + xsc = 1. / dznrm2_(m, &u[p * u_dim1 + 1], &c__1); + zdscal_(m, &xsc, &u[p * u_dim1 + 1], &c__1); +/* L1974: */ + } + + if (transp) { + zlacpy_("A", n, n, &u[u_offset], ldu, &v[v_offset], ldv); + } + + } else { + + + if (! jracc) { + + if (! almort) { + +/* Second Preconditioning Step (QRF [with pivoting]) */ +/* Note that the composition of TRANSPOSE, QRF and TRANSPOSE is */ +/* equivalent to an LQF CALL. Since in many libraries the QRF */ +/* seems to be better optimized than the LQF, we do explicit */ +/* transpose and use the QRF. This is subject to changes in an */ +/* optimized implementation of ZGEJSV. */ + + i__1 = nr; + for (p = 1; p <= i__1; ++p) { + i__2 = *n - p + 1; + zcopy_(&i__2, &a[p + p * a_dim1], lda, &v[p + p * v_dim1], + &c__1); + i__2 = *n - p + 1; + zlacgv_(&i__2, &v[p + p * v_dim1], &c__1); +/* L1968: */ + } + +/* denormals in the second QR factorization, where they are */ +/* as good as zeros. This is done to avoid painfully slow */ +/* computation with denormals. The relative size of the perturbation */ +/* is a parameter that can be changed by the implementer. */ +/* This perturbation device will be obsolete on machines with */ +/* properly implemented arithmetic. */ +/* To switch it off, set L2PERT=.FALSE. To remove it from the */ +/* code, remove the action under L2PERT=.TRUE., leave the ELSE part. */ +/* The following two loops should be blocked and fused with the */ +/* transposed copy above. */ + + if (l2pert) { + xsc = sqrt(small); + i__1 = nr; + for (q = 1; q <= i__1; ++q) { + d__1 = xsc * z_abs(&v[q + q * v_dim1]); + z__1.r = d__1, z__1.i = 0.; + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__2 = *n; + for (p = 1; p <= i__2; ++p) { + if (p > q && z_abs(&v[p + q * v_dim1]) <= temp1 || + p < q) { + i__3 = p + q * v_dim1; + v[i__3].r = ctemp.r, v[i__3].i = ctemp.i; + } +/* $ V(p,q) = TEMP1 * ( V(p,q) / ABS(V(p,q)) ) */ + if (p < q) { + i__3 = p + q * v_dim1; + i__4 = p + q * v_dim1; + z__1.r = -v[i__4].r, z__1.i = -v[i__4].i; + v[i__3].r = z__1.r, v[i__3].i = z__1.i; + } +/* L2968: */ + } +/* L2969: */ + } + } else { + i__1 = nr - 1; + i__2 = nr - 1; + zlaset_("U", &i__1, &i__2, &c_b1, &c_b1, &v[(v_dim1 << 1) + + 1], ldv); + } + +/* Estimate the row scaled condition number of R1 */ +/* (If R1 is rectangular, N > NR, then the condition number */ +/* of the leading NR x NR submatrix is estimated.) */ + + zlacpy_("L", &nr, &nr, &v[v_offset], ldv, &cwork[(*n << 1) + + 1], &nr); + i__1 = nr; + for (p = 1; p <= i__1; ++p) { + i__2 = nr - p + 1; + temp1 = dznrm2_(&i__2, &cwork[(*n << 1) + (p - 1) * nr + + p], &c__1); + i__2 = nr - p + 1; + d__1 = 1. / temp1; + zdscal_(&i__2, &d__1, &cwork[(*n << 1) + (p - 1) * nr + p] + , &c__1); +/* L3950: */ + } + zpocon_("L", &nr, &cwork[(*n << 1) + 1], &nr, &c_b141, &temp1, + &cwork[(*n << 1) + nr * nr + 1], &rwork[1], &ierr); + condr1 = 1. / sqrt(temp1); +/* R1 is OK for inverse <=> CONDR1 .LT. DBLE(N) */ +/* more conservative <=> CONDR1 .LT. SQRT(DBLE(N)) */ + + cond_ok__ = sqrt(sqrt((doublereal) nr)); +/* [TP] COND_OK is a tuning parameter. */ + + if (condr1 < cond_ok__) { +/* implementation, this QRF should be implemented as the QRF */ +/* of a lower triangular matrix. */ +/* R1^* = Q2 * R2 */ + i__1 = *lwork - (*n << 1); + zgeqrf_(n, &nr, &v[v_offset], ldv, &cwork[*n + 1], &cwork[ + (*n << 1) + 1], &i__1, &ierr); + + if (l2pert) { + xsc = sqrt(small) / epsln; + i__1 = nr; + for (p = 2; p <= i__1; ++p) { + i__2 = p - 1; + for (q = 1; q <= i__2; ++q) { +/* Computing MIN */ + d__2 = z_abs(&v[p + p * v_dim1]), d__3 = + z_abs(&v[q + q * v_dim1]); + d__1 = xsc * f2cmin(d__2,d__3); + z__1.r = d__1, z__1.i = 0.; + ctemp.r = z__1.r, ctemp.i = z__1.i; + if (z_abs(&v[q + p * v_dim1]) <= temp1) { + i__3 = q + p * v_dim1; + v[i__3].r = ctemp.r, v[i__3].i = ctemp.i; + } +/* $ V(q,p) = TEMP1 * ( V(q,p) / ABS(V(q,p)) ) */ +/* L3958: */ + } +/* L3959: */ + } + } + + if (nr != *n) { + zlacpy_("A", n, &nr, &v[v_offset], ldv, &cwork[(*n << + 1) + 1], n); + } + + i__1 = nr - 1; + for (p = 1; p <= i__1; ++p) { + i__2 = nr - p; + zcopy_(&i__2, &v[p + (p + 1) * v_dim1], ldv, &v[p + 1 + + p * v_dim1], &c__1); + i__2 = nr - p + 1; + zlacgv_(&i__2, &v[p + p * v_dim1], &c__1); +/* L1969: */ + } + i__1 = nr + nr * v_dim1; + d_cnjg(&z__1, &v[nr + nr * v_dim1]); + v[i__1].r = z__1.r, v[i__1].i = z__1.i; + + condr2 = condr1; + + } else { + +/* Note that windowed pivoting would be equally good */ +/* numerically, and more run-time efficient. So, in */ +/* an optimal implementation, the next call to ZGEQP3 */ +/* should be replaced with eg. CALL ZGEQPX (ACM TOMS #782) */ +/* with properly (carefully) chosen parameters. */ + +/* R1^* * P2 = Q2 * R2 */ + i__1 = nr; + for (p = 1; p <= i__1; ++p) { + iwork[*n + p] = 0; +/* L3003: */ + } + i__1 = *lwork - (*n << 1); + zgeqp3_(n, &nr, &v[v_offset], ldv, &iwork[*n + 1], &cwork[ + *n + 1], &cwork[(*n << 1) + 1], &i__1, &rwork[1], + &ierr); +/* * CALL ZGEQRF( N, NR, V, LDV, CWORK(N+1), CWORK(2*N+1), */ +/* * $ LWORK-2*N, IERR ) */ + if (l2pert) { + xsc = sqrt(small); + i__1 = nr; + for (p = 2; p <= i__1; ++p) { + i__2 = p - 1; + for (q = 1; q <= i__2; ++q) { +/* Computing MIN */ + d__2 = z_abs(&v[p + p * v_dim1]), d__3 = + z_abs(&v[q + q * v_dim1]); + d__1 = xsc * f2cmin(d__2,d__3); + z__1.r = d__1, z__1.i = 0.; + ctemp.r = z__1.r, ctemp.i = z__1.i; + if (z_abs(&v[q + p * v_dim1]) <= temp1) { + i__3 = q + p * v_dim1; + v[i__3].r = ctemp.r, v[i__3].i = ctemp.i; + } +/* $ V(q,p) = TEMP1 * ( V(q,p) / ABS(V(q,p)) ) */ +/* L3968: */ + } +/* L3969: */ + } + } + + zlacpy_("A", n, &nr, &v[v_offset], ldv, &cwork[(*n << 1) + + 1], n); + + if (l2pert) { + xsc = sqrt(small); + i__1 = nr; + for (p = 2; p <= i__1; ++p) { + i__2 = p - 1; + for (q = 1; q <= i__2; ++q) { +/* Computing MIN */ + d__2 = z_abs(&v[p + p * v_dim1]), d__3 = + z_abs(&v[q + q * v_dim1]); + d__1 = xsc * f2cmin(d__2,d__3); + z__1.r = d__1, z__1.i = 0.; + ctemp.r = z__1.r, ctemp.i = z__1.i; +/* V(p,q) = - TEMP1*( V(q,p) / ABS(V(q,p)) ) */ + i__3 = p + q * v_dim1; + z__1.r = -ctemp.r, z__1.i = -ctemp.i; + v[i__3].r = z__1.r, v[i__3].i = z__1.i; +/* L8971: */ + } +/* L8970: */ + } + } else { + i__1 = nr - 1; + i__2 = nr - 1; + zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &v[v_dim1 + + 2], ldv); + } +/* Now, compute R2 = L3 * Q3, the LQ factorization. */ + i__1 = *lwork - (*n << 1) - *n * nr - nr; + zgelqf_(&nr, &nr, &v[v_offset], ldv, &cwork[(*n << 1) + * + n * nr + 1], &cwork[(*n << 1) + *n * nr + nr + 1], + &i__1, &ierr); + zlacpy_("L", &nr, &nr, &v[v_offset], ldv, &cwork[(*n << 1) + + *n * nr + nr + 1], &nr); + i__1 = nr; + for (p = 1; p <= i__1; ++p) { + temp1 = dznrm2_(&p, &cwork[(*n << 1) + *n * nr + nr + + p], &nr); + d__1 = 1. / temp1; + zdscal_(&p, &d__1, &cwork[(*n << 1) + *n * nr + nr + + p], &nr); +/* L4950: */ + } + zpocon_("L", &nr, &cwork[(*n << 1) + *n * nr + nr + 1], & + nr, &c_b141, &temp1, &cwork[(*n << 1) + *n * nr + + nr + nr * nr + 1], &rwork[1], &ierr); + condr2 = 1. / sqrt(temp1); + + + if (condr2 >= cond_ok__) { +/* (this overwrites the copy of R2, as it will not be */ +/* needed in this branch, but it does not overwritte the */ +/* Huseholder vectors of Q2.). */ + zlacpy_("U", &nr, &nr, &v[v_offset], ldv, &cwork[(*n + << 1) + 1], n); +/* WORK(2*N+N*NR+1:2*N+N*NR+N) */ + } + + } + + if (l2pert) { + xsc = sqrt(small); + i__1 = nr; + for (q = 2; q <= i__1; ++q) { + i__2 = q + q * v_dim1; + z__1.r = xsc * v[i__2].r, z__1.i = xsc * v[i__2].i; + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__2 = q - 1; + for (p = 1; p <= i__2; ++p) { +/* V(p,q) = - TEMP1*( V(p,q) / ABS(V(p,q)) ) */ + i__3 = p + q * v_dim1; + z__1.r = -ctemp.r, z__1.i = -ctemp.i; + v[i__3].r = z__1.r, v[i__3].i = z__1.i; +/* L4969: */ + } +/* L4968: */ + } + } else { + i__1 = nr - 1; + i__2 = nr - 1; + zlaset_("U", &i__1, &i__2, &c_b1, &c_b1, &v[(v_dim1 << 1) + + 1], ldv); + } + +/* Second preconditioning finished; continue with Jacobi SVD */ +/* The input matrix is lower trinagular. */ + +/* Recover the right singular vectors as solution of a well */ +/* conditioned triangular matrix equation. */ + + if (condr1 < cond_ok__) { + + i__1 = *lwork - (*n << 1) - *n * nr - nr; + zgesvj_("L", "U", "N", &nr, &nr, &v[v_offset], ldv, &sva[ + 1], &nr, &u[u_offset], ldu, &cwork[(*n << 1) + *n + * nr + nr + 1], &i__1, &rwork[1], lrwork, info); + scalem = rwork[1]; + numrank = i_dnnt(&rwork[2]); + i__1 = nr; + for (p = 1; p <= i__1; ++p) { + zcopy_(&nr, &v[p * v_dim1 + 1], &c__1, &u[p * u_dim1 + + 1], &c__1); + zdscal_(&nr, &sva[p], &v[p * v_dim1 + 1], &c__1); +/* L3970: */ + } + + if (nr == *n) { +/* :)) .. best case, R1 is inverted. The solution of this matrix */ +/* equation is Q2*V2 = the product of the Jacobi rotations */ +/* used in ZGESVJ, premultiplied with the orthogonal matrix */ +/* from the second QR factorization. */ + ztrsm_("L", "U", "N", "N", &nr, &nr, &c_b2, &a[ + a_offset], lda, &v[v_offset], ldv); + } else { +/* is inverted to get the product of the Jacobi rotations */ +/* used in ZGESVJ. The Q-factor from the second QR */ +/* factorization is then built in explicitly. */ + ztrsm_("L", "U", "C", "N", &nr, &nr, &c_b2, &cwork[(* + n << 1) + 1], n, &v[v_offset], ldv); + if (nr < *n) { + i__1 = *n - nr; + zlaset_("A", &i__1, &nr, &c_b1, &c_b1, &v[nr + 1 + + v_dim1], ldv); + i__1 = *n - nr; + zlaset_("A", &nr, &i__1, &c_b1, &c_b1, &v[(nr + 1) + * v_dim1 + 1], ldv); + i__1 = *n - nr; + i__2 = *n - nr; + zlaset_("A", &i__1, &i__2, &c_b1, &c_b2, &v[nr + + 1 + (nr + 1) * v_dim1], ldv); + } + i__1 = *lwork - (*n << 1) - *n * nr - nr; + zunmqr_("L", "N", n, n, &nr, &cwork[(*n << 1) + 1], n, + &cwork[*n + 1], &v[v_offset], ldv, &cwork[(* + n << 1) + *n * nr + nr + 1], &i__1, &ierr); + } + + } else if (condr2 < cond_ok__) { + +/* The matrix R2 is inverted. The solution of the matrix equation */ +/* is Q3^* * V3 = the product of the Jacobi rotations (appplied to */ +/* the lower triangular L3 from the LQ factorization of */ +/* R2=L3*Q3), pre-multiplied with the transposed Q3. */ + i__1 = *lwork - (*n << 1) - *n * nr - nr; + zgesvj_("L", "U", "N", &nr, &nr, &v[v_offset], ldv, &sva[ + 1], &nr, &u[u_offset], ldu, &cwork[(*n << 1) + *n + * nr + nr + 1], &i__1, &rwork[1], lrwork, info); + scalem = rwork[1]; + numrank = i_dnnt(&rwork[2]); + i__1 = nr; + for (p = 1; p <= i__1; ++p) { + zcopy_(&nr, &v[p * v_dim1 + 1], &c__1, &u[p * u_dim1 + + 1], &c__1); + zdscal_(&nr, &sva[p], &u[p * u_dim1 + 1], &c__1); +/* L3870: */ + } + ztrsm_("L", "U", "N", "N", &nr, &nr, &c_b2, &cwork[(*n << + 1) + 1], n, &u[u_offset], ldu); + i__1 = nr; + for (q = 1; q <= i__1; ++q) { + i__2 = nr; + for (p = 1; p <= i__2; ++p) { + i__3 = (*n << 1) + *n * nr + nr + iwork[*n + p]; + i__4 = p + q * u_dim1; + cwork[i__3].r = u[i__4].r, cwork[i__3].i = u[i__4] + .i; +/* L872: */ + } + i__2 = nr; + for (p = 1; p <= i__2; ++p) { + i__3 = p + q * u_dim1; + i__4 = (*n << 1) + *n * nr + nr + p; + u[i__3].r = cwork[i__4].r, u[i__3].i = cwork[i__4] + .i; +/* L874: */ + } +/* L873: */ + } + if (nr < *n) { + i__1 = *n - nr; + zlaset_("A", &i__1, &nr, &c_b1, &c_b1, &v[nr + 1 + + v_dim1], ldv); + i__1 = *n - nr; + zlaset_("A", &nr, &i__1, &c_b1, &c_b1, &v[(nr + 1) * + v_dim1 + 1], ldv); + i__1 = *n - nr; + i__2 = *n - nr; + zlaset_("A", &i__1, &i__2, &c_b1, &c_b2, &v[nr + 1 + ( + nr + 1) * v_dim1], ldv); + } + i__1 = *lwork - (*n << 1) - *n * nr - nr; + zunmqr_("L", "N", n, n, &nr, &cwork[(*n << 1) + 1], n, & + cwork[*n + 1], &v[v_offset], ldv, &cwork[(*n << 1) + + *n * nr + nr + 1], &i__1, &ierr); + } else { +/* Last line of defense. */ +/* #:( This is a rather pathological case: no scaled condition */ +/* improvement after two pivoted QR factorizations. Other */ +/* possibility is that the rank revealing QR factorization */ +/* or the condition estimator has failed, or the COND_OK */ +/* is set very close to ONE (which is unnecessary). Normally, */ +/* this branch should never be executed, but in rare cases of */ +/* failure of the RRQR or condition estimator, the last line of */ +/* defense ensures that ZGEJSV completes the task. */ +/* Compute the full SVD of L3 using ZGESVJ with explicit */ +/* accumulation of Jacobi rotations. */ + i__1 = *lwork - (*n << 1) - *n * nr - nr; + zgesvj_("L", "U", "V", &nr, &nr, &v[v_offset], ldv, &sva[ + 1], &nr, &u[u_offset], ldu, &cwork[(*n << 1) + *n + * nr + nr + 1], &i__1, &rwork[1], lrwork, info); + scalem = rwork[1]; + numrank = i_dnnt(&rwork[2]); + if (nr < *n) { + i__1 = *n - nr; + zlaset_("A", &i__1, &nr, &c_b1, &c_b1, &v[nr + 1 + + v_dim1], ldv); + i__1 = *n - nr; + zlaset_("A", &nr, &i__1, &c_b1, &c_b1, &v[(nr + 1) * + v_dim1 + 1], ldv); + i__1 = *n - nr; + i__2 = *n - nr; + zlaset_("A", &i__1, &i__2, &c_b1, &c_b2, &v[nr + 1 + ( + nr + 1) * v_dim1], ldv); + } + i__1 = *lwork - (*n << 1) - *n * nr - nr; + zunmqr_("L", "N", n, n, &nr, &cwork[(*n << 1) + 1], n, & + cwork[*n + 1], &v[v_offset], ldv, &cwork[(*n << 1) + + *n * nr + nr + 1], &i__1, &ierr); + + i__1 = *lwork - (*n << 1) - *n * nr - nr; + zunmlq_("L", "C", &nr, &nr, &nr, &cwork[(*n << 1) + 1], n, + &cwork[(*n << 1) + *n * nr + 1], &u[u_offset], + ldu, &cwork[(*n << 1) + *n * nr + nr + 1], &i__1, + &ierr); + i__1 = nr; + for (q = 1; q <= i__1; ++q) { + i__2 = nr; + for (p = 1; p <= i__2; ++p) { + i__3 = (*n << 1) + *n * nr + nr + iwork[*n + p]; + i__4 = p + q * u_dim1; + cwork[i__3].r = u[i__4].r, cwork[i__3].i = u[i__4] + .i; +/* L772: */ + } + i__2 = nr; + for (p = 1; p <= i__2; ++p) { + i__3 = p + q * u_dim1; + i__4 = (*n << 1) + *n * nr + nr + p; + u[i__3].r = cwork[i__4].r, u[i__3].i = cwork[i__4] + .i; +/* L774: */ + } +/* L773: */ + } + + } + +/* Permute the rows of V using the (column) permutation from the */ +/* first QRF. Also, scale the columns to make them unit in */ +/* Euclidean norm. This applies to all cases. */ + + temp1 = sqrt((doublereal) (*n)) * epsln; + i__1 = *n; + for (q = 1; q <= i__1; ++q) { + i__2 = *n; + for (p = 1; p <= i__2; ++p) { + i__3 = (*n << 1) + *n * nr + nr + iwork[p]; + i__4 = p + q * v_dim1; + cwork[i__3].r = v[i__4].r, cwork[i__3].i = v[i__4].i; +/* L972: */ + } + i__2 = *n; + for (p = 1; p <= i__2; ++p) { + i__3 = p + q * v_dim1; + i__4 = (*n << 1) + *n * nr + nr + p; + v[i__3].r = cwork[i__4].r, v[i__3].i = cwork[i__4].i; +/* L973: */ + } + xsc = 1. / dznrm2_(n, &v[q * v_dim1 + 1], &c__1); + if (xsc < 1. - temp1 || xsc > temp1 + 1.) { + zdscal_(n, &xsc, &v[q * v_dim1 + 1], &c__1); + } +/* L1972: */ + } +/* At this moment, V contains the right singular vectors of A. */ +/* Next, assemble the left singular vector matrix U (M x N). */ + if (nr < *m) { + i__1 = *m - nr; + zlaset_("A", &i__1, &nr, &c_b1, &c_b1, &u[nr + 1 + u_dim1] + , ldu); + if (nr < n1) { + i__1 = n1 - nr; + zlaset_("A", &nr, &i__1, &c_b1, &c_b1, &u[(nr + 1) * + u_dim1 + 1], ldu); + i__1 = *m - nr; + i__2 = n1 - nr; + zlaset_("A", &i__1, &i__2, &c_b1, &c_b2, &u[nr + 1 + ( + nr + 1) * u_dim1], ldu); + } + } + +/* The Q matrix from the first QRF is built into the left singular */ +/* matrix U. This applies to all cases. */ + + i__1 = *lwork - *n; + zunmqr_("L", "N", m, &n1, n, &a[a_offset], lda, &cwork[1], &u[ + u_offset], ldu, &cwork[*n + 1], &i__1, &ierr); +/* The columns of U are normalized. The cost is O(M*N) flops. */ + temp1 = sqrt((doublereal) (*m)) * epsln; + i__1 = nr; + for (p = 1; p <= i__1; ++p) { + xsc = 1. / dznrm2_(m, &u[p * u_dim1 + 1], &c__1); + if (xsc < 1. - temp1 || xsc > temp1 + 1.) { + zdscal_(m, &xsc, &u[p * u_dim1 + 1], &c__1); + } +/* L1973: */ + } + +/* If the initial QRF is computed with row pivoting, the left */ +/* singular vectors must be adjusted. */ + + if (rowpiv) { + i__1 = *m - 1; + zlaswp_(&n1, &u[u_offset], ldu, &c__1, &i__1, &iwork[ + iwoff + 1], &c_n1); + } + + } else { + +/* the second QRF is not needed */ + + zlacpy_("U", n, n, &a[a_offset], lda, &cwork[*n + 1], n); + if (l2pert) { + xsc = sqrt(small); + i__1 = *n; + for (p = 2; p <= i__1; ++p) { + i__2 = *n + (p - 1) * *n + p; + z__1.r = xsc * cwork[i__2].r, z__1.i = xsc * cwork[ + i__2].i; + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__2 = p - 1; + for (q = 1; q <= i__2; ++q) { +/* CWORK(N+(q-1)*N+p)=-TEMP1 * ( CWORK(N+(p-1)*N+q) / */ +/* $ ABS(CWORK(N+(p-1)*N+q)) ) */ + i__3 = *n + (q - 1) * *n + p; + z__1.r = -ctemp.r, z__1.i = -ctemp.i; + cwork[i__3].r = z__1.r, cwork[i__3].i = z__1.i; +/* L5971: */ + } +/* L5970: */ + } + } else { + i__1 = *n - 1; + i__2 = *n - 1; + zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &cwork[*n + 2], + n); + } + + i__1 = *lwork - *n - *n * *n; + zgesvj_("U", "U", "N", n, n, &cwork[*n + 1], n, &sva[1], n, & + u[u_offset], ldu, &cwork[*n + *n * *n + 1], &i__1, & + rwork[1], lrwork, info); + + scalem = rwork[1]; + numrank = i_dnnt(&rwork[2]); + i__1 = *n; + for (p = 1; p <= i__1; ++p) { + zcopy_(n, &cwork[*n + (p - 1) * *n + 1], &c__1, &u[p * + u_dim1 + 1], &c__1); + zdscal_(n, &sva[p], &cwork[*n + (p - 1) * *n + 1], &c__1); +/* L6970: */ + } + + ztrsm_("L", "U", "N", "N", n, n, &c_b2, &a[a_offset], lda, & + cwork[*n + 1], n); + i__1 = *n; + for (p = 1; p <= i__1; ++p) { + zcopy_(n, &cwork[*n + p], n, &v[iwork[p] + v_dim1], ldv); +/* L6972: */ + } + temp1 = sqrt((doublereal) (*n)) * epsln; + i__1 = *n; + for (p = 1; p <= i__1; ++p) { + xsc = 1. / dznrm2_(n, &v[p * v_dim1 + 1], &c__1); + if (xsc < 1. - temp1 || xsc > temp1 + 1.) { + zdscal_(n, &xsc, &v[p * v_dim1 + 1], &c__1); + } +/* L6971: */ + } + +/* Assemble the left singular vector matrix U (M x N). */ + + if (*n < *m) { + i__1 = *m - *n; + zlaset_("A", &i__1, n, &c_b1, &c_b1, &u[*n + 1 + u_dim1], + ldu); + if (*n < n1) { + i__1 = n1 - *n; + zlaset_("A", n, &i__1, &c_b1, &c_b1, &u[(*n + 1) * + u_dim1 + 1], ldu); + i__1 = *m - *n; + i__2 = n1 - *n; + zlaset_("A", &i__1, &i__2, &c_b1, &c_b2, &u[*n + 1 + ( + *n + 1) * u_dim1], ldu); + } + } + i__1 = *lwork - *n; + zunmqr_("L", "N", m, &n1, n, &a[a_offset], lda, &cwork[1], &u[ + u_offset], ldu, &cwork[*n + 1], &i__1, &ierr); + temp1 = sqrt((doublereal) (*m)) * epsln; + i__1 = n1; + for (p = 1; p <= i__1; ++p) { + xsc = 1. / dznrm2_(m, &u[p * u_dim1 + 1], &c__1); + if (xsc < 1. - temp1 || xsc > temp1 + 1.) { + zdscal_(m, &xsc, &u[p * u_dim1 + 1], &c__1); + } +/* L6973: */ + } + + if (rowpiv) { + i__1 = *m - 1; + zlaswp_(&n1, &u[u_offset], ldu, &c__1, &i__1, &iwork[ + iwoff + 1], &c_n1); + } + + } + +/* end of the >> almost orthogonal case << in the full SVD */ + + } else { + +/* This branch deploys a preconditioned Jacobi SVD with explicitly */ +/* accumulated rotations. It is included as optional, mainly for */ +/* experimental purposes. It does perform well, and can also be used. */ +/* In this implementation, this branch will be automatically activated */ +/* if the condition number sigma_max(A) / sigma_min(A) is predicted */ +/* to be greater than the overflow threshold. This is because the */ +/* a posteriori computation of the singular vectors assumes robust */ +/* implementation of BLAS and some LAPACK procedures, capable of working */ +/* in presence of extreme values, e.g. when the singular values spread from */ +/* the underflow to the overflow threshold. */ + + i__1 = nr; + for (p = 1; p <= i__1; ++p) { + i__2 = *n - p + 1; + zcopy_(&i__2, &a[p + p * a_dim1], lda, &v[p + p * v_dim1], & + c__1); + i__2 = *n - p + 1; + zlacgv_(&i__2, &v[p + p * v_dim1], &c__1); +/* L7968: */ + } + + if (l2pert) { + xsc = sqrt(small / epsln); + i__1 = nr; + for (q = 1; q <= i__1; ++q) { + d__1 = xsc * z_abs(&v[q + q * v_dim1]); + z__1.r = d__1, z__1.i = 0.; + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__2 = *n; + for (p = 1; p <= i__2; ++p) { + if (p > q && z_abs(&v[p + q * v_dim1]) <= temp1 || p < + q) { + i__3 = p + q * v_dim1; + v[i__3].r = ctemp.r, v[i__3].i = ctemp.i; + } +/* $ V(p,q) = TEMP1 * ( V(p,q) / ABS(V(p,q)) ) */ + if (p < q) { + i__3 = p + q * v_dim1; + i__4 = p + q * v_dim1; + z__1.r = -v[i__4].r, z__1.i = -v[i__4].i; + v[i__3].r = z__1.r, v[i__3].i = z__1.i; + } +/* L5968: */ + } +/* L5969: */ + } + } else { + i__1 = nr - 1; + i__2 = nr - 1; + zlaset_("U", &i__1, &i__2, &c_b1, &c_b1, &v[(v_dim1 << 1) + 1] + , ldv); + } + i__1 = *lwork - (*n << 1); + zgeqrf_(n, &nr, &v[v_offset], ldv, &cwork[*n + 1], &cwork[(*n << + 1) + 1], &i__1, &ierr); + zlacpy_("L", n, &nr, &v[v_offset], ldv, &cwork[(*n << 1) + 1], n); + + i__1 = nr; + for (p = 1; p <= i__1; ++p) { + i__2 = nr - p + 1; + zcopy_(&i__2, &v[p + p * v_dim1], ldv, &u[p + p * u_dim1], & + c__1); + i__2 = nr - p + 1; + zlacgv_(&i__2, &u[p + p * u_dim1], &c__1); +/* L7969: */ + } + if (l2pert) { + xsc = sqrt(small / epsln); + i__1 = nr; + for (q = 2; q <= i__1; ++q) { + i__2 = q - 1; + for (p = 1; p <= i__2; ++p) { +/* Computing MIN */ + d__2 = z_abs(&u[p + p * u_dim1]), d__3 = z_abs(&u[q + + q * u_dim1]); + d__1 = xsc * f2cmin(d__2,d__3); + z__1.r = d__1, z__1.i = 0.; + ctemp.r = z__1.r, ctemp.i = z__1.i; +/* U(p,q) = - TEMP1 * ( U(q,p) / ABS(U(q,p)) ) */ + i__3 = p + q * u_dim1; + z__1.r = -ctemp.r, z__1.i = -ctemp.i; + u[i__3].r = z__1.r, u[i__3].i = z__1.i; +/* L9971: */ + } +/* L9970: */ + } + } else { + i__1 = nr - 1; + i__2 = nr - 1; + zlaset_("U", &i__1, &i__2, &c_b1, &c_b1, &u[(u_dim1 << 1) + 1] + , ldu); + } + i__1 = *lwork - (*n << 1) - *n * nr; + zgesvj_("L", "U", "V", &nr, &nr, &u[u_offset], ldu, &sva[1], n, & + v[v_offset], ldv, &cwork[(*n << 1) + *n * nr + 1], &i__1, + &rwork[1], lrwork, info); + scalem = rwork[1]; + numrank = i_dnnt(&rwork[2]); + if (nr < *n) { + i__1 = *n - nr; + zlaset_("A", &i__1, &nr, &c_b1, &c_b1, &v[nr + 1 + v_dim1], + ldv); + i__1 = *n - nr; + zlaset_("A", &nr, &i__1, &c_b1, &c_b1, &v[(nr + 1) * v_dim1 + + 1], ldv); + i__1 = *n - nr; + i__2 = *n - nr; + zlaset_("A", &i__1, &i__2, &c_b1, &c_b2, &v[nr + 1 + (nr + 1) + * v_dim1], ldv); + } + i__1 = *lwork - (*n << 1) - *n * nr - nr; + zunmqr_("L", "N", n, n, &nr, &cwork[(*n << 1) + 1], n, &cwork[*n + + 1], &v[v_offset], ldv, &cwork[(*n << 1) + *n * nr + nr + + 1], &i__1, &ierr); + +/* Permute the rows of V using the (column) permutation from the */ +/* first QRF. Also, scale the columns to make them unit in */ +/* Euclidean norm. This applies to all cases. */ + + temp1 = sqrt((doublereal) (*n)) * epsln; + i__1 = *n; + for (q = 1; q <= i__1; ++q) { + i__2 = *n; + for (p = 1; p <= i__2; ++p) { + i__3 = (*n << 1) + *n * nr + nr + iwork[p]; + i__4 = p + q * v_dim1; + cwork[i__3].r = v[i__4].r, cwork[i__3].i = v[i__4].i; +/* L8972: */ + } + i__2 = *n; + for (p = 1; p <= i__2; ++p) { + i__3 = p + q * v_dim1; + i__4 = (*n << 1) + *n * nr + nr + p; + v[i__3].r = cwork[i__4].r, v[i__3].i = cwork[i__4].i; +/* L8973: */ + } + xsc = 1. / dznrm2_(n, &v[q * v_dim1 + 1], &c__1); + if (xsc < 1. - temp1 || xsc > temp1 + 1.) { + zdscal_(n, &xsc, &v[q * v_dim1 + 1], &c__1); + } +/* L7972: */ + } + +/* At this moment, V contains the right singular vectors of A. */ +/* Next, assemble the left singular vector matrix U (M x N). */ + + if (nr < *m) { + i__1 = *m - nr; + zlaset_("A", &i__1, &nr, &c_b1, &c_b1, &u[nr + 1 + u_dim1], + ldu); + if (nr < n1) { + i__1 = n1 - nr; + zlaset_("A", &nr, &i__1, &c_b1, &c_b1, &u[(nr + 1) * + u_dim1 + 1], ldu); + i__1 = *m - nr; + i__2 = n1 - nr; + zlaset_("A", &i__1, &i__2, &c_b1, &c_b2, &u[nr + 1 + (nr + + 1) * u_dim1], ldu); + } + } + + i__1 = *lwork - *n; + zunmqr_("L", "N", m, &n1, n, &a[a_offset], lda, &cwork[1], &u[ + u_offset], ldu, &cwork[*n + 1], &i__1, &ierr); + + if (rowpiv) { + i__1 = *m - 1; + zlaswp_(&n1, &u[u_offset], ldu, &c__1, &i__1, &iwork[iwoff + + 1], &c_n1); + } + + + } + if (transp) { + i__1 = *n; + for (p = 1; p <= i__1; ++p) { + zswap_(n, &u[p * u_dim1 + 1], &c__1, &v[p * v_dim1 + 1], & + c__1); +/* L6974: */ + } + } + + } +/* end of the full SVD */ + +/* Undo scaling, if necessary (and possible) */ + + if (uscal2 <= big / sva[1] * uscal1) { + dlascl_("G", &c__0, &c__0, &uscal1, &uscal2, &nr, &c__1, &sva[1], n, & + ierr); + uscal1 = 1.; + uscal2 = 1.; + } + + if (nr < *n) { + i__1 = *n; + for (p = nr + 1; p <= i__1; ++p) { + sva[p] = 0.; +/* L3004: */ + } + } + + rwork[1] = uscal2 * scalem; + rwork[2] = uscal1; + if (errest) { + rwork[3] = sconda; + } + if (lsvec && rsvec) { + rwork[4] = condr1; + rwork[5] = condr2; + } + if (l2tran) { + rwork[6] = entra; + rwork[7] = entrat; + } + + iwork[1] = nr; + iwork[2] = numrank; + iwork[3] = warning; + if (transp) { + iwork[4] = 1; + } else { + iwork[4] = -1; + } + + return 0; +} /* zgejsv_ */ + diff --git a/lapack-netlib/SRC/zgelq.c b/lapack-netlib/SRC/zgelq.c new file mode 100644 index 000000000..bf424bcdb --- /dev/null +++ b/lapack-netlib/SRC/zgelq.c @@ -0,0 +1,746 @@ +/* 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 ZGELQ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGELQ( M, N, A, LDA, T, TSIZE, WORK, LWORK, */ +/* INFO ) */ + +/* INTEGER INFO, LDA, M, N, TSIZE, LWORK */ +/* COMPLEX*16 A( LDA, * ), T( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGELQ computes an LQ factorization of a complex M-by-N matrix A: */ +/* > */ +/* > A = ( L 0 ) * Q */ +/* > */ +/* > where: */ +/* > */ +/* > Q is a N-by-N orthogonal matrix; */ +/* > L is a lower-triangular M-by-M matrix; */ +/* > 0 is a M-by-(N-M) zero matrix, if M < N. */ +/* > */ +/* > \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 elements on and below the diagonal of the array */ +/* > contain the M-by-f2cmin(M,N) lower trapezoidal matrix L */ +/* > (L is lower triangular if M <= N); */ +/* > the elements above the diagonal are used to store part of the */ +/* > data structure to represent Q. */ +/* > \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 (MAX(5,TSIZE)) */ +/* > On exit, if INFO = 0, T(1) returns optimal (or either minimal */ +/* > or optimal, if query is assumed) TSIZE. See TSIZE for details. */ +/* > Remaining T contains part of the data structure used to represent Q. */ +/* > If one wants to apply or construct Q, then one needs to keep T */ +/* > (in addition to A) and pass it to further subroutines. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TSIZE */ +/* > \verbatim */ +/* > TSIZE is INTEGER */ +/* > If TSIZE >= 5, the dimension of the array T. */ +/* > If TSIZE = -1 or -2, then a workspace query is assumed. The routine */ +/* > only calculates the sizes of the T and WORK arrays, returns these */ +/* > values as the first entries of the T and WORK arrays, and no error */ +/* > message related to T or WORK is issued by XERBLA. */ +/* > If TSIZE = -1, the routine calculates optimal size of T for the */ +/* > optimum performance and returns this value in T(1). */ +/* > If TSIZE = -2, the routine calculates minimal size of T and */ +/* > returns this value in T(1). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) contains optimal (or either minimal */ +/* > or optimal, if query was assumed) LWORK. */ +/* > See LWORK for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > If LWORK = -1 or -2, then a workspace query is assumed. The routine */ +/* > only calculates the sizes of the T and WORK arrays, returns these */ +/* > values as the first entries of the T and WORK arrays, and no error */ +/* > message related to T or WORK is issued by XERBLA. */ +/* > If LWORK = -1, the routine calculates optimal size of WORK for the */ +/* > optimal performance and returns this value in WORK(1). */ +/* > If LWORK = -2, the routine calculates minimal size of WORK and */ +/* > returns this value in WORK(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. */ + +/* > \par Further Details */ +/* ==================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The goal of the interface is to give maximum freedom to the developers for */ +/* > creating any LQ factorization algorithm they wish. The triangular */ +/* > (trapezoidal) L has to be stored in the lower part of A. The lower part of A */ +/* > and the array T can be used to store any relevant information for applying or */ +/* > constructing the Q factor. The WORK array can safely be discarded after exit. */ +/* > */ +/* > Caution: One should not expect the sizes of T and WORK to be the same from one */ +/* > LAPACK implementation to the other, or even from one execution to the other. */ +/* > A workspace query (for T and WORK) is needed at each execution. However, */ +/* > for a given execution, the size of T and WORK are fixed and will not change */ +/* > from one query to the next. */ +/* > */ +/* > \endverbatim */ +/* > */ +/* > \par Further Details particular to this LAPACK implementation: */ +/* ============================================================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > These details are particular for this LAPACK implementation. Users should not */ +/* > take them for granted. These details may change in the future, and are not likely */ +/* > true for another LAPACK implementation. These details are relevant if one wants */ +/* > to try to understand the code. They are not part of the interface. */ +/* > */ +/* > In this version, */ +/* > */ +/* > T(2): row block size (MB) */ +/* > T(3): column block size (NB) */ +/* > T(6:TSIZE): data structure needed for Q, computed by */ +/* > ZLASWLQ or ZGELQT */ +/* > */ +/* > Depending on the matrix dimensions M and N, and row and column */ +/* > block sizes MB and NB returned by ILAENV, ZGELQ will use either */ +/* > ZLASWLQ (if the matrix is short-and-wide) or ZGELQT to compute */ +/* > the LQ factorization. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgelq_(integer *m, integer *n, doublecomplex *a, integer + *lda, doublecomplex *t, integer *tsize, doublecomplex *work, integer * + lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + logical mint, minw; + integer lwmin, lwreq, lwopt, mb, nb, nblcks; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int zgelqt_(integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + logical lminws, lquery; + integer mintsz; + extern /* Subroutine */ int zlaswlq_(integer *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, integer *); + + +/* -- 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. -- */ +/* November 2019 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --t; + --work; + + /* Function Body */ + *info = 0; + + lquery = *tsize == -1 || *tsize == -2 || *lwork == -1 || *lwork == -2; + + mint = FALSE_; + minw = FALSE_; + if (*tsize == -2 || *lwork == -2) { + if (*tsize != -1) { + mint = TRUE_; + } + if (*lwork != -1) { + minw = TRUE_; + } + } + +/* Determine the block size */ + + if (f2cmin(*m,*n) > 0) { + mb = ilaenv_(&c__1, "ZGELQ ", " ", m, n, &c__1, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb = ilaenv_(&c__1, "ZGELQ ", " ", m, n, &c__2, &c_n1, (ftnlen)6, ( + ftnlen)1); + } else { + mb = 1; + nb = *n; + } + if (mb > f2cmin(*m,*n) || mb < 1) { + mb = 1; + } + if (nb > *n || nb <= *m) { + nb = *n; + } + mintsz = *m + 5; + if (nb > *m && *n > *m) { + if ((*n - *m) % (nb - *m) == 0) { + nblcks = (*n - *m) / (nb - *m); + } else { + nblcks = (*n - *m) / (nb - *m) + 1; + } + } else { + nblcks = 1; + } + +/* Determine if the workspace size satisfies minimal size */ + + if (*n <= *m || nb <= *m || nb >= *n) { + lwmin = f2cmax(1,*n); +/* Computing MAX */ + i__1 = 1, i__2 = mb * *n; + lwopt = f2cmax(i__1,i__2); + } else { + lwmin = f2cmax(1,*m); +/* Computing MAX */ + i__1 = 1, i__2 = mb * *m; + lwopt = f2cmax(i__1,i__2); + } + lminws = FALSE_; +/* Computing MAX */ + i__1 = 1, i__2 = mb * *m * nblcks + 5; + if ((*tsize < f2cmax(i__1,i__2) || *lwork < lwopt) && *lwork >= lwmin && * + tsize >= mintsz && ! lquery) { +/* Computing MAX */ + i__1 = 1, i__2 = mb * *m * nblcks + 5; + if (*tsize < f2cmax(i__1,i__2)) { + lminws = TRUE_; + mb = 1; + nb = *n; + } + if (*lwork < lwopt) { + lminws = TRUE_; + mb = 1; + } + } + if (*n <= *m || nb <= *m || nb >= *n) { +/* Computing MAX */ + i__1 = 1, i__2 = mb * *n; + lwreq = f2cmax(i__1,i__2); + } else { +/* Computing MAX */ + i__1 = 1, i__2 = mb * *m; + lwreq = f2cmax(i__1,i__2); + } + + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = mb * *m * nblcks + 5; + if (*tsize < f2cmax(i__1,i__2) && ! lquery && ! lminws) { + *info = -6; + } else if (*lwork < lwreq && ! lquery && ! lminws) { + *info = -8; + } + } + + if (*info == 0) { + if (mint) { + t[1].r = (doublereal) mintsz, t[1].i = 0.; + } else { + i__1 = mb * *m * nblcks + 5; + t[1].r = (doublereal) i__1, t[1].i = 0.; + } + t[2].r = (doublereal) mb, t[2].i = 0.; + t[3].r = (doublereal) nb, t[3].i = 0.; + if (minw) { + work[1].r = (doublereal) lwmin, work[1].i = 0.; + } else { + work[1].r = (doublereal) lwreq, work[1].i = 0.; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGELQ", &i__1, (ftnlen)5); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (f2cmin(*m,*n) == 0) { + return 0; + } + +/* The LQ Decomposition */ + + if (*n <= *m || nb <= *m || nb >= *n) { + zgelqt_(m, n, &mb, &a[a_offset], lda, &t[6], &mb, &work[1], info); + } else { + zlaswlq_(m, n, &mb, &nb, &a[a_offset], lda, &t[6], &mb, &work[1], + lwork, info); + } + + work[1].r = (doublereal) lwreq, work[1].i = 0.; + + return 0; + +/* End of ZGELQ */ + +} /* zgelq_ */ + diff --git a/lapack-netlib/SRC/zgelq2.c b/lapack-netlib/SRC/zgelq2.c new file mode 100644 index 000000000..93269408a --- /dev/null +++ b/lapack-netlib/SRC/zgelq2.c @@ -0,0 +1,605 @@ +/* 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 ZGELQ2 computes the LQ factorization of a general rectangular matrix using an unblocked algorit +hm. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGELQ2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGELQ2( M, N, A, LDA, TAU, WORK, INFO ) */ + +/* INTEGER INFO, LDA, M, N */ +/* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGELQ2 computes an LQ factorization of a complex m-by-n matrix A: */ +/* > */ +/* > A = ( L 0 ) * Q */ +/* > */ +/* > where: */ +/* > */ +/* > Q is a n-by-n orthogonal matrix; */ +/* > L is an lower-triangular m-by-m matrix; */ +/* > 0 is a m-by-(n-m) zero matrix, if m < n. */ +/* > */ +/* > \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 elements on and below the diagonal of the array */ +/* > contain the m by f2cmin(m,n) lower trapezoidal matrix L (L is */ +/* > lower triangular if m <= n); the elements above the diagonal, */ +/* > with the array TAU, represent the unitary matrix Q as a */ +/* > product of elementary reflectors (see Further Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 array, dimension (f2cmin(M,N)) */ +/* > The scalar factors of the elementary reflectors (see Further */ +/* > Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (M) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2019 */ + +/* > \ingroup complex16GEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix Q is represented as a product of elementary reflectors */ +/* > */ +/* > Q = H(k)**H . . . H(2)**H H(1)**H, where k = f2cmin(m,n). */ +/* > */ +/* > 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-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in */ +/* > A(i,i+1:n), and tau in TAU(i). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgelq2_(integer *m, integer *n, doublecomplex *a, + integer *lda, doublecomplex *tau, doublecomplex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, k; + doublecomplex alpha; + extern /* Subroutine */ int zlarf_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *), xerbla_(char *, integer *, ftnlen), zlarfg_(integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *), zlacgv_(integer *, doublecomplex *, + integer *); + + +/* -- 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..-- */ +/* November 2019 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGELQ2", &i__1, (ftnlen)6); + return 0; + } + + k = f2cmin(*m,*n); + + i__1 = k; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Generate elementary reflector H(i) to annihilate A(i,i+1:n) */ + + i__2 = *n - i__ + 1; + zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda); + i__2 = i__ + i__ * a_dim1; + alpha.r = a[i__2].r, alpha.i = a[i__2].i; + i__2 = *n - i__ + 1; +/* Computing MIN */ + i__3 = i__ + 1; + zlarfg_(&i__2, &alpha, &a[i__ + f2cmin(i__3,*n) * a_dim1], lda, &tau[i__] + ); + if (i__ < *m) { + +/* Apply H(i) to A(i+1:m,i:n) from the right */ + + i__2 = i__ + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + i__2 = *m - i__; + i__3 = *n - i__ + 1; + zlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[ + i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]); + } + i__2 = i__ + i__ * a_dim1; + a[i__2].r = alpha.r, a[i__2].i = alpha.i; + i__2 = *n - i__ + 1; + zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda); +/* L10: */ + } + return 0; + +/* End of ZGELQ2 */ + +} /* zgelq2_ */ + diff --git a/lapack-netlib/SRC/zgelqf.c b/lapack-netlib/SRC/zgelqf.c new file mode 100644 index 000000000..ba8ac1b7b --- /dev/null +++ b/lapack-netlib/SRC/zgelqf.c @@ -0,0 +1,703 @@ +/* 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 ZGELQF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGELQF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) */ + +/* INTEGER INFO, LDA, LWORK, M, N */ +/* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGELQF computes an LQ factorization of a complex M-by-N matrix A: */ +/* > */ +/* > A = ( L 0 ) * Q */ +/* > */ +/* > where: */ +/* > */ +/* > Q is a N-by-N orthogonal matrix; */ +/* > L is an lower-triangular M-by-M matrix; */ +/* > 0 is a M-by-(N-M) zero matrix, if M < N. */ +/* > */ +/* > \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 elements on and below the diagonal of the array */ +/* > contain the m-by-f2cmin(m,n) lower trapezoidal matrix L (L is */ +/* > lower triangular if m <= n); the elements above the diagonal, */ +/* > with the array TAU, represent the unitary matrix Q as a */ +/* > product of elementary reflectors (see Further Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 array, dimension (f2cmin(M,N)) */ +/* > The scalar factors of the elementary reflectors (see Further */ +/* > Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,M). */ +/* > For optimum performance LWORK >= M*NB, where NB is the */ +/* > optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2019 */ + +/* > \ingroup complex16GEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix Q is represented as a product of elementary reflectors */ +/* > */ +/* > Q = H(k)**H . . . H(2)**H H(1)**H, where k = f2cmin(m,n). */ +/* > */ +/* > 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-1) = 0 and v(i) = 1; conjg(v(i+1:n)) is stored on exit in */ +/* > A(i,i+1:n), and tau in TAU(i). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgelqf_(integer *m, integer *n, doublecomplex *a, + integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, k, nbmin, iinfo; + extern /* Subroutine */ int zgelq2_(integer *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + integer ib, nb, nx; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *, + integer *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + integer ldwork; + extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + integer lwkopt; + logical lquery; + integer iws; + + +/* -- 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..-- */ +/* November 2019 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + nb = ilaenv_(&c__1, "ZGELQF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen) + 1); + lwkopt = *m * nb; + work[1].r = (doublereal) lwkopt, work[1].i = 0.; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } else if (*lwork < f2cmax(1,*m) && ! lquery) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGELQF", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + k = f2cmin(*m,*n); + if (k == 0) { + work[1].r = 1., work[1].i = 0.; + return 0; + } + + nbmin = 2; + nx = 0; + iws = *m; + if (nb > 1 && nb < k) { + +/* Determine when to cross over from blocked to unblocked code. */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "ZGELQF", " ", m, n, &c_n1, &c_n1, ( + ftnlen)6, (ftnlen)1); + nx = f2cmax(i__1,i__2); + if (nx < k) { + +/* Determine if workspace is large enough for blocked code. */ + + ldwork = *m; + iws = ldwork * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: reduce NB and */ +/* determine the minimum value of NB. */ + + nb = *lwork / ldwork; +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "ZGELQF", " ", m, n, &c_n1, & + c_n1, (ftnlen)6, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + } + } + } + + if (nb >= nbmin && nb < k && nx < k) { + +/* Use blocked code initially */ + + i__1 = k - nx; + i__2 = nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = k - i__ + 1; + ib = f2cmin(i__3,nb); + +/* Compute the LQ factorization of the current block */ +/* A(i:i+ib-1,i:n) */ + + i__3 = *n - i__ + 1; + zgelq2_(&ib, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[ + 1], &iinfo); + if (i__ + ib <= *m) { + +/* Form the triangular factor of the block reflector */ +/* H = H(i) H(i+1) . . . H(i+ib-1) */ + + i__3 = *n - i__ + 1; + zlarft_("Forward", "Rowwise", &i__3, &ib, &a[i__ + i__ * + a_dim1], lda, &tau[i__], &work[1], &ldwork); + +/* Apply H to A(i+ib:m,i:n) from the right */ + + i__3 = *m - i__ - ib + 1; + i__4 = *n - i__ + 1; + zlarfb_("Right", "No transpose", "Forward", "Rowwise", &i__3, + &i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], & + ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib + + 1], &ldwork); + } +/* L10: */ + } + } else { + i__ = 1; + } + +/* Use unblocked code to factor the last or only block. */ + + if (i__ <= k) { + i__2 = *m - i__ + 1; + i__1 = *n - i__ + 1; + zgelq2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1] + , &iinfo); + } + + work[1].r = (doublereal) iws, work[1].i = 0.; + return 0; + +/* End of ZGELQF */ + +} /* zgelqf_ */ + diff --git a/lapack-netlib/SRC/zgelqt.c b/lapack-netlib/SRC/zgelqt.c new file mode 100644 index 000000000..ab82b11b2 --- /dev/null +++ b/lapack-netlib/SRC/zgelqt.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 ZGELQT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGEQRT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGELQT( M, N, MB, A, LDA, T, LDT, WORK, INFO ) */ + +/* INTEGER INFO, LDA, LDT, M, N, MB */ +/* COMPLEX*16 A( LDA, * ), T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGELQT computes a blocked LQ factorization of a complex M-by-N matrix A */ +/* > using the compact WY representation of Q. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MB */ +/* > \verbatim */ +/* > MB is INTEGER */ +/* > The block size to be used in the blocked QR. MIN(M,N) >= MB >= 1. */ +/* > \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 M-by-MIN(M,N) lower trapezoidal matrix L (L is */ +/* > lower triangular if M <= N); the elements above the diagonal */ +/* > are the rows of V. */ +/* > \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,MIN(M,N)) */ +/* > The 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[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (MB*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 doubleGEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix V stores the elementary reflectors H(i) in the i-th row */ +/* > above the diagonal. For example, if M=5 and N=3, the matrix V is */ +/* > */ +/* > V = ( 1 v1 v1 v1 v1 ) */ +/* > ( 1 v2 v2 v2 ) */ +/* > ( 1 v3 v3 ) */ +/* > */ +/* > */ +/* > where the vi's represent the vectors which define H(i), which are returned */ +/* > in the matrix A. The 1's along the diagonal of V are not stored in A. */ +/* > Let K=MIN(M,N). The number of blocks is B = ceiling(K/MB), where each */ +/* > block is of order MB except for the last block, which is of order */ +/* > IB = K - (B-1)*MB. For each of the B blocks, a upper triangular block */ +/* > reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB */ +/* > for the last block) T's are stored in the MB-by-K matrix T as */ +/* > */ +/* > T = (T1 T2 ... TB). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgelqt_(integer *m, integer *n, integer *mb, + doublecomplex *a, integer *lda, doublecomplex *t, integer *ldt, + doublecomplex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, t_dim1, t_offset, i__1, i__2, i__3, i__4, i__5; + + /* Local variables */ + integer i__, k, iinfo, ib; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zlarfb_( + char *, char *, char *, char *, integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *), zgelqt3_(integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *) + ; + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 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; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*mb < 1 || *mb > f2cmin(*m,*n) && f2cmin(*m,*n) > 0) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } else if (*ldt < *mb) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGELQT", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + k = f2cmin(*m,*n); + if (k == 0) { + return 0; + } + +/* Blocked loop of length K */ + + i__1 = k; + i__2 = *mb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = k - i__ + 1; + ib = f2cmin(i__3,*mb); + +/* Compute the LQ factorization of the current block A(I:M,I:I+IB-1) */ + + i__3 = *n - i__ + 1; + zgelqt3_(&ib, &i__3, &a[i__ + i__ * a_dim1], lda, &t[i__ * t_dim1 + 1] + , ldt, &iinfo); + if (i__ + ib <= *m) { + +/* Update by applying H**T to A(I:M,I+IB:N) from the right */ + + i__3 = *m - i__ - ib + 1; + i__4 = *n - i__ + 1; + i__5 = *m - i__ - ib + 1; + zlarfb_("R", "N", "F", "R", &i__3, &i__4, &ib, &a[i__ + i__ * + a_dim1], lda, &t[i__ * t_dim1 + 1], ldt, &a[i__ + ib + + i__ * a_dim1], lda, &work[1], &i__5); + } + } + return 0; + +/* End of ZGELQT */ + +} /* zgelqt_ */ + diff --git a/lapack-netlib/SRC/zgelqt3.c b/lapack-netlib/SRC/zgelqt3.c new file mode 100644 index 000000000..e1d5dace9 --- /dev/null +++ b/lapack-netlib/SRC/zgelqt3.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 ZGELQT3 recursively computes a LQ factorization of a general real or complex matrix using the c +ompact WY representation of Q. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGEQRT3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGELQT3( M, N, A, LDA, T, LDT, INFO ) */ + +/* INTEGER INFO, LDA, M, N, LDT */ +/* COMPLEX*16 A( LDA, * ), T( LDT, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DGELQT3 recursively computes a LQ factorization of a complex M-by-N */ +/* > matrix A, using the compact WY representation of Q. */ +/* > */ +/* > Based on the algorithm of Elmroth and Gustavson, */ +/* > IBM J. Res. Develop. Vol 44 No. 4 July 2000. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M =< N. */ +/* > \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 real M-by-N matrix A. On exit, the elements on and */ +/* > below the diagonal contain the N-by-N lower triangular matrix L; the */ +/* > elements above the diagonal are the rows of V. See below for */ +/* > 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) */ +/* > The N-by-N upper triangular factor of the block reflector. */ +/* > The elements on and above the diagonal contain the block */ +/* > reflector T; the elements below the diagonal are not used. */ +/* > See below for further details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup doubleGEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix V stores the elementary reflectors H(i) in the i-th row */ +/* > above the diagonal. For example, if M=5 and N=3, the matrix V is */ +/* > */ +/* > V = ( 1 v1 v1 v1 v1 ) */ +/* > ( 1 v2 v2 v2 ) */ +/* > ( 1 v3 v3 v3 ) */ +/* > */ +/* > */ +/* > where the vi's represent the vectors which define H(i), which are returned */ +/* > in the matrix A. The 1's along the diagonal of V are not stored in A. The */ +/* > block reflector H is then given by */ +/* > */ +/* > H = I - V * T * V**T */ +/* > */ +/* > where V**T is the transpose of V. */ +/* > */ +/* > For details of the algorithm, see Elmroth and Gustavson (cited above). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgelqt3_(integer *m, integer *n, doublecomplex *a, + integer *lda, doublecomplex *t, integer *ldt, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, t_dim1, t_offset, i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1; + + /* Local variables */ + integer i__, j, iinfo; + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + integer i1, j1, m1, m2; + extern /* Subroutine */ int ztrmm_(char *, char *, char *, char *, + integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *), + xerbla_(char *, integer *, ftnlen), zlarfg_(integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *); + + +/* -- 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; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < *m) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } else if (*ldt < f2cmax(1,*m)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGELQT3", &i__1, (ftnlen)7); + return 0; + } + + if (*m == 1) { + +/* Compute Householder transform when N=1 */ + + zlarfg_(n, &a[a_offset], &a[f2cmin(2,*n) * a_dim1 + 1], lda, &t[t_offset] + ); + i__1 = t_dim1 + 1; + d_cnjg(&z__1, &t[t_dim1 + 1]); + t[i__1].r = z__1.r, t[i__1].i = z__1.i; + + } else { + +/* Otherwise, split A into blocks... */ + + m1 = *m / 2; + m2 = *m - m1; +/* Computing MIN */ + i__1 = m1 + 1; + i1 = f2cmin(i__1,*m); +/* Computing MIN */ + i__1 = *m + 1; + j1 = f2cmin(i__1,*n); + +/* Compute A(1:M1,1:N) <- (Y1,R1,T1), where Q1 = I - Y1 T1 Y1^H */ + + zgelqt3_(&m1, n, &a[a_offset], lda, &t[t_offset], ldt, &iinfo); + +/* Compute A(J1:M,1:N) = A(J1:M,1:N) Q1^H [workspace: T(1:N1,J1:N)] */ + + i__1 = m2; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = m1; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + m1 + j * t_dim1; + i__4 = i__ + m1 + j * a_dim1; + t[i__3].r = a[i__4].r, t[i__3].i = a[i__4].i; + } + } + ztrmm_("R", "U", "C", "U", &m2, &m1, &c_b1, &a[a_offset], lda, &t[i1 + + t_dim1], ldt); + + i__1 = *n - m1; + zgemm_("N", "C", &m2, &m1, &i__1, &c_b1, &a[i1 + i1 * a_dim1], lda, & + a[i1 * a_dim1 + 1], lda, &c_b1, &t[i1 + t_dim1], ldt); + + ztrmm_("R", "U", "N", "N", &m2, &m1, &c_b1, &t[t_offset], ldt, &t[i1 + + t_dim1], ldt); + + i__1 = *n - m1; + z__1.r = -1., z__1.i = 0.; + zgemm_("N", "N", &m2, &i__1, &m1, &z__1, &t[i1 + t_dim1], ldt, &a[i1 * + a_dim1 + 1], lda, &c_b1, &a[i1 + i1 * a_dim1], lda); + + ztrmm_("R", "U", "N", "U", &m2, &m1, &c_b1, &a[a_offset], lda, &t[i1 + + t_dim1], ldt); + + i__1 = m2; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = m1; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + m1 + j * a_dim1; + i__4 = i__ + m1 + j * a_dim1; + i__5 = i__ + m1 + j * t_dim1; + z__1.r = a[i__4].r - t[i__5].r, z__1.i = a[i__4].i - t[i__5] + .i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + i__3 = i__ + m1 + j * t_dim1; + t[i__3].r = 0., t[i__3].i = 0.; + } + } + +/* Compute A(J1:M,J1:N) <- (Y2,R2,T2) where Q2 = I - Y2 T2 Y2^H */ + + i__1 = *n - m1; + zgelqt3_(&m2, &i__1, &a[i1 + i1 * a_dim1], lda, &t[i1 + i1 * t_dim1], + ldt, &iinfo); + +/* Compute T3 = T(J1:N1,1:N) = -T1 Y1^H Y2 T2 */ + + i__1 = m2; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = m1; + for (j = 1; j <= i__2; ++j) { + i__3 = j + (i__ + m1) * t_dim1; + i__4 = j + (i__ + m1) * a_dim1; + t[i__3].r = a[i__4].r, t[i__3].i = a[i__4].i; + } + } + + ztrmm_("R", "U", "C", "U", &m1, &m2, &c_b1, &a[i1 + i1 * a_dim1], lda, + &t[i1 * t_dim1 + 1], ldt); + + i__1 = *n - *m; + zgemm_("N", "C", &m1, &m2, &i__1, &c_b1, &a[j1 * a_dim1 + 1], lda, &a[ + i1 + j1 * a_dim1], lda, &c_b1, &t[i1 * t_dim1 + 1], ldt); + + z__1.r = -1., z__1.i = 0.; + ztrmm_("L", "U", "N", "N", &m1, &m2, &z__1, &t[t_offset], ldt, &t[i1 * + t_dim1 + 1], ldt) + ; + + ztrmm_("R", "U", "N", "N", &m1, &m2, &c_b1, &t[i1 + i1 * t_dim1], ldt, + &t[i1 * t_dim1 + 1], ldt); + + + +/* Y = (Y1,Y2); L = [ L1 0 ]; T = [T1 T3] */ +/* [ A(1:N1,J1:N) L2 ] [ 0 T2] */ + + } + + return 0; + +/* End of ZGELQT3 */ + +} /* zgelqt3_ */ + diff --git a/lapack-netlib/SRC/zgels.c b/lapack-netlib/SRC/zgels.c new file mode 100644 index 000000000..4c50e06c7 --- /dev/null +++ b/lapack-netlib/SRC/zgels.c @@ -0,0 +1,961 @@ +/* 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 ZGELS solves overdetermined or underdetermined systems for GE matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGELS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK, */ +/* INFO ) */ + +/* CHARACTER TRANS */ +/* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS */ +/* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGELS solves overdetermined or underdetermined complex linear systems */ +/* > involving an M-by-N matrix A, or its conjugate-transpose, using a QR */ +/* > or LQ factorization of A. It is assumed that A has full rank. */ +/* > */ +/* > The following options are provided: */ +/* > */ +/* > 1. If TRANS = 'N' and m >= n: find the least squares solution of */ +/* > an overdetermined system, i.e., solve the least squares problem */ +/* > minimize || B - A*X ||. */ +/* > */ +/* > 2. If TRANS = 'N' and m < n: find the minimum norm solution of */ +/* > an underdetermined system A * X = B. */ +/* > */ +/* > 3. If TRANS = 'C' and m >= n: find the minimum norm solution of */ +/* > an underdetermined system A**H * X = B. */ +/* > */ +/* > 4. If TRANS = 'C' and m < n: find the least squares solution of */ +/* > an overdetermined system, i.e., solve the least squares problem */ +/* > minimize || B - A**H * X ||. */ +/* > */ +/* > Several right hand side vectors b and solution vectors x can be */ +/* > handled in a single call; they are stored as the columns of the */ +/* > M-by-NRHS right hand side matrix B and the N-by-NRHS solution */ +/* > matrix X. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': the linear system involves A; */ +/* > = 'C': the linear system involves A**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 A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of */ +/* > columns of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > if M >= N, A is overwritten by details of its QR */ +/* > factorization as returned by ZGEQRF; */ +/* > if M < N, A is overwritten by details of its LQ */ +/* > factorization as returned by ZGELQF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > On entry, the matrix B of right hand side vectors, stored */ +/* > columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS */ +/* > if TRANS = 'C'. */ +/* > On exit, if INFO = 0, B is overwritten by the solution */ +/* > vectors, stored columnwise: */ +/* > if TRANS = 'N' and m >= n, rows 1 to n of B contain the least */ +/* > squares solution vectors; the residual sum of squares for the */ +/* > solution in each column is given by the sum of squares of the */ +/* > modulus of elements N+1 to M in that column; */ +/* > if TRANS = 'N' and m < n, rows 1 to N of B contain the */ +/* > minimum norm solution vectors; */ +/* > if TRANS = 'C' and m >= n, rows 1 to M of B contain the */ +/* > minimum norm solution vectors; */ +/* > if TRANS = 'C' and m < n, rows 1 to M of B contain the */ +/* > least squares solution vectors; the residual sum of squares */ +/* > for the solution in each column is given by the sum of */ +/* > squares of the modulus of elements M+1 to N in that column. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= MAX(1,M,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > LWORK >= f2cmax( 1, MN + f2cmax( MN, NRHS ) ). */ +/* > For optimal performance, */ +/* > LWORK >= f2cmax( 1, MN + f2cmax( MN, NRHS )*NB ). */ +/* > where MN = f2cmin(M,N) and NB is the optimum block size. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the i-th diagonal element of the */ +/* > triangular factor of A is zero, so that A does not have */ +/* > full rank; the least squares solution could not be */ +/* > computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GEsolve */ + +/* ===================================================================== */ +/* Subroutine */ int zgels_(char *trans, integer *m, integer *n, integer * + nrhs, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, + doublecomplex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; + doublereal d__1; + + /* Local variables */ + doublereal anrm, bnrm; + integer brow; + logical tpsd; + integer i__, j, iascl, ibscl; + extern logical lsame_(char *, char *); + integer wsize; + doublereal rwork[1]; + extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); + integer nb; + extern doublereal dlamch_(char *); + integer mn; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer scllen; + doublereal bignum; + extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, + integer *, doublereal *); + extern /* Subroutine */ int zgelqf_(integer *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *, integer * + ), zlascl_(char *, integer *, integer *, doublereal *, doublereal + *, integer *, integer *, doublecomplex *, integer *, integer *), zgeqrf_(integer *, integer *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, integer *, integer *), zlaset_( + char *, integer *, integer *, doublecomplex *, doublecomplex *, + doublecomplex *, integer *); + doublereal smlnum; + logical lquery; + extern /* Subroutine */ int zunmlq_(char *, char *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *), zunmqr_(char *, char *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *), ztrtrs_(char *, char *, char *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *, + integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments. */ + + /* 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; + --work; + + /* Function Body */ + *info = 0; + mn = f2cmin(*m,*n); + lquery = *lwork == -1; + if (! (lsame_(trans, "N") || lsame_(trans, "C"))) { + *info = -1; + } else if (*m < 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*lda < f2cmax(1,*m)) { + *info = -6; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = f2cmax(1,*m); + if (*ldb < f2cmax(i__1,*n)) { + *info = -8; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = mn + f2cmax(mn,*nrhs); + if (*lwork < f2cmax(i__1,i__2) && ! lquery) { + *info = -10; + } + } + } + +/* Figure out optimal block size */ + + if (*info == 0 || *info == -10) { + + tpsd = TRUE_; + if (lsame_(trans, "N")) { + tpsd = FALSE_; + } + + if (*m >= *n) { + nb = ilaenv_(&c__1, "ZGEQRF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); + if (tpsd) { +/* Computing MAX */ + i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMQR", "LN", m, nrhs, n, & + c_n1, (ftnlen)6, (ftnlen)2); + nb = f2cmax(i__1,i__2); + } else { +/* Computing MAX */ + i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMQR", "LC", m, nrhs, n, & + c_n1, (ftnlen)6, (ftnlen)2); + nb = f2cmax(i__1,i__2); + } + } else { + nb = ilaenv_(&c__1, "ZGELQF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); + if (tpsd) { +/* Computing MAX */ + i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMLQ", "LC", n, nrhs, m, & + c_n1, (ftnlen)6, (ftnlen)2); + nb = f2cmax(i__1,i__2); + } else { +/* Computing MAX */ + i__1 = nb, i__2 = ilaenv_(&c__1, "ZUNMLQ", "LN", n, nrhs, m, & + c_n1, (ftnlen)6, (ftnlen)2); + nb = f2cmax(i__1,i__2); + } + } + +/* Computing MAX */ + i__1 = 1, i__2 = mn + f2cmax(mn,*nrhs) * nb; + wsize = f2cmax(i__1,i__2); + d__1 = (doublereal) wsize; + work[1].r = d__1, work[1].i = 0.; + + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGELS ", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + +/* Computing MIN */ + i__1 = f2cmin(*m,*n); + if (f2cmin(i__1,*nrhs) == 0) { + i__1 = f2cmax(*m,*n); + zlaset_("Full", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb); + return 0; + } + +/* Get machine parameters */ + + smlnum = dlamch_("S") / dlamch_("P"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + +/* Scale A, B if f2cmax element outside range [SMLNUM,BIGNUM] */ + + anrm = zlange_("M", m, n, &a[a_offset], lda, rwork); + iascl = 0; + if (anrm > 0. && anrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, + info); + iascl = 1; + } else if (anrm > bignum) { + +/* Scale matrix norm down to BIGNUM */ + + zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, + info); + iascl = 2; + } else if (anrm == 0.) { + +/* Matrix all zero. Return zero solution. */ + + i__1 = f2cmax(*m,*n); + zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb); + goto L50; + } + + brow = *m; + if (tpsd) { + brow = *n; + } + bnrm = zlange_("M", &brow, nrhs, &b[b_offset], ldb, rwork); + ibscl = 0; + if (bnrm > 0. && bnrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + zlascl_("G", &c__0, &c__0, &bnrm, &smlnum, &brow, nrhs, &b[b_offset], + ldb, info); + ibscl = 1; + } else if (bnrm > bignum) { + +/* Scale matrix norm down to BIGNUM */ + + zlascl_("G", &c__0, &c__0, &bnrm, &bignum, &brow, nrhs, &b[b_offset], + ldb, info); + ibscl = 2; + } + + if (*m >= *n) { + +/* compute QR factorization of A */ + + i__1 = *lwork - mn; + zgeqrf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info) + ; + +/* workspace at least N, optimally N*NB */ + + if (! tpsd) { + +/* Least-Squares Problem f2cmin || A * X - B || */ + +/* B(1:M,1:NRHS) := Q**H * B(1:M,1:NRHS) */ + + i__1 = *lwork - mn; + zunmqr_("Left", "Conjugate transpose", m, nrhs, n, &a[a_offset], + lda, &work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, + info); + +/* workspace at least NRHS, optimally NRHS*NB */ + +/* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) */ + + ztrtrs_("Upper", "No transpose", "Non-unit", n, nrhs, &a[a_offset] + , lda, &b[b_offset], ldb, info); + + if (*info > 0) { + return 0; + } + + scllen = *n; + + } else { + +/* Underdetermined system of equations A**T * X = B */ + +/* B(1:N,1:NRHS) := inv(R**H) * B(1:N,1:NRHS) */ + + ztrtrs_("Upper", "Conjugate transpose", "Non-unit", n, nrhs, &a[ + a_offset], lda, &b[b_offset], ldb, info); + + if (*info > 0) { + return 0; + } + +/* B(N+1:M,1:NRHS) = ZERO */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = *n + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + b[i__3].r = 0., b[i__3].i = 0.; +/* L10: */ + } +/* L20: */ + } + +/* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) */ + + i__1 = *lwork - mn; + zunmqr_("Left", "No transpose", m, nrhs, n, &a[a_offset], lda, & + work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info); + +/* workspace at least NRHS, optimally NRHS*NB */ + + scllen = *m; + + } + + } else { + +/* Compute LQ factorization of A */ + + i__1 = *lwork - mn; + zgelqf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info) + ; + +/* workspace at least M, optimally M*NB. */ + + if (! tpsd) { + +/* underdetermined system of equations A * X = B */ + +/* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) */ + + ztrtrs_("Lower", "No transpose", "Non-unit", m, nrhs, &a[a_offset] + , lda, &b[b_offset], ldb, info); + + if (*info > 0) { + return 0; + } + +/* B(M+1:N,1:NRHS) = 0 */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = *m + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + b[i__3].r = 0., b[i__3].i = 0.; +/* L30: */ + } +/* L40: */ + } + +/* B(1:N,1:NRHS) := Q(1:N,:)**H * B(1:M,1:NRHS) */ + + i__1 = *lwork - mn; + zunmlq_("Left", "Conjugate transpose", n, nrhs, m, &a[a_offset], + lda, &work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, + info); + +/* workspace at least NRHS, optimally NRHS*NB */ + + scllen = *n; + + } else { + +/* overdetermined system f2cmin || A**H * X - B || */ + +/* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) */ + + i__1 = *lwork - mn; + zunmlq_("Left", "No transpose", n, nrhs, m, &a[a_offset], lda, & + work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info); + +/* workspace at least NRHS, optimally NRHS*NB */ + +/* B(1:M,1:NRHS) := inv(L**H) * B(1:M,1:NRHS) */ + + ztrtrs_("Lower", "Conjugate transpose", "Non-unit", m, nrhs, &a[ + a_offset], lda, &b[b_offset], ldb, info); + + if (*info > 0) { + return 0; + } + + scllen = *m; + + } + + } + +/* Undo scaling */ + + if (iascl == 1) { + zlascl_("G", &c__0, &c__0, &anrm, &smlnum, &scllen, nrhs, &b[b_offset] + , ldb, info); + } else if (iascl == 2) { + zlascl_("G", &c__0, &c__0, &anrm, &bignum, &scllen, nrhs, &b[b_offset] + , ldb, info); + } + if (ibscl == 1) { + zlascl_("G", &c__0, &c__0, &smlnum, &bnrm, &scllen, nrhs, &b[b_offset] + , ldb, info); + } else if (ibscl == 2) { + zlascl_("G", &c__0, &c__0, &bignum, &bnrm, &scllen, nrhs, &b[b_offset] + , ldb, info); + } + +L50: + d__1 = (doublereal) wsize; + work[1].r = d__1, work[1].i = 0.; + + return 0; + +/* End of ZGELS */ + +} /* zgels_ */ + diff --git a/lapack-netlib/SRC/zgelsd.c b/lapack-netlib/SRC/zgelsd.c new file mode 100644 index 000000000..42daeb359 --- /dev/null +++ b/lapack-netlib/SRC/zgelsd.c @@ -0,0 +1,1191 @@ +/* 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 ZGELSD computes the minimum-norm solution to a linear least squares problem for GE matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGELSD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, */ +/* WORK, LWORK, RWORK, IWORK, INFO ) */ + +/* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK */ +/* DOUBLE PRECISION RCOND */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION RWORK( * ), S( * ) */ +/* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGELSD computes the minimum-norm solution to a real linear least */ +/* > squares problem: */ +/* > minimize 2-norm(| b - A*x |) */ +/* > using the singular value decomposition (SVD) of A. A is an M-by-N */ +/* > matrix which may be rank-deficient. */ +/* > */ +/* > Several right hand side vectors b and solution vectors x can be */ +/* > handled in a single call; they are stored as the columns of the */ +/* > M-by-NRHS right hand side matrix B and the N-by-NRHS solution */ +/* > matrix X. */ +/* > */ +/* > The problem is solved in three steps: */ +/* > (1) Reduce the coefficient matrix A to bidiagonal form with */ +/* > Householder transformations, reducing the original problem */ +/* > into a "bidiagonal least squares problem" (BLS) */ +/* > (2) Solve the BLS using a divide and conquer approach. */ +/* > (3) Apply back all the Householder transformations to solve */ +/* > the original least squares problem. */ +/* > */ +/* > The effective rank of A is determined by treating as zero those */ +/* > singular values which are less than RCOND times the largest singular */ +/* > value. */ +/* > */ +/* > The divide and conquer algorithm makes very mild assumptions about */ +/* > floating point arithmetic. It will work on machines with a guard */ +/* > digit in add/subtract, or on those binary machines without guard */ +/* > digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ +/* > Cray-2. It could conceivably fail on hexadecimal or decimal machines */ +/* > without guard digits, but we know of none. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, A has been destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > On entry, the M-by-NRHS right hand side matrix B. */ +/* > On exit, B is overwritten by the N-by-NRHS solution matrix X. */ +/* > If m >= n and RANK = n, the residual sum-of-squares for */ +/* > the solution in the i-th column is given by the sum of */ +/* > squares of the modulus of elements n+1:m in that column. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is DOUBLE PRECISION array, dimension (f2cmin(M,N)) */ +/* > The singular values of A in decreasing order. */ +/* > The condition number of A in the 2-norm = S(1)/S(f2cmin(m,n)). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > RCOND is used to determine the effective rank of A. */ +/* > Singular values S(i) <= RCOND*S(1) are treated as zero. */ +/* > If RCOND < 0, machine precision is used instead. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RANK */ +/* > \verbatim */ +/* > RANK is INTEGER */ +/* > The effective rank of A, i.e., the number of singular values */ +/* > which are greater than RCOND*S(1). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK must be at least 1. */ +/* > The exact minimum amount of workspace needed depends on M, */ +/* > N and NRHS. As long as LWORK is at least */ +/* > 2*N + N*NRHS */ +/* > if M is greater than or equal to N or */ +/* > 2*M + M*NRHS */ +/* > if M is less than N, the code will execute correctly. */ +/* > For good performance, LWORK should generally be larger. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the array WORK and the */ +/* > minimum sizes of the arrays RWORK and IWORK, and returns */ +/* > these values as the first entries of the WORK, RWORK and */ +/* > IWORK arrays, and no error message related to LWORK is issued */ +/* > by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK)) */ +/* > LRWORK >= */ +/* > 10*N + 2*N*SMLSIZ + 8*N*NLVL + 3*SMLSIZ*NRHS + */ +/* > MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS ) */ +/* > if M is greater than or equal to N or */ +/* > 10*M + 2*M*SMLSIZ + 8*M*NLVL + 3*SMLSIZ*NRHS + */ +/* > MAX( (SMLSIZ+1)**2, N*(1+NRHS) + 2*NRHS ) */ +/* > if M is less than N, the code will execute correctly. */ +/* > SMLSIZ is returned by ILAENV and is equal to the maximum */ +/* > size of the subproblems at the bottom of the computation */ +/* > tree (usually about 25), and */ +/* > NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 ) */ +/* > On exit, if INFO = 0, RWORK(1) returns the minimum LRWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */ +/* > LIWORK >= f2cmax(1, 3*MINMN*NLVL + 11*MINMN), */ +/* > where MINMN = MIN( M,N ). */ +/* > On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK. */ +/* > \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 for computing the SVD failed to converge; */ +/* > if INFO = i, i off-diagonal elements of an intermediate */ +/* > bidiagonal form did not converge to zero. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup complex16GEsolve */ + +/* > \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 zgelsd_(integer *m, integer *n, integer *nrhs, + doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, + doublereal *s, doublereal *rcond, integer *rank, doublecomplex *work, + integer *lwork, doublereal *rwork, integer *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + doublereal anrm, bnrm; + integer itau, nlvl, iascl, ibscl; + doublereal sfmin; + integer minmn, maxmn, itaup, itauq, mnthr, nwork; + extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); + integer ie, il; + extern doublereal dlamch_(char *); + integer mm; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *), dlaset_(char *, integer *, integer + *, doublereal *, doublereal *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen), zgebrd_(integer *, integer *, + doublecomplex *, integer *, doublereal *, doublereal *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *, + integer *); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, + integer *, doublereal *); + doublereal bignum; + extern /* Subroutine */ int zgelqf_(integer *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *, integer * + ), zlalsd_(char *, integer *, integer *, integer *, doublereal *, + doublereal *, doublecomplex *, integer *, doublereal *, integer *, + doublecomplex *, doublereal *, integer *, integer *), + zlascl_(char *, integer *, integer *, doublereal *, doublereal *, + integer *, integer *, doublecomplex *, integer *, integer *), zgeqrf_(integer *, integer *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, integer *, integer *); + integer ldwork; + extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *), + zlaset_(char *, integer *, integer *, doublecomplex *, + doublecomplex *, doublecomplex *, integer *); + integer liwork, minwrk, maxwrk; + doublereal smlnum; + extern /* Subroutine */ int zunmbr_(char *, char *, char *, integer *, + integer *, integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer * + ); + integer lrwork; + logical lquery; + integer nrwork, smlsiz; + extern /* Subroutine */ int zunmlq_(char *, char *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *), zunmqr_(char *, char *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *); + doublereal eps; + + +/* -- LAPACK driver routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input arguments. */ + + /* 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; + --s; + --work; + --rwork; + --iwork; + + /* Function Body */ + *info = 0; + minmn = f2cmin(*m,*n); + maxmn = f2cmax(*m,*n); + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } else if (*ldb < f2cmax(1,maxmn)) { + *info = -7; + } + +/* Compute workspace. */ +/* (Note: Comments in the code beginning "Workspace:" describe the */ +/* minimal amount of workspace needed at that point in the code, */ +/* as well as the preferred amount for good performance. */ +/* NB refers to the optimal block size for the immediately */ +/* following subroutine, as returned by ILAENV.) */ + + if (*info == 0) { + minwrk = 1; + maxwrk = 1; + liwork = 1; + lrwork = 1; + if (minmn > 0) { + smlsiz = ilaenv_(&c__9, "ZGELSD", " ", &c__0, &c__0, &c__0, &c__0, + (ftnlen)6, (ftnlen)1); + mnthr = ilaenv_(&c__6, "ZGELSD", " ", m, n, nrhs, &c_n1, (ftnlen) + 6, (ftnlen)1); +/* Computing MAX */ + i__1 = (integer) (log((doublereal) minmn / (doublereal) (smlsiz + + 1)) / log(2.)) + 1; + nlvl = f2cmax(i__1,0); + liwork = minmn * 3 * nlvl + minmn * 11; + mm = *m; + if (*m >= *n && *m >= mnthr) { + +/* Path 1a - overdetermined, with many more rows than */ +/* columns. */ + + mm = *n; +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n * ilaenv_(&c__1, "ZGEQRF", " ", m, n, + &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + maxwrk = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *nrhs * ilaenv_(&c__1, "ZUNMQR", "LC", + m, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)2); + maxwrk = f2cmax(i__1,i__2); + } + if (*m >= *n) { + +/* Path 1 - overdetermined or exactly determined. */ + +/* Computing MAX */ +/* Computing 2nd power */ + i__3 = smlsiz + 1; + i__1 = i__3 * i__3, i__2 = *n * (*nrhs + 1) + (*nrhs << 1); + lrwork = *n * 10 + (*n << 1) * smlsiz + (*n << 3) * nlvl + + smlsiz * 3 * *nrhs + f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = (*n << 1) + (mm + *n) * ilaenv_(&c__1, + "ZGEBRD", " ", &mm, n, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + maxwrk = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = (*n << 1) + *nrhs * ilaenv_(&c__1, + "ZUNMBR", "QLC", &mm, nrhs, n, &c_n1, (ftnlen)6, ( + ftnlen)3); + maxwrk = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = (*n << 1) + (*n - 1) * ilaenv_(&c__1, + "ZUNMBR", "PLN", n, nrhs, n, &c_n1, (ftnlen)6, ( + ftnlen)3); + maxwrk = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = (*n << 1) + *n * *nrhs; + maxwrk = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = (*n << 1) + mm, i__2 = (*n << 1) + *n * *nrhs; + minwrk = f2cmax(i__1,i__2); + } + if (*n > *m) { +/* Computing MAX */ +/* Computing 2nd power */ + i__3 = smlsiz + 1; + i__1 = i__3 * i__3, i__2 = *n * (*nrhs + 1) + (*nrhs << 1); + lrwork = *m * 10 + (*m << 1) * smlsiz + (*m << 3) * nlvl + + smlsiz * 3 * *nrhs + f2cmax(i__1,i__2); + if (*n >= mnthr) { + +/* Path 2a - underdetermined, with many more columns */ +/* than rows. */ + + maxwrk = *m + *m * ilaenv_(&c__1, "ZGELQF", " ", m, n, & + c_n1, &c_n1, (ftnlen)6, (ftnlen)1); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m << 1) * + ilaenv_(&c__1, "ZGEBRD", " ", m, m, &c_n1, &c_n1, + (ftnlen)6, (ftnlen)1); + maxwrk = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *nrhs * + ilaenv_(&c__1, "ZUNMBR", "QLC", m, nrhs, m, &c_n1, + (ftnlen)6, (ftnlen)3); + maxwrk = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + (*m - 1) * + ilaenv_(&c__1, "ZUNMLQ", "LC", n, nrhs, m, &c_n1, + (ftnlen)6, (ftnlen)2); + maxwrk = f2cmax(i__1,i__2); + if (*nrhs > 1) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs; + maxwrk = f2cmax(i__1,i__2); + } else { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * *m + (*m << 1); + maxwrk = f2cmax(i__1,i__2); + } +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * *m + (*m << 2) + *m * *nrhs; + maxwrk = f2cmax(i__1,i__2); +/* XXX: Ensure the Path 2a case below is triggered. The workspace */ +/* calculation should use queries for all routines eventually. */ +/* Computing MAX */ +/* Computing MAX */ + i__3 = *m, i__4 = (*m << 1) - 4, i__3 = f2cmax(i__3,i__4), + i__3 = f2cmax(i__3,*nrhs), i__4 = *n - *m * 3; + i__1 = maxwrk, i__2 = (*m << 2) + *m * *m + f2cmax(i__3,i__4) + ; + maxwrk = f2cmax(i__1,i__2); + } else { + +/* Path 2 - underdetermined. */ + + maxwrk = (*m << 1) + (*n + *m) * ilaenv_(&c__1, "ZGEBRD", + " ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); +/* Computing MAX */ + i__1 = maxwrk, i__2 = (*m << 1) + *nrhs * ilaenv_(&c__1, + "ZUNMBR", "QLC", m, nrhs, m, &c_n1, (ftnlen)6, ( + ftnlen)3); + maxwrk = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = (*m << 1) + *m * ilaenv_(&c__1, + "ZUNMBR", "PLN", n, nrhs, m, &c_n1, (ftnlen)6, ( + ftnlen)3); + maxwrk = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = (*m << 1) + *m * *nrhs; + maxwrk = f2cmax(i__1,i__2); + } +/* Computing MAX */ + i__1 = (*m << 1) + *n, i__2 = (*m << 1) + *m * *nrhs; + minwrk = f2cmax(i__1,i__2); + } + } + minwrk = f2cmin(minwrk,maxwrk); + work[1].r = (doublereal) maxwrk, work[1].i = 0.; + iwork[1] = liwork; + rwork[1] = (doublereal) lrwork; + + if (*lwork < minwrk && ! lquery) { + *info = -12; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGELSD", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0) { + *rank = 0; + return 0; + } + +/* Get machine parameters. */ + + eps = dlamch_("P"); + sfmin = dlamch_("S"); + smlnum = sfmin / eps; + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + +/* Scale A if f2cmax entry outside range [SMLNUM,BIGNUM]. */ + + anrm = zlange_("M", m, n, &a[a_offset], lda, &rwork[1]); + iascl = 0; + if (anrm > 0. && anrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, + info); + iascl = 1; + } else if (anrm > bignum) { + +/* Scale matrix norm down to BIGNUM. */ + + zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, + info); + iascl = 2; + } else if (anrm == 0.) { + +/* Matrix all zero. Return zero solution. */ + + i__1 = f2cmax(*m,*n); + zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb); + dlaset_("F", &minmn, &c__1, &c_b80, &c_b80, &s[1], &c__1); + *rank = 0; + goto L10; + } + +/* Scale B if f2cmax entry outside range [SMLNUM,BIGNUM]. */ + + bnrm = zlange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1]); + ibscl = 0; + if (bnrm > 0. && bnrm < smlnum) { + +/* Scale matrix norm up to SMLNUM. */ + + zlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, + info); + ibscl = 1; + } else if (bnrm > bignum) { + +/* Scale matrix norm down to BIGNUM. */ + + zlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, + info); + ibscl = 2; + } + +/* If M < N make sure B(M+1:N,:) = 0 */ + + if (*m < *n) { + i__1 = *n - *m; + zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[*m + 1 + b_dim1], ldb); + } + +/* Overdetermined case. */ + + if (*m >= *n) { + +/* Path 1 - overdetermined or exactly determined. */ + + mm = *m; + if (*m >= mnthr) { + +/* Path 1a - overdetermined, with many more rows than columns */ + + mm = *n; + itau = 1; + nwork = itau + *n; + +/* Compute A=Q*R. */ +/* (RWorkspace: need N) */ +/* (CWorkspace: need N, prefer N*NB) */ + + i__1 = *lwork - nwork + 1; + zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, + info); + +/* Multiply B by transpose(Q). */ +/* (RWorkspace: need N) */ +/* (CWorkspace: need NRHS, prefer NRHS*NB) */ + + i__1 = *lwork - nwork + 1; + zunmqr_("L", "C", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[ + b_offset], ldb, &work[nwork], &i__1, info); + +/* Zero out below R. */ + + if (*n > 1) { + i__1 = *n - 1; + i__2 = *n - 1; + zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &a[a_dim1 + 2], lda); + } + } + + itauq = 1; + itaup = itauq + *n; + nwork = itaup + *n; + ie = 1; + nrwork = ie + *n; + +/* Bidiagonalize R in A. */ +/* (RWorkspace: need N) */ +/* (CWorkspace: need 2*N+MM, prefer 2*N+(MM+N)*NB) */ + + i__1 = *lwork - nwork + 1; + zgebrd_(&mm, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq], & + work[itaup], &work[nwork], &i__1, info); + +/* Multiply B by transpose of left bidiagonalizing vectors of R. */ +/* (CWorkspace: need 2*N+NRHS, prefer 2*N+NRHS*NB) */ + + i__1 = *lwork - nwork + 1; + zunmbr_("Q", "L", "C", &mm, nrhs, n, &a[a_offset], lda, &work[itauq], + &b[b_offset], ldb, &work[nwork], &i__1, info); + +/* Solve the bidiagonal least squares problem. */ + + zlalsd_("U", &smlsiz, n, nrhs, &s[1], &rwork[ie], &b[b_offset], ldb, + rcond, rank, &work[nwork], &rwork[nrwork], &iwork[1], info); + if (*info != 0) { + goto L10; + } + +/* Multiply B by right bidiagonalizing vectors of R. */ + + i__1 = *lwork - nwork + 1; + zunmbr_("P", "L", "N", n, nrhs, n, &a[a_offset], lda, &work[itaup], & + b[b_offset], ldb, &work[nwork], &i__1, info); + + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = *m, i__2 = (*m << 1) - 4, i__1 = f2cmax(i__1,i__2), i__1 = f2cmax( + i__1,*nrhs), i__2 = *n - *m * 3; + if (*n >= mnthr && *lwork >= (*m << 2) + *m * *m + f2cmax(i__1,i__2)) { + +/* Path 2a - underdetermined, with many more columns than rows */ +/* and sufficient workspace for an efficient algorithm. */ + + ldwork = *m; +/* Computing MAX */ +/* Computing MAX */ + i__3 = *m, i__4 = (*m << 1) - 4, i__3 = f2cmax(i__3,i__4), i__3 = + f2cmax(i__3,*nrhs), i__4 = *n - *m * 3; + i__1 = (*m << 2) + *m * *lda + f2cmax(i__3,i__4), i__2 = *m * *lda + + *m + *m * *nrhs; + if (*lwork >= f2cmax(i__1,i__2)) { + ldwork = *lda; + } + itau = 1; + nwork = *m + 1; + +/* Compute A=L*Q. */ +/* (CWorkspace: need 2*M, prefer M+M*NB) */ + + i__1 = *lwork - nwork + 1; + zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[nwork], &i__1, + info); + il = nwork; + +/* Copy L to WORK(IL), zeroing out above its diagonal. */ + + zlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork); + i__1 = *m - 1; + i__2 = *m - 1; + zlaset_("U", &i__1, &i__2, &c_b1, &c_b1, &work[il + ldwork], & + ldwork); + itauq = il + ldwork * *m; + itaup = itauq + *m; + nwork = itaup + *m; + ie = 1; + nrwork = ie + *m; + +/* Bidiagonalize L in WORK(IL). */ +/* (RWorkspace: need M) */ +/* (CWorkspace: need M*M+4*M, prefer M*M+4*M+2*M*NB) */ + + i__1 = *lwork - nwork + 1; + zgebrd_(m, m, &work[il], &ldwork, &s[1], &rwork[ie], &work[itauq], + &work[itaup], &work[nwork], &i__1, info); + +/* Multiply B by transpose of left bidiagonalizing vectors of L. */ +/* (CWorkspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB) */ + + i__1 = *lwork - nwork + 1; + zunmbr_("Q", "L", "C", m, nrhs, m, &work[il], &ldwork, &work[ + itauq], &b[b_offset], ldb, &work[nwork], &i__1, info); + +/* Solve the bidiagonal least squares problem. */ + + zlalsd_("U", &smlsiz, m, nrhs, &s[1], &rwork[ie], &b[b_offset], + ldb, rcond, rank, &work[nwork], &rwork[nrwork], &iwork[1], + info); + if (*info != 0) { + goto L10; + } + +/* Multiply B by right bidiagonalizing vectors of L. */ + + i__1 = *lwork - nwork + 1; + zunmbr_("P", "L", "N", m, nrhs, m, &work[il], &ldwork, &work[ + itaup], &b[b_offset], ldb, &work[nwork], &i__1, info); + +/* Zero out below first M rows of B. */ + + i__1 = *n - *m; + zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[*m + 1 + b_dim1], ldb); + nwork = itau + *m; + +/* Multiply transpose(Q) by B. */ +/* (CWorkspace: need NRHS, prefer NRHS*NB) */ + + i__1 = *lwork - nwork + 1; + zunmlq_("L", "C", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[ + b_offset], ldb, &work[nwork], &i__1, info); + + } else { + +/* Path 2 - remaining underdetermined cases. */ + + itauq = 1; + itaup = itauq + *m; + nwork = itaup + *m; + ie = 1; + nrwork = ie + *m; + +/* Bidiagonalize A. */ +/* (RWorkspace: need M) */ +/* (CWorkspace: need 2*M+N, prefer 2*M+(M+N)*NB) */ + + i__1 = *lwork - nwork + 1; + zgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq], + &work[itaup], &work[nwork], &i__1, info); + +/* Multiply B by transpose of left bidiagonalizing vectors. */ +/* (CWorkspace: need 2*M+NRHS, prefer 2*M+NRHS*NB) */ + + i__1 = *lwork - nwork + 1; + zunmbr_("Q", "L", "C", m, nrhs, n, &a[a_offset], lda, &work[itauq] + , &b[b_offset], ldb, &work[nwork], &i__1, info); + +/* Solve the bidiagonal least squares problem. */ + + zlalsd_("L", &smlsiz, m, nrhs, &s[1], &rwork[ie], &b[b_offset], + ldb, rcond, rank, &work[nwork], &rwork[nrwork], &iwork[1], + info); + if (*info != 0) { + goto L10; + } + +/* Multiply B by right bidiagonalizing vectors of A. */ + + i__1 = *lwork - nwork + 1; + zunmbr_("P", "L", "N", n, nrhs, m, &a[a_offset], lda, &work[itaup] + , &b[b_offset], ldb, &work[nwork], &i__1, info); + + } + } + +/* Undo scaling. */ + + if (iascl == 1) { + zlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, + info); + dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & + minmn, info); + } else if (iascl == 2) { + zlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, + info); + dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & + minmn, info); + } + if (ibscl == 1) { + zlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, + info); + } else if (ibscl == 2) { + zlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, + info); + } + +L10: + work[1].r = (doublereal) maxwrk, work[1].i = 0.; + iwork[1] = liwork; + rwork[1] = (doublereal) lrwork; + return 0; + +/* End of ZGELSD */ + +} /* zgelsd_ */ + diff --git a/lapack-netlib/SRC/zgelss.c b/lapack-netlib/SRC/zgelss.c new file mode 100644 index 000000000..d50cdf6c3 --- /dev/null +++ b/lapack-netlib/SRC/zgelss.c @@ -0,0 +1,1321 @@ +/* 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 ZGELSS solves overdetermined or underdetermined systems for GE matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGELSS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK, */ +/* WORK, LWORK, RWORK, INFO ) */ + +/* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK */ +/* DOUBLE PRECISION RCOND */ +/* DOUBLE PRECISION RWORK( * ), S( * ) */ +/* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGELSS computes the minimum norm solution to a complex linear */ +/* > least squares problem: */ +/* > */ +/* > Minimize 2-norm(| b - A*x |). */ +/* > */ +/* > using the singular value decomposition (SVD) of A. A is an M-by-N */ +/* > matrix which may be rank-deficient. */ +/* > */ +/* > Several right hand side vectors b and solution vectors x can be */ +/* > handled in a single call; they are stored as the columns of the */ +/* > M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix */ +/* > X. */ +/* > */ +/* > The effective rank of A is determined by treating as zero those */ +/* > singular values which are less than RCOND times the largest singular */ +/* > value. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, the first f2cmin(m,n) rows of A are overwritten with */ +/* > its right singular vectors, stored rowwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > On entry, the M-by-NRHS right hand side matrix B. */ +/* > On exit, B is overwritten by the N-by-NRHS solution matrix X. */ +/* > If m >= n and RANK = n, the residual sum-of-squares for */ +/* > the solution in the i-th column is given by the sum of */ +/* > squares of the modulus of elements n+1:m in that column. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is DOUBLE PRECISION array, dimension (f2cmin(M,N)) */ +/* > The singular values of A in decreasing order. */ +/* > The condition number of A in the 2-norm = S(1)/S(f2cmin(m,n)). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > RCOND is used to determine the effective rank of A. */ +/* > Singular values S(i) <= RCOND*S(1) are treated as zero. */ +/* > If RCOND < 0, machine precision is used instead. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RANK */ +/* > \verbatim */ +/* > RANK is INTEGER */ +/* > The effective rank of A, i.e., the number of singular values */ +/* > which are greater than RCOND*S(1). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= 1, and also: */ +/* > LWORK >= 2*f2cmin(M,N) + f2cmax(M,N,NRHS) */ +/* > For good performance, LWORK should generally be larger. */ +/* > */ +/* > 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] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (5*f2cmin(M,N)) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: the algorithm for computing the SVD failed to converge; */ +/* > if INFO = i, i off-diagonal elements of an intermediate */ +/* > bidiagonal form did not converge to zero. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16GEsolve */ + +/* ===================================================================== */ +/* Subroutine */ int zgelss_(integer *m, integer *n, integer *nrhs, + doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, + doublereal *s, doublereal *rcond, integer *rank, doublecomplex *work, + integer *lwork, doublereal *rwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; + doublereal d__1; + + /* Local variables */ + doublereal anrm, bnrm; + integer itau, lwork_zgebrd__, lwork_zgelqf__, i__, lwork_zgeqrf__, + lwork_zungbr__, lwork_zunmbr__, iascl, ibscl, lwork_zunmlq__, + chunk, lwork_zunmqr__; + doublereal sfmin; + integer minmn; + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + integer maxmn, itaup, itauq, mnthr; + extern /* Subroutine */ int zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + integer iwork; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), dlabad_(doublereal *, doublereal *); + integer bl, ie, il; + extern doublereal dlamch_(char *); + integer mm; + extern /* Subroutine */ int dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *), dlaset_(char *, integer *, integer + *, doublereal *, doublereal *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen), zgebrd_(integer *, integer *, + doublecomplex *, integer *, doublereal *, doublereal *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *, + integer *); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, + integer *, doublereal *); + doublereal bignum; + extern /* Subroutine */ int zgelqf_(integer *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *, integer * + ), zlascl_(char *, integer *, integer *, doublereal *, doublereal + *, integer *, integer *, doublecomplex *, integer *, integer *), zgeqrf_(integer *, integer *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, integer *, integer *), zdrscl_( + integer *, doublereal *, doublecomplex *, integer *); + integer ldwork; + extern /* Subroutine */ int zlacpy_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *), + zlaset_(char *, integer *, integer *, doublecomplex *, + doublecomplex *, doublecomplex *, integer *), zbdsqr_( + char *, integer *, integer *, integer *, integer *, doublereal *, + doublereal *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, integer *, doublereal *, integer *); + integer minwrk, maxwrk; + extern /* Subroutine */ int zungbr_(char *, integer *, integer *, integer + *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *); + doublereal smlnum; + integer irwork; + extern /* Subroutine */ int zunmbr_(char *, char *, char *, integer *, + integer *, integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer * + ); + logical lquery; + extern /* Subroutine */ int zunmlq_(char *, char *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *), zunmqr_(char *, char *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *); + doublecomplex dum[1]; + doublereal eps, thr; + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* 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; + --s; + --work; + --rwork; + + /* Function Body */ + *info = 0; + minmn = f2cmin(*m,*n); + maxmn = f2cmax(*m,*n); + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } else if (*ldb < f2cmax(1,maxmn)) { + *info = -7; + } + +/* Compute workspace */ +/* (Note: Comments in the code beginning "Workspace:" describe the */ +/* minimal amount of workspace needed at that point in the code, */ +/* as well as the preferred amount for good performance. */ +/* CWorkspace refers to complex workspace, and RWorkspace refers */ +/* to real workspace. NB refers to the optimal block size for the */ +/* immediately following subroutine, as returned by ILAENV.) */ + + if (*info == 0) { + minwrk = 1; + maxwrk = 1; + if (minmn > 0) { + mm = *m; + mnthr = ilaenv_(&c__6, "ZGELSS", " ", m, n, nrhs, &c_n1, (ftnlen) + 6, (ftnlen)1); + if (*m >= *n && *m >= mnthr) { + +/* Path 1a - overdetermined, with many more rows than */ +/* columns */ + +/* Compute space needed for ZGEQRF */ + zgeqrf_(m, n, &a[a_offset], lda, dum, dum, &c_n1, info); + lwork_zgeqrf__ = (integer) dum[0].r; +/* Compute space needed for ZUNMQR */ + zunmqr_("L", "C", m, nrhs, n, &a[a_offset], lda, dum, &b[ + b_offset], ldb, dum, &c_n1, info); + lwork_zunmqr__ = (integer) dum[0].r; + mm = *n; +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + *n * ilaenv_(&c__1, "ZGEQRF", + " ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + maxwrk = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n + *nrhs * ilaenv_(&c__1, "ZUNMQR", + "LC", m, nrhs, n, &c_n1, (ftnlen)6, (ftnlen)2); + maxwrk = f2cmax(i__1,i__2); + } + if (*m >= *n) { + +/* Path 1 - overdetermined or exactly determined */ + +/* Compute space needed for ZGEBRD */ + zgebrd_(&mm, n, &a[a_offset], lda, &s[1], &s[1], dum, dum, + dum, &c_n1, info); + lwork_zgebrd__ = (integer) dum[0].r; +/* Compute space needed for ZUNMBR */ + zunmbr_("Q", "L", "C", &mm, nrhs, n, &a[a_offset], lda, dum, & + b[b_offset], ldb, dum, &c_n1, info); + lwork_zunmbr__ = (integer) dum[0].r; +/* Compute space needed for ZUNGBR */ + zungbr_("P", n, n, n, &a[a_offset], lda, dum, dum, &c_n1, + info); + lwork_zungbr__ = (integer) dum[0].r; +/* Compute total workspace needed */ +/* Computing MAX */ + i__1 = maxwrk, i__2 = (*n << 1) + lwork_zgebrd__; + maxwrk = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = (*n << 1) + lwork_zunmbr__; + maxwrk = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = (*n << 1) + lwork_zungbr__; + maxwrk = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n * *nrhs; + maxwrk = f2cmax(i__1,i__2); + minwrk = (*n << 1) + f2cmax(*nrhs,*m); + } + if (*n > *m) { + minwrk = (*m << 1) + f2cmax(*nrhs,*n); + if (*n >= mnthr) { + +/* Path 2a - underdetermined, with many more columns */ +/* than rows */ + +/* Compute space needed for ZGELQF */ + zgelqf_(m, n, &a[a_offset], lda, dum, dum, &c_n1, info); + lwork_zgelqf__ = (integer) dum[0].r; +/* Compute space needed for ZGEBRD */ + zgebrd_(m, m, &a[a_offset], lda, &s[1], &s[1], dum, dum, + dum, &c_n1, info); + lwork_zgebrd__ = (integer) dum[0].r; +/* Compute space needed for ZUNMBR */ + zunmbr_("Q", "L", "C", m, nrhs, n, &a[a_offset], lda, dum, + &b[b_offset], ldb, dum, &c_n1, info); + lwork_zunmbr__ = (integer) dum[0].r; +/* Compute space needed for ZUNGBR */ + zungbr_("P", m, m, m, &a[a_offset], lda, dum, dum, &c_n1, + info); + lwork_zungbr__ = (integer) dum[0].r; +/* Compute space needed for ZUNMLQ */ + zunmlq_("L", "C", n, nrhs, m, &a[a_offset], lda, dum, &b[ + b_offset], ldb, dum, &c_n1, info); + lwork_zunmlq__ = (integer) dum[0].r; +/* Compute total workspace needed */ + maxwrk = *m + lwork_zgelqf__; +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * 3 + *m * *m + lwork_zgebrd__; + maxwrk = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * 3 + *m * *m + lwork_zunmbr__; + maxwrk = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * 3 + *m * *m + lwork_zungbr__; + maxwrk = f2cmax(i__1,i__2); + if (*nrhs > 1) { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * *m + *m + *m * *nrhs; + maxwrk = f2cmax(i__1,i__2); + } else { +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m * *m + (*m << 1); + maxwrk = f2cmax(i__1,i__2); + } +/* Computing MAX */ + i__1 = maxwrk, i__2 = *m + lwork_zunmlq__; + maxwrk = f2cmax(i__1,i__2); + } else { + +/* Path 2 - underdetermined */ + +/* Compute space needed for ZGEBRD */ + zgebrd_(m, n, &a[a_offset], lda, &s[1], &s[1], dum, dum, + dum, &c_n1, info); + lwork_zgebrd__ = (integer) dum[0].r; +/* Compute space needed for ZUNMBR */ + zunmbr_("Q", "L", "C", m, nrhs, m, &a[a_offset], lda, dum, + &b[b_offset], ldb, dum, &c_n1, info); + lwork_zunmbr__ = (integer) dum[0].r; +/* Compute space needed for ZUNGBR */ + zungbr_("P", m, n, m, &a[a_offset], lda, dum, dum, &c_n1, + info); + lwork_zungbr__ = (integer) dum[0].r; + maxwrk = (*m << 1) + lwork_zgebrd__; +/* Computing MAX */ + i__1 = maxwrk, i__2 = (*m << 1) + lwork_zunmbr__; + maxwrk = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = (*m << 1) + lwork_zungbr__; + maxwrk = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = maxwrk, i__2 = *n * *nrhs; + maxwrk = f2cmax(i__1,i__2); + } + } + maxwrk = f2cmax(minwrk,maxwrk); + } + work[1].r = (doublereal) maxwrk, work[1].i = 0.; + + if (*lwork < minwrk && ! lquery) { + *info = -12; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGELSS", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + *rank = 0; + return 0; + } + +/* Get machine parameters */ + + eps = dlamch_("P"); + sfmin = dlamch_("S"); + smlnum = sfmin / eps; + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + +/* Scale A if f2cmax element outside range [SMLNUM,BIGNUM] */ + + anrm = zlange_("M", m, n, &a[a_offset], lda, &rwork[1]); + iascl = 0; + if (anrm > 0. && anrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, + info); + iascl = 1; + } else if (anrm > bignum) { + +/* Scale matrix norm down to BIGNUM */ + + zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, + info); + iascl = 2; + } else if (anrm == 0.) { + +/* Matrix all zero. Return zero solution. */ + + i__1 = f2cmax(*m,*n); + zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb); + dlaset_("F", &minmn, &c__1, &c_b59, &c_b59, &s[1], &minmn); + *rank = 0; + goto L70; + } + +/* Scale B if f2cmax element outside range [SMLNUM,BIGNUM] */ + + bnrm = zlange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1]); + ibscl = 0; + if (bnrm > 0. && bnrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + zlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, + info); + ibscl = 1; + } else if (bnrm > bignum) { + +/* Scale matrix norm down to BIGNUM */ + + zlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, + info); + ibscl = 2; + } + +/* Overdetermined case */ + + if (*m >= *n) { + +/* Path 1 - overdetermined or exactly determined */ + + mm = *m; + if (*m >= mnthr) { + +/* Path 1a - overdetermined, with many more rows than columns */ + + mm = *n; + itau = 1; + iwork = itau + *n; + +/* Compute A=Q*R */ +/* (CWorkspace: need 2*N, prefer N+N*NB) */ +/* (RWorkspace: none) */ + + i__1 = *lwork - iwork + 1; + zgeqrf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__1, + info); + +/* Multiply B by transpose(Q) */ +/* (CWorkspace: need N+NRHS, prefer N+NRHS*NB) */ +/* (RWorkspace: none) */ + + i__1 = *lwork - iwork + 1; + zunmqr_("L", "C", m, nrhs, n, &a[a_offset], lda, &work[itau], &b[ + b_offset], ldb, &work[iwork], &i__1, info); + +/* Zero out below R */ + + if (*n > 1) { + i__1 = *n - 1; + i__2 = *n - 1; + zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &a[a_dim1 + 2], lda); + } + } + + ie = 1; + itauq = 1; + itaup = itauq + *n; + iwork = itaup + *n; + +/* Bidiagonalize R in A */ +/* (CWorkspace: need 2*N+MM, prefer 2*N+(MM+N)*NB) */ +/* (RWorkspace: need N) */ + + i__1 = *lwork - iwork + 1; + zgebrd_(&mm, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq], & + work[itaup], &work[iwork], &i__1, info); + +/* Multiply B by transpose of left bidiagonalizing vectors of R */ +/* (CWorkspace: need 2*N+NRHS, prefer 2*N+NRHS*NB) */ +/* (RWorkspace: none) */ + + i__1 = *lwork - iwork + 1; + zunmbr_("Q", "L", "C", &mm, nrhs, n, &a[a_offset], lda, &work[itauq], + &b[b_offset], ldb, &work[iwork], &i__1, info); + +/* Generate right bidiagonalizing vectors of R in A */ +/* (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB) */ +/* (RWorkspace: none) */ + + i__1 = *lwork - iwork + 1; + zungbr_("P", n, n, n, &a[a_offset], lda, &work[itaup], &work[iwork], & + i__1, info); + irwork = ie + *n; + +/* Perform bidiagonal QR iteration */ +/* multiply B by transpose of left singular vectors */ +/* compute right singular vectors in A */ +/* (CWorkspace: none) */ +/* (RWorkspace: need BDSPAC) */ + + zbdsqr_("U", n, n, &c__0, nrhs, &s[1], &rwork[ie], &a[a_offset], lda, + dum, &c__1, &b[b_offset], ldb, &rwork[irwork], info); + if (*info != 0) { + goto L70; + } + +/* Multiply B by reciprocals of singular values */ + +/* Computing MAX */ + d__1 = *rcond * s[1]; + thr = f2cmax(d__1,sfmin); + if (*rcond < 0.) { +/* Computing MAX */ + d__1 = eps * s[1]; + thr = f2cmax(d__1,sfmin); + } + *rank = 0; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (s[i__] > thr) { + zdrscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); + ++(*rank); + } else { + zlaset_("F", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1], ldb); + } +/* L10: */ + } + +/* Multiply B by right singular vectors */ +/* (CWorkspace: need N, prefer N*NRHS) */ +/* (RWorkspace: none) */ + + if (*lwork >= *ldb * *nrhs && *nrhs > 1) { + zgemm_("C", "N", n, nrhs, n, &c_b2, &a[a_offset], lda, &b[ + b_offset], ldb, &c_b1, &work[1], ldb); + zlacpy_("G", n, nrhs, &work[1], ldb, &b[b_offset], ldb) + ; + } else if (*nrhs > 1) { + chunk = *lwork / *n; + i__1 = *nrhs; + i__2 = chunk; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = *nrhs - i__ + 1; + bl = f2cmin(i__3,chunk); + zgemm_("C", "N", n, &bl, n, &c_b2, &a[a_offset], lda, &b[i__ * + b_dim1 + 1], ldb, &c_b1, &work[1], n); + zlacpy_("G", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1], ldb); +/* L20: */ + } + } else { + zgemv_("C", n, n, &c_b2, &a[a_offset], lda, &b[b_offset], &c__1, & + c_b1, &work[1], &c__1); + zcopy_(n, &work[1], &c__1, &b[b_offset], &c__1); + } + + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__2 = f2cmax(*m,*nrhs), i__1 = *n - (*m << 1); + if (*n >= mnthr && *lwork >= *m * 3 + *m * *m + f2cmax(i__2,i__1)) { + +/* Underdetermined case, M much less than N */ + +/* Path 2a - underdetermined, with many more columns than rows */ +/* and sufficient workspace for an efficient algorithm */ + + ldwork = *m; +/* Computing MAX */ + i__2 = f2cmax(*m,*nrhs), i__1 = *n - (*m << 1); + if (*lwork >= *m * 3 + *m * *lda + f2cmax(i__2,i__1)) { + ldwork = *lda; + } + itau = 1; + iwork = *m + 1; + +/* Compute A=L*Q */ +/* (CWorkspace: need 2*M, prefer M+M*NB) */ +/* (RWorkspace: none) */ + + i__2 = *lwork - iwork + 1; + zgelqf_(m, n, &a[a_offset], lda, &work[itau], &work[iwork], &i__2, + info); + il = iwork; + +/* Copy L to WORK(IL), zeroing out above it */ + + zlacpy_("L", m, m, &a[a_offset], lda, &work[il], &ldwork); + i__2 = *m - 1; + i__1 = *m - 1; + zlaset_("U", &i__2, &i__1, &c_b1, &c_b1, &work[il + ldwork], & + ldwork); + ie = 1; + itauq = il + ldwork * *m; + itaup = itauq + *m; + iwork = itaup + *m; + +/* Bidiagonalize L in WORK(IL) */ +/* (CWorkspace: need M*M+4*M, prefer M*M+3*M+2*M*NB) */ +/* (RWorkspace: need M) */ + + i__2 = *lwork - iwork + 1; + zgebrd_(m, m, &work[il], &ldwork, &s[1], &rwork[ie], &work[itauq], + &work[itaup], &work[iwork], &i__2, info); + +/* Multiply B by transpose of left bidiagonalizing vectors of L */ +/* (CWorkspace: need M*M+3*M+NRHS, prefer M*M+3*M+NRHS*NB) */ +/* (RWorkspace: none) */ + + i__2 = *lwork - iwork + 1; + zunmbr_("Q", "L", "C", m, nrhs, m, &work[il], &ldwork, &work[ + itauq], &b[b_offset], ldb, &work[iwork], &i__2, info); + +/* Generate right bidiagonalizing vectors of R in WORK(IL) */ +/* (CWorkspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB) */ +/* (RWorkspace: none) */ + + i__2 = *lwork - iwork + 1; + zungbr_("P", m, m, m, &work[il], &ldwork, &work[itaup], &work[ + iwork], &i__2, info); + irwork = ie + *m; + +/* Perform bidiagonal QR iteration, computing right singular */ +/* vectors of L in WORK(IL) and multiplying B by transpose of */ +/* left singular vectors */ +/* (CWorkspace: need M*M) */ +/* (RWorkspace: need BDSPAC) */ + + zbdsqr_("U", m, m, &c__0, nrhs, &s[1], &rwork[ie], &work[il], & + ldwork, &a[a_offset], lda, &b[b_offset], ldb, &rwork[ + irwork], info); + if (*info != 0) { + goto L70; + } + +/* Multiply B by reciprocals of singular values */ + +/* Computing MAX */ + d__1 = *rcond * s[1]; + thr = f2cmax(d__1,sfmin); + if (*rcond < 0.) { +/* Computing MAX */ + d__1 = eps * s[1]; + thr = f2cmax(d__1,sfmin); + } + *rank = 0; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + if (s[i__] > thr) { + zdrscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); + ++(*rank); + } else { + zlaset_("F", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1], + ldb); + } +/* L30: */ + } + iwork = il + *m * ldwork; + +/* Multiply B by right singular vectors of L in WORK(IL) */ +/* (CWorkspace: need M*M+2*M, prefer M*M+M+M*NRHS) */ +/* (RWorkspace: none) */ + + if (*lwork >= *ldb * *nrhs + iwork - 1 && *nrhs > 1) { + zgemm_("C", "N", m, nrhs, m, &c_b2, &work[il], &ldwork, &b[ + b_offset], ldb, &c_b1, &work[iwork], ldb); + zlacpy_("G", m, nrhs, &work[iwork], ldb, &b[b_offset], ldb); + } else if (*nrhs > 1) { + chunk = (*lwork - iwork + 1) / *m; + i__2 = *nrhs; + i__1 = chunk; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += + i__1) { +/* Computing MIN */ + i__3 = *nrhs - i__ + 1; + bl = f2cmin(i__3,chunk); + zgemm_("C", "N", m, &bl, m, &c_b2, &work[il], &ldwork, &b[ + i__ * b_dim1 + 1], ldb, &c_b1, &work[iwork], m); + zlacpy_("G", m, &bl, &work[iwork], m, &b[i__ * b_dim1 + 1] + , ldb); +/* L40: */ + } + } else { + zgemv_("C", m, m, &c_b2, &work[il], &ldwork, &b[b_dim1 + 1], & + c__1, &c_b1, &work[iwork], &c__1); + zcopy_(m, &work[iwork], &c__1, &b[b_dim1 + 1], &c__1); + } + +/* Zero out below first M rows of B */ + + i__1 = *n - *m; + zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[*m + 1 + b_dim1], ldb); + iwork = itau + *m; + +/* Multiply transpose(Q) by B */ +/* (CWorkspace: need M+NRHS, prefer M+NHRS*NB) */ +/* (RWorkspace: none) */ + + i__1 = *lwork - iwork + 1; + zunmlq_("L", "C", n, nrhs, m, &a[a_offset], lda, &work[itau], &b[ + b_offset], ldb, &work[iwork], &i__1, info); + + } else { + +/* Path 2 - remaining underdetermined cases */ + + ie = 1; + itauq = 1; + itaup = itauq + *m; + iwork = itaup + *m; + +/* Bidiagonalize A */ +/* (CWorkspace: need 3*M, prefer 2*M+(M+N)*NB) */ +/* (RWorkspace: need N) */ + + i__1 = *lwork - iwork + 1; + zgebrd_(m, n, &a[a_offset], lda, &s[1], &rwork[ie], &work[itauq], + &work[itaup], &work[iwork], &i__1, info); + +/* Multiply B by transpose of left bidiagonalizing vectors */ +/* (CWorkspace: need 2*M+NRHS, prefer 2*M+NRHS*NB) */ +/* (RWorkspace: none) */ + + i__1 = *lwork - iwork + 1; + zunmbr_("Q", "L", "C", m, nrhs, n, &a[a_offset], lda, &work[itauq] + , &b[b_offset], ldb, &work[iwork], &i__1, info); + +/* Generate right bidiagonalizing vectors in A */ +/* (CWorkspace: need 3*M, prefer 2*M+M*NB) */ +/* (RWorkspace: none) */ + + i__1 = *lwork - iwork + 1; + zungbr_("P", m, n, m, &a[a_offset], lda, &work[itaup], &work[ + iwork], &i__1, info); + irwork = ie + *m; + +/* Perform bidiagonal QR iteration, */ +/* computing right singular vectors of A in A and */ +/* multiplying B by transpose of left singular vectors */ +/* (CWorkspace: none) */ +/* (RWorkspace: need BDSPAC) */ + + zbdsqr_("L", m, n, &c__0, nrhs, &s[1], &rwork[ie], &a[a_offset], + lda, dum, &c__1, &b[b_offset], ldb, &rwork[irwork], info); + if (*info != 0) { + goto L70; + } + +/* Multiply B by reciprocals of singular values */ + +/* Computing MAX */ + d__1 = *rcond * s[1]; + thr = f2cmax(d__1,sfmin); + if (*rcond < 0.) { +/* Computing MAX */ + d__1 = eps * s[1]; + thr = f2cmax(d__1,sfmin); + } + *rank = 0; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (s[i__] > thr) { + zdrscl_(nrhs, &s[i__], &b[i__ + b_dim1], ldb); + ++(*rank); + } else { + zlaset_("F", &c__1, nrhs, &c_b1, &c_b1, &b[i__ + b_dim1], + ldb); + } +/* L50: */ + } + +/* Multiply B by right singular vectors of A */ +/* (CWorkspace: need N, prefer N*NRHS) */ +/* (RWorkspace: none) */ + + if (*lwork >= *ldb * *nrhs && *nrhs > 1) { + zgemm_("C", "N", n, nrhs, m, &c_b2, &a[a_offset], lda, &b[ + b_offset], ldb, &c_b1, &work[1], ldb); + zlacpy_("G", n, nrhs, &work[1], ldb, &b[b_offset], ldb); + } else if (*nrhs > 1) { + chunk = *lwork / *n; + i__1 = *nrhs; + i__2 = chunk; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += + i__2) { +/* Computing MIN */ + i__3 = *nrhs - i__ + 1; + bl = f2cmin(i__3,chunk); + zgemm_("C", "N", n, &bl, m, &c_b2, &a[a_offset], lda, &b[ + i__ * b_dim1 + 1], ldb, &c_b1, &work[1], n); + zlacpy_("F", n, &bl, &work[1], n, &b[i__ * b_dim1 + 1], + ldb); +/* L60: */ + } + } else { + zgemv_("C", m, n, &c_b2, &a[a_offset], lda, &b[b_offset], & + c__1, &c_b1, &work[1], &c__1); + zcopy_(n, &work[1], &c__1, &b[b_offset], &c__1); + } + } + } + +/* Undo scaling */ + + if (iascl == 1) { + zlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, + info); + dlascl_("G", &c__0, &c__0, &smlnum, &anrm, &minmn, &c__1, &s[1], & + minmn, info); + } else if (iascl == 2) { + zlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, + info); + dlascl_("G", &c__0, &c__0, &bignum, &anrm, &minmn, &c__1, &s[1], & + minmn, info); + } + if (ibscl == 1) { + zlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, + info); + } else if (ibscl == 2) { + zlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, + info); + } +L70: + work[1].r = (doublereal) maxwrk, work[1].i = 0.; + return 0; + +/* End of ZGELSS */ + +} /* zgelss_ */ + diff --git a/lapack-netlib/SRC/zgelsy.c b/lapack-netlib/SRC/zgelsy.c new file mode 100644 index 000000000..fdab809ae --- /dev/null +++ b/lapack-netlib/SRC/zgelsy.c @@ -0,0 +1,965 @@ +/* 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 ZGELSY solves overdetermined or underdetermined systems for GE matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGELSY + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, */ +/* WORK, LWORK, RWORK, INFO ) */ + +/* INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK */ +/* DOUBLE PRECISION RCOND */ +/* INTEGER JPVT( * ) */ +/* DOUBLE PRECISION RWORK( * ) */ +/* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGELSY computes the minimum-norm solution to a complex linear least */ +/* > squares problem: */ +/* > minimize || A * X - B || */ +/* > using a complete orthogonal factorization of A. A is an M-by-N */ +/* > matrix which may be rank-deficient. */ +/* > */ +/* > Several right hand side vectors b and solution vectors x can be */ +/* > handled in a single call; they are stored as the columns of the */ +/* > M-by-NRHS right hand side matrix B and the N-by-NRHS solution */ +/* > matrix X. */ +/* > */ +/* > The routine first computes a QR factorization with column pivoting: */ +/* > A * P = Q * [ R11 R12 ] */ +/* > [ 0 R22 ] */ +/* > with R11 defined as the largest leading submatrix whose estimated */ +/* > condition number is less than 1/RCOND. The order of R11, RANK, */ +/* > is the effective rank of A. */ +/* > */ +/* > Then, R22 is considered to be negligible, and R12 is annihilated */ +/* > by unitary transformations from the right, arriving at the */ +/* > complete orthogonal factorization: */ +/* > A * P = Q * [ T11 0 ] * Z */ +/* > [ 0 0 ] */ +/* > The minimum-norm solution is then */ +/* > X = P * Z**H [ inv(T11)*Q1**H*B ] */ +/* > [ 0 ] */ +/* > where Q1 consists of the first RANK columns of Q. */ +/* > */ +/* > This routine is basically identical to the original xGELSX except */ +/* > three differences: */ +/* > o The permutation of matrix B (the right hand side) is faster and */ +/* > more simple. */ +/* > o The call to the subroutine xGEQPF has been substituted by the */ +/* > the call to the subroutine xGEQP3. This subroutine is a Blas-3 */ +/* > version of the QR factorization with column pivoting. */ +/* > o Matrix B (the right hand side) is updated with Blas-3. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of */ +/* > columns of matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, A has been overwritten by details of its */ +/* > complete orthogonal factorization. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > On entry, the M-by-NRHS right hand side matrix B. */ +/* > On exit, the N-by-NRHS solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] JPVT */ +/* > \verbatim */ +/* > JPVT is INTEGER array, dimension (N) */ +/* > On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */ +/* > to the front of AP, otherwise column i 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[in] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > RCOND is used to determine the effective rank of A, which */ +/* > is defined as the order of the largest leading triangular */ +/* > submatrix R11 in the QR factorization with pivoting of A, */ +/* > whose estimated condition number < 1/RCOND. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RANK */ +/* > \verbatim */ +/* > RANK is INTEGER */ +/* > The effective rank of A, i.e., the order of the submatrix */ +/* > R11. This is the same as the order of the submatrix T11 */ +/* > in the complete orthogonal factorization of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > The unblocked strategy requires that: */ +/* > LWORK >= MN + MAX( 2*MN, N+1, MN+NRHS ) */ +/* > where MN = f2cmin(M,N). */ +/* > The block algorithm requires that: */ +/* > LWORK >= MN + MAX( 2*MN, NB*(N+1), MN+MN*NB, MN+NB*NRHS ) */ +/* > where NB is an upper bound on the blocksize returned */ +/* > by ILAENV for the routines ZGEQP3, ZTZRZF, CTZRQF, ZUNMQR, */ +/* > and ZUNMRZ. */ +/* > */ +/* > 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] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GEsolve */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA \n */ +/* > E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain \n */ +/* > G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain \n */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgelsy_(integer *m, integer *n, integer *nrhs, + doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, + integer *jpvt, doublereal *rcond, integer *rank, doublecomplex *work, + integer *lwork, doublereal *rwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4; + doublereal d__1, d__2; + doublecomplex z__1; + + /* Local variables */ + doublereal anrm, bnrm, smin, smax; + integer i__, j, iascl, ibscl, ismin, ismax; + doublecomplex c1, c2; + doublereal wsize; + doublecomplex s1, s2; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), ztrsm_(char *, char *, char *, char * + , integer *, integer *, doublecomplex *, doublecomplex *, integer + *, doublecomplex *, integer *), + zlaic1_(integer *, integer *, doublecomplex *, doublereal *, + doublecomplex *, doublecomplex *, doublereal *, doublecomplex *, + doublecomplex *), dlabad_(doublereal *, doublereal *), zgeqp3_( + integer *, integer *, doublecomplex *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublereal *, + integer *); + integer nb; + extern doublereal dlamch_(char *); + integer mn; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern doublereal zlange_(char *, integer *, integer *, doublecomplex *, + integer *, doublereal *); + doublereal bignum; + extern /* Subroutine */ int zlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublecomplex *, + integer *, integer *); + integer nb1, nb2, nb3, nb4; + extern /* Subroutine */ int zlaset_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *); + doublereal sminpr, smaxpr, smlnum; + integer lwkopt; + logical lquery; + extern /* Subroutine */ int zunmqr_(char *, char *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *), zunmrz_(char *, char *, integer *, integer *, + integer *, integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer * + ), ztzrzf_(integer *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *, integer *) + ; + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --jpvt; + --work; + --rwork; + + /* Function Body */ + mn = f2cmin(*m,*n); + ismin = mn + 1; + ismax = (mn << 1) + 1; + +/* Test the input arguments. */ + + *info = 0; + nb1 = ilaenv_(&c__1, "ZGEQRF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb2 = ilaenv_(&c__1, "ZGERQF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb3 = ilaenv_(&c__1, "ZUNMQR", " ", m, n, nrhs, &c_n1, (ftnlen)6, (ftnlen) + 1); + nb4 = ilaenv_(&c__1, "ZUNMRQ", " ", m, n, nrhs, &c_n1, (ftnlen)6, (ftnlen) + 1); +/* Computing MAX */ + i__1 = f2cmax(nb1,nb2), i__1 = f2cmax(i__1,nb3); + nb = f2cmax(i__1,nb4); +/* Computing MAX */ + i__1 = 1, i__2 = mn + (*n << 1) + nb * (*n + 1), i__1 = f2cmax(i__1,i__2), + i__2 = (mn << 1) + nb * *nrhs; + lwkopt = f2cmax(i__1,i__2); + z__1.r = (doublereal) lwkopt, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = f2cmax(1,*m); + if (*ldb < f2cmax(i__1,*n)) { + *info = -7; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = mn << 1, i__2 = *n + 1, i__1 = f2cmax(i__1,i__2), i__2 = mn + + *nrhs; + if (*lwork < mn + f2cmax(i__1,i__2) && ! lquery) { + *info = -12; + } + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGELSY", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + +/* Computing MIN */ + i__1 = f2cmin(*m,*n); + if (f2cmin(i__1,*nrhs) == 0) { + *rank = 0; + return 0; + } + +/* Get machine parameters */ + + smlnum = dlamch_("S") / dlamch_("P"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + +/* Scale A, B if f2cmax entries outside range [SMLNUM,BIGNUM] */ + + anrm = zlange_("M", m, n, &a[a_offset], lda, &rwork[1]); + iascl = 0; + if (anrm > 0. && anrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + zlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, + info); + iascl = 1; + } else if (anrm > bignum) { + +/* Scale matrix norm down to BIGNUM */ + + zlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, + info); + iascl = 2; + } else if (anrm == 0.) { + +/* Matrix all zero. Return zero solution. */ + + i__1 = f2cmax(*m,*n); + zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb); + *rank = 0; + goto L70; + } + + bnrm = zlange_("M", m, nrhs, &b[b_offset], ldb, &rwork[1]); + ibscl = 0; + if (bnrm > 0. && bnrm < smlnum) { + +/* Scale matrix norm up to SMLNUM */ + + zlascl_("G", &c__0, &c__0, &bnrm, &smlnum, m, nrhs, &b[b_offset], ldb, + info); + ibscl = 1; + } else if (bnrm > bignum) { + +/* Scale matrix norm down to BIGNUM */ + + zlascl_("G", &c__0, &c__0, &bnrm, &bignum, m, nrhs, &b[b_offset], ldb, + info); + ibscl = 2; + } + +/* Compute QR factorization with column pivoting of A: */ +/* A * P = Q * R */ + + i__1 = *lwork - mn; + zgeqp3_(m, n, &a[a_offset], lda, &jpvt[1], &work[1], &work[mn + 1], &i__1, + &rwork[1], info); + i__1 = mn + 1; + wsize = mn + work[i__1].r; + +/* complex workspace: MN+NB*(N+1). real workspace 2*N. */ +/* Details of Householder rotations stored in WORK(1:MN). */ + +/* Determine RANK using incremental condition estimation */ + + i__1 = ismin; + work[i__1].r = 1., work[i__1].i = 0.; + i__1 = ismax; + work[i__1].r = 1., work[i__1].i = 0.; + smax = z_abs(&a[a_dim1 + 1]); + smin = smax; + if (z_abs(&a[a_dim1 + 1]) == 0.) { + *rank = 0; + i__1 = f2cmax(*m,*n); + zlaset_("F", &i__1, nrhs, &c_b1, &c_b1, &b[b_offset], ldb); + goto L70; + } else { + *rank = 1; + } + +L10: + if (*rank < mn) { + i__ = *rank + 1; + zlaic1_(&c__2, rank, &work[ismin], &smin, &a[i__ * a_dim1 + 1], &a[ + i__ + i__ * a_dim1], &sminpr, &s1, &c1); + zlaic1_(&c__1, rank, &work[ismax], &smax, &a[i__ * a_dim1 + 1], &a[ + i__ + i__ * a_dim1], &smaxpr, &s2, &c2); + + if (smaxpr * *rcond <= sminpr) { + i__1 = *rank; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ismin + i__ - 1; + i__3 = ismin + i__ - 1; + z__1.r = s1.r * work[i__3].r - s1.i * work[i__3].i, z__1.i = + s1.r * work[i__3].i + s1.i * work[i__3].r; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + i__2 = ismax + i__ - 1; + i__3 = ismax + i__ - 1; + z__1.r = s2.r * work[i__3].r - s2.i * work[i__3].i, z__1.i = + s2.r * work[i__3].i + s2.i * work[i__3].r; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; +/* L20: */ + } + i__1 = ismin + *rank; + work[i__1].r = c1.r, work[i__1].i = c1.i; + i__1 = ismax + *rank; + work[i__1].r = c2.r, work[i__1].i = c2.i; + smin = sminpr; + smax = smaxpr; + ++(*rank); + goto L10; + } + } + +/* complex workspace: 3*MN. */ + +/* Logically partition R = [ R11 R12 ] */ +/* [ 0 R22 ] */ +/* where R11 = R(1:RANK,1:RANK) */ + +/* [R11,R12] = [ T11, 0 ] * Y */ + + if (*rank < *n) { + i__1 = *lwork - (mn << 1); + ztzrzf_(rank, n, &a[a_offset], lda, &work[mn + 1], &work[(mn << 1) + + 1], &i__1, info); + } + +/* complex workspace: 2*MN. */ +/* Details of Householder rotations stored in WORK(MN+1:2*MN) */ + +/* B(1:M,1:NRHS) := Q**H * B(1:M,1:NRHS) */ + + i__1 = *lwork - (mn << 1); + zunmqr_("Left", "Conjugate transpose", m, nrhs, &mn, &a[a_offset], lda, & + work[1], &b[b_offset], ldb, &work[(mn << 1) + 1], &i__1, info); +/* Computing MAX */ + i__1 = (mn << 1) + 1; + d__1 = wsize, d__2 = (mn << 1) + work[i__1].r; + wsize = f2cmax(d__1,d__2); + +/* complex workspace: 2*MN+NB*NRHS. */ + +/* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS) */ + + ztrsm_("Left", "Upper", "No transpose", "Non-unit", rank, nrhs, &c_b2, &a[ + a_offset], lda, &b[b_offset], ldb); + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = *rank + 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + b[i__3].r = 0., b[i__3].i = 0.; +/* L30: */ + } +/* L40: */ + } + +/* B(1:N,1:NRHS) := Y**H * B(1:N,1:NRHS) */ + + if (*rank < *n) { + i__1 = *n - *rank; + i__2 = *lwork - (mn << 1); + zunmrz_("Left", "Conjugate transpose", n, nrhs, rank, &i__1, &a[ + a_offset], lda, &work[mn + 1], &b[b_offset], ldb, &work[(mn << + 1) + 1], &i__2, info); + } + +/* complex workspace: 2*MN+NRHS. */ + +/* B(1:N,1:NRHS) := P * B(1:N,1:NRHS) */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = jpvt[i__]; + i__4 = i__ + j * b_dim1; + work[i__3].r = b[i__4].r, work[i__3].i = b[i__4].i; +/* L50: */ + } + zcopy_(n, &work[1], &c__1, &b[j * b_dim1 + 1], &c__1); +/* L60: */ + } + +/* complex workspace: N. */ + +/* Undo scaling */ + + if (iascl == 1) { + zlascl_("G", &c__0, &c__0, &anrm, &smlnum, n, nrhs, &b[b_offset], ldb, + info); + zlascl_("U", &c__0, &c__0, &smlnum, &anrm, rank, rank, &a[a_offset], + lda, info); + } else if (iascl == 2) { + zlascl_("G", &c__0, &c__0, &anrm, &bignum, n, nrhs, &b[b_offset], ldb, + info); + zlascl_("U", &c__0, &c__0, &bignum, &anrm, rank, rank, &a[a_offset], + lda, info); + } + if (ibscl == 1) { + zlascl_("G", &c__0, &c__0, &smlnum, &bnrm, n, nrhs, &b[b_offset], ldb, + info); + } else if (ibscl == 2) { + zlascl_("G", &c__0, &c__0, &bignum, &bnrm, n, nrhs, &b[b_offset], ldb, + info); + } + +L70: + z__1.r = (doublereal) lwkopt, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + + return 0; + +/* End of ZGELSY */ + +} /* zgelsy_ */ + diff --git a/lapack-netlib/SRC/zgemlq.c b/lapack-netlib/SRC/zgemlq.c new file mode 100644 index 000000000..63a9ac750 --- /dev/null +++ b/lapack-netlib/SRC/zgemlq.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 ZGEMLQ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEMLQ( SIDE, TRANS, M, N, K, A, LDA, T, */ +/* $ TSIZE, C, LDC, WORK, LWORK, INFO ) */ + + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, LDA, M, N, K, LDT, TSIZE, LWORK, LDC */ +/* COMPLEX*16 A( LDA, * ), T( * ), C(LDC, * ), WORK( * ) */ +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEMLQ 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 complex unitary matrix defined as the product */ +/* > of blocked elementary reflectors computed by short wide */ +/* > LQ factorization (ZGELQ) */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**T from the Left; */ +/* > = 'R': apply Q or Q**T from the Right. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': No transpose, apply Q; */ +/* > = 'T': Transpose, apply Q**T. */ +/* > \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. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > If SIDE = 'L', M >= K >= 0; */ +/* > if SIDE = 'R', N >= K >= 0. */ +/* > */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension */ +/* > (LDA,M) if SIDE = 'L', */ +/* > (LDA,N) if SIDE = 'R' */ +/* > Part of the data structure to represent Q as returned by ZGELQ. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,K). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is COMPLEX*16 array, dimension (MAX(5,TSIZE)). */ +/* > Part of the data structure to represent Q as returned by ZGELQ. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TSIZE */ +/* > \verbatim */ +/* > TSIZE is INTEGER */ +/* > The dimension of the array T. TSIZE >= 5. */ +/* > \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**T*C or C*Q**T 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 LWORK = -1, then a workspace query is assumed. The routine */ +/* > only calculates the size of the WORK array, returns this */ +/* > value as WORK(1), and no error message related to WORK */ +/* > 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 */ +/* > */ +/* > These details are particular for this LAPACK implementation. Users should not */ +/* > take them for granted. These details may change in the future, and are not likely */ +/* > true for another LAPACK implementation. These details are relevant if one wants */ +/* > to try to understand the code. They are not part of the interface. */ +/* > */ +/* > In this version, */ +/* > */ +/* > T(2): row block size (MB) */ +/* > T(3): column block size (NB) */ +/* > T(6:TSIZE): data structure needed for Q, computed by */ +/* > ZLASWLQ or ZGELQT */ +/* > */ +/* > Depending on the matrix dimensions M and N, and row and column */ +/* > block sizes MB and NB returned by ILAENV, ZGELQ will use either */ +/* > ZLASWLQ (if the matrix is wide-and-short) or ZGELQT to compute */ +/* > the LQ factorization. */ +/* > This version of ZGEMLQ will use either ZLAMSWLQ or ZGEMLQT to */ +/* > multiply matrix Q by another matrix. */ +/* > Further Details in ZLAMSWLQ or ZGEMLQT. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgemlq_(char *side, char *trans, integer *m, integer *n, + integer *k, doublecomplex *a, integer *lda, doublecomplex *t, integer + *tsize, doublecomplex *c__, integer *ldc, doublecomplex *work, + integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, i__1; + + /* Local variables */ + logical left, tran; + extern /* Subroutine */ int zlamswlq_(char *, char *, integer *, integer * + , integer *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, integer *); + extern logical lsame_(char *, char *); + logical right; + integer mb, nb, mn, lw, nblcks; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical notran, lquery; + extern /* Subroutine */ int zgemlqt_(char *, char *, integer *, integer *, + integer *, integer *, doublecomplex *, integer *, doublecomplex * + , integer *, doublecomplex *, integer *, doublecomplex *, integer + *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --t; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + lquery = *lwork == -1; + notran = lsame_(trans, "N"); + tran = lsame_(trans, "C"); + left = lsame_(side, "L"); + right = lsame_(side, "R"); + + mb = (integer) t[2].r; + nb = (integer) t[3].r; + if (left) { + lw = *n * mb; + mn = *m; + } else { + lw = *m * mb; + mn = *n; + } + + if (nb > *k && mn > *k) { + if ((mn - *k) % (nb - *k) == 0) { + nblcks = (mn - *k) / (nb - *k); + } else { + nblcks = (mn - *k) / (nb - *k) + 1; + } + } else { + nblcks = 1; + } + + *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 || *k > mn) { + *info = -5; + } else if (*lda < f2cmax(1,*k)) { + *info = -7; + } else if (*tsize < 5) { + *info = -9; + } else if (*ldc < f2cmax(1,*m)) { + *info = -11; + } else if (*lwork < f2cmax(1,lw) && ! lquery) { + *info = -13; + } + + if (*info == 0) { + work[1].r = (doublereal) lw, work[1].i = 0.; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEMLQ", &i__1, (ftnlen)6); + 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 (left && *m <= *k || right && *n <= *k || nb <= *k || nb >= f2cmax(i__1,* + k)) { + zgemlqt_(side, trans, m, n, k, &mb, &a[a_offset], lda, &t[6], &mb, & + c__[c_offset], ldc, &work[1], info); + } else { + zlamswlq_(side, trans, m, n, k, &mb, &nb, &a[a_offset], lda, &t[6], & + mb, &c__[c_offset], ldc, &work[1], lwork, info); + } + + work[1].r = (doublereal) lw, work[1].i = 0.; + + return 0; + +/* End of ZGEMLQ */ + +} /* zgemlq_ */ + diff --git a/lapack-netlib/SRC/zgemlqt.c b/lapack-netlib/SRC/zgemlqt.c new file mode 100644 index 000000000..8c2a70899 --- /dev/null +++ b/lapack-netlib/SRC/zgemlqt.c @@ -0,0 +1,706 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#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 ZGEMLQT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DGEMLQT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEMLQT( SIDE, TRANS, M, N, K, MB, V, LDV, T, LDT, */ +/* C, LDC, WORK, INFO ) */ + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, K, LDV, LDC, M, N, MB, LDT */ +/* DOUBLE PRECISION V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEMLQT 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 complex orthogonal matrix defined as the product of K */ +/* > elementary reflectors: */ +/* > */ +/* > Q = H(1) H(2) . . . H(K) = I - V T V**H */ +/* > */ +/* > generated using the compact WY representation as returned by ZGELQT. */ +/* > */ +/* > Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'. */ +/* > \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': 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 >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > If SIDE = 'L', M >= K >= 0; */ +/* > if SIDE = 'R', N >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MB */ +/* > \verbatim */ +/* > MB is INTEGER */ +/* > The block size used for the storage of T. K >= MB >= 1. */ +/* > This must be the same value of MB used to generate T */ +/* > in DGELQT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is COMPLEX*16 array, dimension */ +/* > (LDV,M) if SIDE = 'L', */ +/* > (LDV,N) if SIDE = 'R' */ +/* > The i-th row must contain the vector which defines the */ +/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* > DGELQT in the first K rows of its array argument A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. LDV >= f2cmax(1,K). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is COMPLEX*16 array, dimension (LDT,K) */ +/* > The upper triangular factors of the block reflectors */ +/* > as returned by DGELQT, stored as a MB-by-K matrix. */ +/* > \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, Q**H C, 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 */ +/* > WORK is COMPLEX*16 array. The dimension of */ +/* > WORK is N*MB if SIDE = 'L', or M*MB if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup doubleGEcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zgemlqt_(char *side, char *trans, integer *m, integer *n, + integer *k, integer *mb, doublecomplex *v, integer *ldv, + doublecomplex *t, integer *ldt, doublecomplex *c__, integer *ldc, + doublecomplex *work, integer *info) +{ + /* System generated locals */ + integer v_dim1, v_offset, c_dim1, c_offset, t_dim1, t_offset, i__1, i__2, + i__3, i__4; + + /* Local variables */ + logical left, tran; + integer i__; + extern logical lsame_(char *, char *); + logical right; + integer ib, kf; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zlarfb_( + char *, char *, char *, char *, integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + logical notran; + integer ldwork; + + +/* -- 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 */ + 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; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + right = lsame_(side, "R"); + tran = lsame_(trans, "C"); + notran = lsame_(trans, "N"); + + if (left) { + ldwork = f2cmax(1,*n); + } else if (right) { + ldwork = f2cmax(1,*m); + } + 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 (*mb < 1 || *mb > *k && *k > 0) { + *info = -6; + } else if (*ldv < f2cmax(1,*k)) { + *info = -8; + } else if (*ldt < *mb) { + *info = -10; + } else if (*ldc < f2cmax(1,*m)) { + *info = -12; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEMLQT", &i__1, (ftnlen)7); + return 0; + } + + + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + + if (left && notran) { + + i__1 = *k; + i__2 = *mb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = *mb, i__4 = *k - i__ + 1; + ib = f2cmin(i__3,i__4); + i__3 = *m - i__ + 1; + zlarfb_("L", "C", "F", "R", &i__3, n, &ib, &v[i__ + i__ * v_dim1], + ldv, &t[i__ * t_dim1 + 1], ldt, &c__[i__ + c_dim1], ldc, + &work[1], &ldwork); + } + + } else if (right && tran) { + + i__2 = *k; + i__1 = *mb; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { +/* Computing MIN */ + i__3 = *mb, i__4 = *k - i__ + 1; + ib = f2cmin(i__3,i__4); + i__3 = *n - i__ + 1; + zlarfb_("R", "N", "F", "R", m, &i__3, &ib, &v[i__ + i__ * v_dim1], + ldv, &t[i__ * t_dim1 + 1], ldt, &c__[i__ * c_dim1 + 1], + ldc, &work[1], &ldwork); + } + + } else if (left && tran) { + + kf = (*k - 1) / *mb * *mb + 1; + i__1 = -(*mb); + for (i__ = kf; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { +/* Computing MIN */ + i__2 = *mb, i__3 = *k - i__ + 1; + ib = f2cmin(i__2,i__3); + i__2 = *m - i__ + 1; + zlarfb_("L", "N", "F", "R", &i__2, n, &ib, &v[i__ + i__ * v_dim1], + ldv, &t[i__ * t_dim1 + 1], ldt, &c__[i__ + c_dim1], ldc, + &work[1], &ldwork); + } + + } else if (right && notran) { + + kf = (*k - 1) / *mb * *mb + 1; + i__1 = -(*mb); + for (i__ = kf; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { +/* Computing MIN */ + i__2 = *mb, i__3 = *k - i__ + 1; + ib = f2cmin(i__2,i__3); + i__2 = *n - i__ + 1; + zlarfb_("R", "C", "F", "R", m, &i__2, &ib, &v[i__ + i__ * v_dim1], + ldv, &t[i__ * t_dim1 + 1], ldt, &c__[i__ * c_dim1 + 1], + ldc, &work[1], &ldwork); + } + + } + + return 0; + +/* End of ZGEMLQT */ + +} /* zgemlqt_ */ + diff --git a/lapack-netlib/SRC/zgemqr.c b/lapack-netlib/SRC/zgemqr.c new file mode 100644 index 000000000..b221742e2 --- /dev/null +++ b/lapack-netlib/SRC/zgemqr.c @@ -0,0 +1,686 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#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 ZGEMQR */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEMQR( SIDE, TRANS, M, N, K, A, LDA, T, */ +/* $ TSIZE, C, LDC, WORK, LWORK, INFO ) */ + + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, LDA, M, N, K, LDT, TSIZE, LWORK, LDC */ +/* COMPLEX*16 A( LDA, * ), T( * ), C( LDC, * ), WORK( * ) */ + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEMQR overwrites the general real M-by-N matrix C with */ +/* > */ +/* > SIDE = 'L' SIDE = 'R' */ +/* > TRANS = 'N': Q * C C * Q */ +/* > TRANS = 'T': Q**H * C C * Q**H */ +/* > */ +/* > where Q is a complex unitary matrix defined as the product */ +/* > of blocked elementary reflectors computed by tall skinny */ +/* > QR factorization (ZGEQR) */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**T from the Left; */ +/* > = 'R': apply Q or Q**T from the Right. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': No transpose, apply Q; */ +/* > = 'T': Transpose, apply Q**T. */ +/* > \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. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > If SIDE = 'L', M >= K >= 0; */ +/* > if SIDE = 'R', N >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,K) */ +/* > Part of the data structure to represent Q as returned by ZGEQR. */ +/* > \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 (MAX(5,TSIZE)). */ +/* > Part of the data structure to represent Q as returned by ZGEQR. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TSIZE */ +/* > \verbatim */ +/* > TSIZE is INTEGER */ +/* > The dimension of the array T. TSIZE >= 5. */ +/* > \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**T*C or C*Q**T 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 LWORK = -1, then a workspace query is assumed. The routine */ +/* > only calculates the size of the WORK array, returns this */ +/* > value as WORK(1), and no error message related to WORK */ +/* > 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 */ +/* > */ +/* > These details are particular for this LAPACK implementation. Users should not */ +/* > take them for granted. These details may change in the future, and are not likely */ +/* > true for another LAPACK implementation. These details are relevant if one wants */ +/* > to try to understand the code. They are not part of the interface. */ +/* > */ +/* > In this version, */ +/* > */ +/* > T(2): row block size (MB) */ +/* > T(3): column block size (NB) */ +/* > T(6:TSIZE): data structure needed for Q, computed by */ +/* > ZLATSQR or ZGEQRT */ +/* > */ +/* > Depending on the matrix dimensions M and N, and row and column */ +/* > block sizes MB and NB returned by ILAENV, ZGEQR will use either */ +/* > ZLATSQR (if the matrix is tall-and-skinny) or ZGEQRT to compute */ +/* > the QR factorization. */ +/* > This version of ZGEMQR will use either ZLAMTSQR or ZGEMQRT to */ +/* > multiply matrix Q by another matrix. */ +/* > Further Details in ZLAMTSQR or ZGEMQRT. */ +/* > */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgemqr_(char *side, char *trans, integer *m, integer *n, + integer *k, doublecomplex *a, integer *lda, doublecomplex *t, integer + *tsize, doublecomplex *c__, integer *ldc, doublecomplex *work, + integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, c_dim1, c_offset, i__1; + + /* Local variables */ + logical left, tran; + extern /* Subroutine */ int zlamtsqr_(char *, char *, integer *, integer * + , integer *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, integer *); + extern logical lsame_(char *, char *); + logical right; + integer mb, nb, mn, lw, nblcks; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical notran, lquery; + extern /* Subroutine */ int zgemqrt_(char *, char *, integer *, integer *, + integer *, integer *, doublecomplex *, integer *, doublecomplex * + , integer *, doublecomplex *, integer *, doublecomplex *, integer + *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --t; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + lquery = *lwork == -1; + notran = lsame_(trans, "N"); + tran = lsame_(trans, "C"); + left = lsame_(side, "L"); + right = lsame_(side, "R"); + + mb = (integer) t[2].r; + nb = (integer) t[3].r; + if (left) { + lw = *n * nb; + mn = *m; + } else { + lw = mb * nb; + mn = *n; + } + + if (mb > *k && mn > *k) { + if ((mn - *k) % (mb - *k) == 0) { + nblcks = (mn - *k) / (mb - *k); + } else { + nblcks = (mn - *k) / (mb - *k) + 1; + } + } else { + nblcks = 1; + } + + *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 || *k > mn) { + *info = -5; + } else if (*lda < f2cmax(1,mn)) { + *info = -7; + } else if (*tsize < 5) { + *info = -9; + } else if (*ldc < f2cmax(1,*m)) { + *info = -11; + } else if (*lwork < f2cmax(1,lw) && ! lquery) { + *info = -13; + } + + if (*info == 0) { + work[1].r = (doublereal) lw, work[1].i = 0.; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEMQR", &i__1, (ftnlen)6); + 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 (left && *m <= *k || right && *n <= *k || mb <= *k || mb >= f2cmax(i__1,* + k)) { + zgemqrt_(side, trans, m, n, k, &nb, &a[a_offset], lda, &t[6], &nb, & + c__[c_offset], ldc, &work[1], info); + } else { + zlamtsqr_(side, trans, m, n, k, &mb, &nb, &a[a_offset], lda, &t[6], & + nb, &c__[c_offset], ldc, &work[1], lwork, info); + } + + work[1].r = (doublereal) lw, work[1].i = 0.; + + return 0; + +/* End of ZGEMQR */ + +} /* zgemqr_ */ + diff --git a/lapack-netlib/SRC/zgemqrt.c b/lapack-netlib/SRC/zgemqrt.c new file mode 100644 index 000000000..8866e6e97 --- /dev/null +++ b/lapack-netlib/SRC/zgemqrt.c @@ -0,0 +1,708 @@ +/* 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 ZGEMQRT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEMQRT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEMQRT( SIDE, TRANS, M, N, K, NB, V, LDV, T, LDT, */ +/* C, LDC, WORK, INFO ) */ + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, K, LDV, LDC, M, N, NB, LDT */ +/* COMPLEX*16 V( LDV, * ), C( LDC, * ), T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEMQRT 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 complex orthogonal matrix defined as the product of K */ +/* > elementary reflectors: */ +/* > */ +/* > Q = H(1) H(2) . . . H(K) = I - V T V**H */ +/* > */ +/* > generated using the compact WY representation as returned by ZGEQRT. */ +/* > */ +/* > Q is of order M if SIDE = 'L' and of order N if SIDE = 'R'. */ +/* > \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': 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 >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > If SIDE = 'L', M >= K >= 0; */ +/* > if SIDE = 'R', N >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The block size used for the storage of T. K >= NB >= 1. */ +/* > This must be the same value of NB used to generate T */ +/* > in CGEQRT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is COMPLEX*16 array, dimension (LDV,K) */ +/* > The i-th column must contain the vector which defines the */ +/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* > CGEQRT in the first K columns of its array argument A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. */ +/* > 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 (LDT,K) */ +/* > The upper triangular factors of the block reflectors */ +/* > as returned by CGEQRT, stored as a NB-by-N matrix. */ +/* > \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, Q**H C, 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 */ +/* > WORK is COMPLEX*16 array. The dimension of WORK is */ +/* > N*NB if SIDE = 'L', or M*NB if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GEcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zgemqrt_(char *side, char *trans, integer *m, integer *n, + integer *k, integer *nb, doublecomplex *v, integer *ldv, + doublecomplex *t, integer *ldt, doublecomplex *c__, integer *ldc, + doublecomplex *work, integer *info) +{ + /* System generated locals */ + integer v_dim1, v_offset, c_dim1, c_offset, t_dim1, t_offset, i__1, i__2, + i__3, i__4; + + /* Local variables */ + logical left, tran; + integer i__, q; + extern logical lsame_(char *, char *); + logical right; + integer ib, kf; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zlarfb_( + char *, char *, char *, char *, integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + logical notran; + integer ldwork; + + +/* -- 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_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; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + right = lsame_(side, "R"); + tran = lsame_(trans, "C"); + notran = lsame_(trans, "N"); + + if (left) { + ldwork = f2cmax(1,*n); + q = *m; + } else if (right) { + ldwork = f2cmax(1,*m); + q = *n; + } + 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 || *k > q) { + *info = -5; + } else if (*nb < 1 || *nb > *k && *k > 0) { + *info = -6; + } else if (*ldv < f2cmax(1,q)) { + *info = -8; + } else if (*ldt < *nb) { + *info = -10; + } else if (*ldc < f2cmax(1,*m)) { + *info = -12; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEMQRT", &i__1, (ftnlen)7); + return 0; + } + + + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + + if (left && tran) { + + i__1 = *k; + i__2 = *nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = *nb, i__4 = *k - i__ + 1; + ib = f2cmin(i__3,i__4); + i__3 = *m - i__ + 1; + zlarfb_("L", "C", "F", "C", &i__3, n, &ib, &v[i__ + i__ * v_dim1], + ldv, &t[i__ * t_dim1 + 1], ldt, &c__[i__ + c_dim1], ldc, + &work[1], &ldwork); + } + + } else if (right && notran) { + + i__2 = *k; + i__1 = *nb; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { +/* Computing MIN */ + i__3 = *nb, i__4 = *k - i__ + 1; + ib = f2cmin(i__3,i__4); + i__3 = *n - i__ + 1; + zlarfb_("R", "N", "F", "C", m, &i__3, &ib, &v[i__ + i__ * v_dim1], + ldv, &t[i__ * t_dim1 + 1], ldt, &c__[i__ * c_dim1 + 1], + ldc, &work[1], &ldwork); + } + + } else if (left && notran) { + + kf = (*k - 1) / *nb * *nb + 1; + i__1 = -(*nb); + for (i__ = kf; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { +/* Computing MIN */ + i__2 = *nb, i__3 = *k - i__ + 1; + ib = f2cmin(i__2,i__3); + i__2 = *m - i__ + 1; + zlarfb_("L", "N", "F", "C", &i__2, n, &ib, &v[i__ + i__ * v_dim1], + ldv, &t[i__ * t_dim1 + 1], ldt, &c__[i__ + c_dim1], ldc, + &work[1], &ldwork); + } + + } else if (right && tran) { + + kf = (*k - 1) / *nb * *nb + 1; + i__1 = -(*nb); + for (i__ = kf; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { +/* Computing MIN */ + i__2 = *nb, i__3 = *k - i__ + 1; + ib = f2cmin(i__2,i__3); + i__2 = *n - i__ + 1; + zlarfb_("R", "C", "F", "C", m, &i__2, &ib, &v[i__ + i__ * v_dim1], + ldv, &t[i__ * t_dim1 + 1], ldt, &c__[i__ * c_dim1 + 1], + ldc, &work[1], &ldwork); + } + + } + + return 0; + +/* End of ZGEMQRT */ + +} /* zgemqrt_ */ + diff --git a/lapack-netlib/SRC/zgeql2.c b/lapack-netlib/SRC/zgeql2.c new file mode 100644 index 000000000..5039e28ec --- /dev/null +++ b/lapack-netlib/SRC/zgeql2.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 ZGEQL2 computes the QL factorization of a general rectangular matrix using an unblocked algorit +hm. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEQL2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEQL2( M, N, A, LDA, TAU, WORK, INFO ) */ + +/* INTEGER INFO, LDA, M, N */ +/* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEQL2 computes a QL factorization of a complex m by n matrix A: */ +/* > A = Q * L. */ +/* > \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, if m >= n, the lower triangle of the subarray */ +/* > A(m-n+1:m,1:n) contains the n by n lower triangular matrix L; */ +/* > if m <= n, the elements on and below the (n-m)-th */ +/* > superdiagonal contain the m by n lower trapezoidal matrix L; */ +/* > the remaining elements, with the array TAU, represent the */ +/* > unitary matrix Q as a product of elementary reflectors */ +/* > (see Further Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 array, dimension (f2cmin(M,N)) */ +/* > The scalar factors of the elementary reflectors (see Further */ +/* > Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix Q is represented as a product of elementary reflectors */ +/* > */ +/* > Q = H(k) . . . H(2) H(1), where k = f2cmin(m,n). */ +/* > */ +/* > 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(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in */ +/* > A(1:m-k+i-1,n-k+i), and tau in TAU(i). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgeql2_(integer *m, integer *n, doublecomplex *a, + integer *lda, doublecomplex *tau, doublecomplex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublecomplex z__1; + + /* Local variables */ + integer i__, k; + doublecomplex alpha; + extern /* Subroutine */ int zlarf_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *), xerbla_(char *, integer *, ftnlen), zlarfg_(integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEQL2", &i__1, (ftnlen)6); + return 0; + } + + k = f2cmin(*m,*n); + + for (i__ = k; i__ >= 1; --i__) { + +/* Generate elementary reflector H(i) to annihilate */ +/* A(1:m-k+i-1,n-k+i) */ + + i__1 = *m - k + i__ + (*n - k + i__) * a_dim1; + alpha.r = a[i__1].r, alpha.i = a[i__1].i; + i__1 = *m - k + i__; + zlarfg_(&i__1, &alpha, &a[(*n - k + i__) * a_dim1 + 1], &c__1, &tau[ + i__]); + +/* Apply H(i)**H to A(1:m-k+i,1:n-k+i-1) from the left */ + + i__1 = *m - k + i__ + (*n - k + i__) * a_dim1; + a[i__1].r = 1., a[i__1].i = 0.; + i__1 = *m - k + i__; + i__2 = *n - k + i__ - 1; + d_cnjg(&z__1, &tau[i__]); + zlarf_("Left", &i__1, &i__2, &a[(*n - k + i__) * a_dim1 + 1], &c__1, & + z__1, &a[a_offset], lda, &work[1]); + i__1 = *m - k + i__ + (*n - k + i__) * a_dim1; + a[i__1].r = alpha.r, a[i__1].i = alpha.i; +/* L10: */ + } + return 0; + +/* End of ZGEQL2 */ + +} /* zgeql2_ */ + diff --git a/lapack-netlib/SRC/zgeqlf.c b/lapack-netlib/SRC/zgeqlf.c new file mode 100644 index 000000000..0124a6861 --- /dev/null +++ b/lapack-netlib/SRC/zgeqlf.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 ZGEQLF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEQLF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) */ + +/* INTEGER INFO, LDA, LWORK, M, N */ +/* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEQLF computes a QL factorization of a complex M-by-N matrix A: */ +/* > A = Q * L. */ +/* > \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, */ +/* > if m >= n, the lower triangle of the subarray */ +/* > A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L; */ +/* > if m <= n, the elements on and below the (n-m)-th */ +/* > superdiagonal contain the M-by-N lower trapezoidal matrix L; */ +/* > the remaining elements, with the array TAU, represent the */ +/* > unitary matrix Q as a product of elementary reflectors */ +/* > (see Further Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 array, dimension (f2cmin(M,N)) */ +/* > The scalar factors of the elementary reflectors (see Further */ +/* > Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,N). */ +/* > For optimum performance LWORK >= N*NB, where NB is */ +/* > the optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix Q is represented as a product of elementary reflectors */ +/* > */ +/* > Q = H(k) . . . H(2) H(1), where k = f2cmin(m,n). */ +/* > */ +/* > 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(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in */ +/* > A(1:m-k+i-1,n-k+i), and tau in TAU(i). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgeqlf_(integer *m, integer *n, doublecomplex *a, + integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, k, nbmin, iinfo; + extern /* Subroutine */ int zgeql2_(integer *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + integer ib, nb, ki, kk, mu, nu, nx; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *, + integer *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + integer ldwork; + extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + integer lwkopt; + logical lquery; + integer iws; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + + if (*info == 0) { + k = f2cmin(*m,*n); + if (k == 0) { + lwkopt = 1; + } else { + nb = ilaenv_(&c__1, "ZGEQLF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); + lwkopt = *n * nb; + } + work[1].r = (doublereal) lwkopt, work[1].i = 0.; + + if (*lwork < f2cmax(1,*n) && ! lquery) { + *info = -7; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEQLF", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (k == 0) { + return 0; + } + + nbmin = 2; + nx = 1; + iws = *n; + if (nb > 1 && nb < k) { + +/* Determine when to cross over from blocked to unblocked code. */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "ZGEQLF", " ", m, n, &c_n1, &c_n1, ( + ftnlen)6, (ftnlen)1); + nx = f2cmax(i__1,i__2); + if (nx < k) { + +/* Determine if workspace is large enough for blocked code. */ + + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: reduce NB and */ +/* determine the minimum value of NB. */ + + nb = *lwork / ldwork; +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "ZGEQLF", " ", m, n, &c_n1, & + c_n1, (ftnlen)6, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + } + } + } + + if (nb >= nbmin && nb < k && nx < k) { + +/* Use blocked code initially. */ +/* The last kk columns are handled by the block method. */ + + ki = (k - nx - 1) / nb * nb; +/* Computing MIN */ + i__1 = k, i__2 = ki + nb; + kk = f2cmin(i__1,i__2); + + i__1 = k - kk + 1; + i__2 = -nb; + for (i__ = k - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ + += i__2) { +/* Computing MIN */ + i__3 = k - i__ + 1; + ib = f2cmin(i__3,nb); + +/* Compute the QL factorization of the current block */ +/* A(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1) */ + + i__3 = *m - k + i__ + ib - 1; + zgeql2_(&i__3, &ib, &a[(*n - k + i__) * a_dim1 + 1], lda, &tau[ + i__], &work[1], &iinfo); + if (*n - k + i__ > 1) { + +/* Form the triangular factor of the block reflector */ +/* H = H(i+ib-1) . . . H(i+1) H(i) */ + + i__3 = *m - k + i__ + ib - 1; + zlarft_("Backward", "Columnwise", &i__3, &ib, &a[(*n - k + + i__) * a_dim1 + 1], lda, &tau[i__], &work[1], &ldwork); + +/* Apply H**H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left */ + + i__3 = *m - k + i__ + ib - 1; + i__4 = *n - k + i__ - 1; + zlarfb_("Left", "Conjugate transpose", "Backward", "Columnwi" + "se", &i__3, &i__4, &ib, &a[(*n - k + i__) * a_dim1 + + 1], lda, &work[1], &ldwork, &a[a_offset], lda, &work[ + ib + 1], &ldwork); + } +/* L10: */ + } + mu = *m - k + i__ + nb - 1; + nu = *n - k + i__ + nb - 1; + } else { + mu = *m; + nu = *n; + } + +/* Use unblocked code to factor the last or only block */ + + if (mu > 0 && nu > 0) { + zgeql2_(&mu, &nu, &a[a_offset], lda, &tau[1], &work[1], &iinfo); + } + + work[1].r = (doublereal) iws, work[1].i = 0.; + return 0; + +/* End of ZGEQLF */ + +} /* zgeqlf_ */ + diff --git a/lapack-netlib/SRC/zgeqp3.c b/lapack-netlib/SRC/zgeqp3.c new file mode 100644 index 000000000..8db17e343 --- /dev/null +++ b/lapack-netlib/SRC/zgeqp3.c @@ -0,0 +1,806 @@ +/* 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 ZGEQP3 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEQP3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, RWORK, */ +/* INFO ) */ + +/* INTEGER INFO, LDA, LWORK, M, N */ +/* INTEGER JPVT( * ) */ +/* DOUBLE PRECISION RWORK( * ) */ +/* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEQP3 computes a QR factorization with column pivoting of a */ +/* > matrix A: A*P = Q*R using Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, the upper triangle of the array contains the */ +/* > f2cmin(M,N)-by-N upper trapezoidal matrix R; the elements below */ +/* > the diagonal, together with the array TAU, represent the */ +/* > unitary matrix Q as a product of f2cmin(M,N) elementary */ +/* > reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] JPVT */ +/* > \verbatim */ +/* > JPVT is INTEGER array, dimension (N) */ +/* > On entry, if JPVT(J).ne.0, the J-th column of A is permuted */ +/* > to the front of A*P (a leading column); if JPVT(J)=0, */ +/* > the J-th column of A is a free column. */ +/* > On exit, if JPVT(J)=K, then the J-th column of A*P was the */ +/* > the K-th column of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 array, dimension (f2cmin(M,N)) */ +/* > The scalar factors of the elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO=0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= N+1. */ +/* > For optimal performance LWORK >= ( N+1 )*NB, where NB */ +/* > is the optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix Q is represented as a product of elementary reflectors */ +/* > */ +/* > Q = H(1) H(2) . . . H(k), where k = f2cmin(m,n). */ +/* > */ +/* > Each H(i) has the form */ +/* > */ +/* > H(i) = I - tau * v * v**H */ +/* > */ +/* > where tau is a complex scalar, and v is a real/complex vector */ +/* > with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in */ +/* > A(i+1:m,i), and tau in TAU(i). */ +/* > \endverbatim */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */ +/* > X. Sun, Computer Science Dept., Duke University, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgeqp3_(integer *m, integer *n, doublecomplex *a, + integer *lda, integer *jpvt, doublecomplex *tau, doublecomplex *work, + integer *lwork, doublereal *rwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublecomplex z__1; + + /* Local variables */ + integer nfxd, j, nbmin, minmn, minws; + extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zlaqp2_(integer *, integer *, + integer *, doublecomplex *, integer *, integer *, doublecomplex *, + doublereal *, doublereal *, doublecomplex *); + integer jb; + extern doublereal dznrm2_(integer *, doublecomplex *, integer *); + integer na, nb, sm, sn, nx; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int zgeqrf_(integer *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *, integer * + ); + integer topbmn, sminmn; + extern /* Subroutine */ int zlaqps_(integer *, integer *, integer *, + integer *, integer *, doublecomplex *, integer *, integer *, + doublecomplex *, doublereal *, doublereal *, doublecomplex *, + doublecomplex *, integer *); + integer lwkopt; + logical lquery; + extern /* Subroutine */ int zunmqr_(char *, char *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *); + integer fjb, iws; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test input arguments */ +/* ==================== */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --jpvt; + --tau; + --work; + --rwork; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + + if (*info == 0) { + minmn = f2cmin(*m,*n); + if (minmn == 0) { + iws = 1; + lwkopt = 1; + } else { + iws = *n + 1; + nb = ilaenv_(&c__1, "ZGEQRF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); + lwkopt = (*n + 1) * nb; + } + z__1.r = (doublereal) lwkopt, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + + if (*lwork < iws && ! lquery) { + *info = -8; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEQP3", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Move initial columns up front. */ + + nfxd = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (jpvt[j] != 0) { + if (j != nfxd) { + zswap_(m, &a[j * a_dim1 + 1], &c__1, &a[nfxd * a_dim1 + 1], & + c__1); + jpvt[j] = jpvt[nfxd]; + jpvt[nfxd] = j; + } else { + jpvt[j] = j; + } + ++nfxd; + } else { + jpvt[j] = j; + } +/* L10: */ + } + --nfxd; + +/* Factorize fixed columns */ +/* ======================= */ + +/* Compute the QR factorization of fixed columns and update */ +/* remaining columns. */ + + if (nfxd > 0) { + na = f2cmin(*m,nfxd); +/* CC CALL ZGEQR2( M, NA, A, LDA, TAU, WORK, INFO ) */ + zgeqrf_(m, &na, &a[a_offset], lda, &tau[1], &work[1], lwork, info); +/* Computing MAX */ + i__1 = iws, i__2 = (integer) work[1].r; + iws = f2cmax(i__1,i__2); + if (na < *n) { +/* CC CALL ZUNM2R( 'Left', 'Conjugate Transpose', M, N-NA, */ +/* CC $ NA, A, LDA, TAU, A( 1, NA+1 ), LDA, WORK, */ +/* CC $ INFO ) */ + i__1 = *n - na; + zunmqr_("Left", "Conjugate Transpose", m, &i__1, &na, &a[a_offset] + , lda, &tau[1], &a[(na + 1) * a_dim1 + 1], lda, &work[1], + lwork, info); +/* Computing MAX */ + i__1 = iws, i__2 = (integer) work[1].r; + iws = f2cmax(i__1,i__2); + } + } + +/* Factorize free columns */ +/* ====================== */ + + if (nfxd < minmn) { + + sm = *m - nfxd; + sn = *n - nfxd; + sminmn = minmn - nfxd; + +/* Determine the block size. */ + + nb = ilaenv_(&c__1, "ZGEQRF", " ", &sm, &sn, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); + nbmin = 2; + nx = 0; + + if (nb > 1 && nb < sminmn) { + +/* Determine when to cross over from blocked to unblocked code. */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "ZGEQRF", " ", &sm, &sn, &c_n1, & + c_n1, (ftnlen)6, (ftnlen)1); + nx = f2cmax(i__1,i__2); + + + if (nx < sminmn) { + +/* Determine if workspace is large enough for blocked code. */ + + minws = (sn + 1) * nb; + iws = f2cmax(iws,minws); + if (*lwork < minws) { + +/* Not enough workspace to use optimal NB: Reduce NB and */ +/* determine the minimum value of NB. */ + + nb = *lwork / (sn + 1); +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "ZGEQRF", " ", &sm, &sn, & + c_n1, &c_n1, (ftnlen)6, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + + + } + } + } + +/* Initialize partial column norms. The first N elements of work */ +/* store the exact column norms. */ + + i__1 = *n; + for (j = nfxd + 1; j <= i__1; ++j) { + rwork[j] = dznrm2_(&sm, &a[nfxd + 1 + j * a_dim1], &c__1); + rwork[*n + j] = rwork[j]; +/* L20: */ + } + + if (nb >= nbmin && nb < sminmn && nx < sminmn) { + +/* Use blocked code initially. */ + + j = nfxd + 1; + +/* Compute factorization: while loop. */ + + + topbmn = minmn - nx; +L30: + if (j <= topbmn) { +/* Computing MIN */ + i__1 = nb, i__2 = topbmn - j + 1; + jb = f2cmin(i__1,i__2); + +/* Factorize JB columns among columns J:N. */ + + i__1 = *n - j + 1; + i__2 = j - 1; + i__3 = *n - j + 1; + zlaqps_(m, &i__1, &i__2, &jb, &fjb, &a[j * a_dim1 + 1], lda, & + jpvt[j], &tau[j], &rwork[j], &rwork[*n + j], &work[1], + &work[jb + 1], &i__3); + + j += fjb; + goto L30; + } + } else { + j = nfxd + 1; + } + +/* Use unblocked code to factor the last or only block. */ + + + if (j <= minmn) { + i__1 = *n - j + 1; + i__2 = j - 1; + zlaqp2_(m, &i__1, &i__2, &a[j * a_dim1 + 1], lda, &jpvt[j], &tau[ + j], &rwork[j], &rwork[*n + j], &work[1]); + } + + } + + z__1.r = (doublereal) lwkopt, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + return 0; + +/* End of ZGEQP3 */ + +} /* zgeqp3_ */ + diff --git a/lapack-netlib/SRC/zgeqr.c b/lapack-netlib/SRC/zgeqr.c new file mode 100644 index 000000000..efadd0237 --- /dev/null +++ b/lapack-netlib/SRC/zgeqr.c @@ -0,0 +1,740 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#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 ZGEQR */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEQR( M, N, A, LDA, T, TSIZE, WORK, LWORK, */ +/* INFO ) */ + +/* INTEGER INFO, LDA, M, N, TSIZE, LWORK */ +/* COMPLEX*16 A( LDA, * ), T( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEQR computes a QR factorization of a complex M-by-N matrix A: */ +/* > */ +/* > A = Q * ( R ), */ +/* > ( 0 ) */ +/* > */ +/* > where: */ +/* > */ +/* > Q is a M-by-M orthogonal matrix; */ +/* > R is an upper-triangular N-by-N matrix; */ +/* > 0 is a (M-N)-by-N zero matrix, if M > N. */ +/* > */ +/* > \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 elements on and above the diagonal of the array */ +/* > contain the f2cmin(M,N)-by-N upper trapezoidal matrix R */ +/* > (R is upper triangular if M >= N); */ +/* > the elements below the diagonal are used to store part of the */ +/* > data structure to represent Q. */ +/* > \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 (MAX(5,TSIZE)) */ +/* > On exit, if INFO = 0, T(1) returns optimal (or either minimal */ +/* > or optimal, if query is assumed) TSIZE. See TSIZE for details. */ +/* > Remaining T contains part of the data structure used to represent Q. */ +/* > If one wants to apply or construct Q, then one needs to keep T */ +/* > (in addition to A) and pass it to further subroutines. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TSIZE */ +/* > \verbatim */ +/* > TSIZE is INTEGER */ +/* > If TSIZE >= 5, the dimension of the array T. */ +/* > If TSIZE = -1 or -2, then a workspace query is assumed. The routine */ +/* > only calculates the sizes of the T and WORK arrays, returns these */ +/* > values as the first entries of the T and WORK arrays, and no error */ +/* > message related to T or WORK is issued by XERBLA. */ +/* > If TSIZE = -1, the routine calculates optimal size of T for the */ +/* > optimum performance and returns this value in T(1). */ +/* > If TSIZE = -2, the routine calculates minimal size of T and */ +/* > returns this value in T(1). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > (workspace) COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) contains optimal (or either minimal */ +/* > or optimal, if query was assumed) LWORK. */ +/* > See LWORK for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > If LWORK = -1 or -2, then a workspace query is assumed. The routine */ +/* > only calculates the sizes of the T and WORK arrays, returns these */ +/* > values as the first entries of the T and WORK arrays, and no error */ +/* > message related to T or WORK is issued by XERBLA. */ +/* > If LWORK = -1, the routine calculates optimal size of WORK for the */ +/* > optimal performance and returns this value in WORK(1). */ +/* > If LWORK = -2, the routine calculates minimal size of WORK and */ +/* > returns this value in WORK(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. */ + +/* > \par Further Details */ +/* ==================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The goal of the interface is to give maximum freedom to the developers for */ +/* > creating any QR factorization algorithm they wish. The triangular */ +/* > (trapezoidal) R has to be stored in the upper part of A. The lower part of A */ +/* > and the array T can be used to store any relevant information for applying or */ +/* > constructing the Q factor. The WORK array can safely be discarded after exit. */ +/* > */ +/* > Caution: One should not expect the sizes of T and WORK to be the same from one */ +/* > LAPACK implementation to the other, or even from one execution to the other. */ +/* > A workspace query (for T and WORK) is needed at each execution. However, */ +/* > for a given execution, the size of T and WORK are fixed and will not change */ +/* > from one query to the next. */ +/* > */ +/* > \endverbatim */ +/* > */ +/* > \par Further Details particular to this LAPACK implementation: */ +/* ============================================================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > These details are particular for this LAPACK implementation. Users should not */ +/* > take them for granted. These details may change in the future, and are not likely */ +/* > true for another LAPACK implementation. These details are relevant if one wants */ +/* > to try to understand the code. They are not part of the interface. */ +/* > */ +/* > In this version, */ +/* > */ +/* > T(2): row block size (MB) */ +/* > T(3): column block size (NB) */ +/* > T(6:TSIZE): data structure needed for Q, computed by */ +/* > ZLATSQR or ZGEQRT */ +/* > */ +/* > Depending on the matrix dimensions M and N, and row and column */ +/* > block sizes MB and NB returned by ILAENV, ZGEQR will use either */ +/* > ZLATSQR (if the matrix is tall-and-skinny) or ZGEQRT to compute */ +/* > the QR factorization. */ +/* > */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgeqr_(integer *m, integer *n, doublecomplex *a, integer + *lda, doublecomplex *t, integer *tsize, doublecomplex *work, integer * + lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + logical mint, minw; + integer mb, nb, nblcks; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + logical lminws; + extern /* Subroutine */ int zgeqrt_(integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + logical lquery; + integer mintsz; + extern /* Subroutine */ int zlatsqr_(integer *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, integer *); + + +/* -- 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. -- */ +/* November 2019 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --t; + --work; + + /* Function Body */ + *info = 0; + + lquery = *tsize == -1 || *tsize == -2 || *lwork == -1 || *lwork == -2; + + mint = FALSE_; + minw = FALSE_; + if (*tsize == -2 || *lwork == -2) { + if (*tsize != -1) { + mint = TRUE_; + } + if (*lwork != -1) { + minw = TRUE_; + } + } + +/* Determine the block size */ + + if (f2cmin(*m,*n) > 0) { + mb = ilaenv_(&c__1, "ZGEQR ", " ", m, n, &c__1, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb = ilaenv_(&c__1, "ZGEQR ", " ", m, n, &c__2, &c_n1, (ftnlen)6, ( + ftnlen)1); + } else { + mb = *m; + nb = 1; + } + if (mb > *m || mb <= *n) { + mb = *m; + } + if (nb > f2cmin(*m,*n) || nb < 1) { + nb = 1; + } + mintsz = *n + 5; + if (mb > *n && *m > *n) { + if ((*m - *n) % (mb - *n) == 0) { + nblcks = (*m - *n) / (mb - *n); + } else { + nblcks = (*m - *n) / (mb - *n) + 1; + } + } else { + nblcks = 1; + } + +/* Determine if the workspace size satisfies minimal size */ + + lminws = FALSE_; +/* Computing MAX */ + i__1 = 1, i__2 = nb * *n * nblcks + 5; + if ((*tsize < f2cmax(i__1,i__2) || *lwork < nb * *n) && *lwork >= *n && * + tsize >= mintsz && ! lquery) { +/* Computing MAX */ + i__1 = 1, i__2 = nb * *n * nblcks + 5; + if (*tsize < f2cmax(i__1,i__2)) { + lminws = TRUE_; + nb = 1; + mb = *m; + } + if (*lwork < nb * *n) { + lminws = TRUE_; + nb = 1; + } + } + + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = nb * *n * nblcks + 5; + if (*tsize < f2cmax(i__1,i__2) && ! lquery && ! lminws) { + *info = -6; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *n * nb; + if (*lwork < f2cmax(i__1,i__2) && ! lquery && ! lminws) { + *info = -8; + } + } + } + + if (*info == 0) { + if (mint) { + t[1].r = (doublereal) mintsz, t[1].i = 0.; + } else { + i__1 = nb * *n * nblcks + 5; + t[1].r = (doublereal) i__1, t[1].i = 0.; + } + t[2].r = (doublereal) mb, t[2].i = 0.; + t[3].r = (doublereal) nb, t[3].i = 0.; + if (minw) { + i__1 = f2cmax(1,*n); + work[1].r = (doublereal) i__1, work[1].i = 0.; + } else { +/* Computing MAX */ + i__2 = 1, i__3 = nb * *n; + i__1 = f2cmax(i__2,i__3); + work[1].r = (doublereal) i__1, work[1].i = 0.; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEQR", &i__1, (ftnlen)5); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (f2cmin(*m,*n) == 0) { + return 0; + } + +/* The QR Decomposition */ + + if (*m <= *n || mb <= *n || mb >= *m) { + zgeqrt_(m, n, &nb, &a[a_offset], lda, &t[6], &nb, &work[1], info); + } else { + zlatsqr_(m, n, &mb, &nb, &a[a_offset], lda, &t[6], &nb, &work[1], + lwork, info); + } + +/* Computing MAX */ + i__2 = 1, i__3 = nb * *n; + i__1 = f2cmax(i__2,i__3); + work[1].r = (doublereal) i__1, work[1].i = 0.; + + return 0; + +/* End of ZGEQR */ + +} /* zgeqr_ */ + diff --git a/lapack-netlib/SRC/zgeqr2.c b/lapack-netlib/SRC/zgeqr2.c new file mode 100644 index 000000000..9c39435b1 --- /dev/null +++ b/lapack-netlib/SRC/zgeqr2.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 ZGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorit +hm. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEQR2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEQR2( M, N, A, LDA, TAU, WORK, INFO ) */ + +/* INTEGER INFO, LDA, M, N */ +/* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEQR2 computes a QR factorization of a complex m-by-n matrix A: */ +/* > */ +/* > A = Q * ( R ), */ +/* > ( 0 ) */ +/* > */ +/* > where: */ +/* > */ +/* > Q is a m-by-m orthogonal matrix; */ +/* > R is an upper-triangular n-by-n matrix; */ +/* > 0 is a (m-n)-by-n zero matrix, if m > n. */ +/* > */ +/* > \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 elements on and above the diagonal of the array */ +/* > contain the f2cmin(m,n) by n upper trapezoidal matrix R (R is */ +/* > upper triangular if m >= n); the elements below the diagonal, */ +/* > with the array TAU, represent the unitary matrix Q as a */ +/* > product of elementary reflectors (see Further Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 array, dimension (f2cmin(M,N)) */ +/* > The scalar factors of the elementary reflectors (see Further */ +/* > Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2019 */ + +/* > \ingroup complex16GEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix Q is represented as a product of elementary reflectors */ +/* > */ +/* > Q = H(1) H(2) . . . H(k), where k = f2cmin(m,n). */ +/* > */ +/* > 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-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */ +/* > and tau in TAU(i). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgeqr2_(integer *m, integer *n, doublecomplex *a, + integer *lda, doublecomplex *tau, doublecomplex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublecomplex z__1; + + /* Local variables */ + integer i__, k; + doublecomplex alpha; + extern /* Subroutine */ int zlarf_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *), xerbla_(char *, integer *, ftnlen), zlarfg_(integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *); + + +/* -- 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..-- */ +/* November 2019 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEQR2", &i__1, (ftnlen)6); + return 0; + } + + k = f2cmin(*m,*n); + + i__1 = k; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */ + + i__2 = *m - i__ + 1; +/* Computing MIN */ + i__3 = i__ + 1; + zlarfg_(&i__2, &a[i__ + i__ * a_dim1], &a[f2cmin(i__3,*m) + i__ * a_dim1] + , &c__1, &tau[i__]); + if (i__ < *n) { + +/* Apply H(i)**H to A(i:m,i+1:n) from the left */ + + i__2 = i__ + i__ * a_dim1; + alpha.r = a[i__2].r, alpha.i = a[i__2].i; + i__2 = i__ + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + i__2 = *m - i__ + 1; + i__3 = *n - i__; + d_cnjg(&z__1, &tau[i__]); + zlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &z__1, + &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]); + i__2 = i__ + i__ * a_dim1; + a[i__2].r = alpha.r, a[i__2].i = alpha.i; + } +/* L10: */ + } + return 0; + +/* End of ZGEQR2 */ + +} /* zgeqr2_ */ + diff --git a/lapack-netlib/SRC/zgeqr2p.c b/lapack-netlib/SRC/zgeqr2p.c new file mode 100644 index 000000000..6d8a9b757 --- /dev/null +++ b/lapack-netlib/SRC/zgeqr2p.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 ZGEQR2P computes the QR factorization of a general rectangular matrix with non-negative diagona +l elements using an unblocked algorithm. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEQR2P + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEQR2P( M, N, A, LDA, TAU, WORK, INFO ) */ + +/* INTEGER INFO, LDA, M, N */ +/* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEQR2P computes a QR factorization of a complex m-by-n matrix A: */ +/* > */ +/* > A = Q * ( R ), */ +/* > ( 0 ) */ +/* > */ +/* > where: */ +/* > */ +/* > Q is a m-by-m orthogonal matrix; */ +/* > R is an upper-triangular n-by-n matrix with nonnegative diagonal */ +/* > entries; */ +/* > 0 is a (m-n)-by-n zero matrix, if m > n. */ +/* > */ +/* > \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 elements on and above the diagonal of the array */ +/* > contain the f2cmin(m,n) by n upper trapezoidal matrix R (R is */ +/* > upper triangular if m >= n). The diagonal entries of R */ +/* > are real and nonnegative; the elements below the diagonal, */ +/* > with the array TAU, represent the unitary matrix Q as a */ +/* > product of elementary reflectors (see Further Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 array, dimension (f2cmin(M,N)) */ +/* > The scalar factors of the elementary reflectors (see Further */ +/* > Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2019 */ + +/* > \ingroup complex16GEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix Q is represented as a product of elementary reflectors */ +/* > */ +/* > Q = H(1) H(2) . . . H(k), where k = f2cmin(m,n). */ +/* > */ +/* > 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-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */ +/* > and tau in TAU(i). */ +/* > */ +/* > See Lapack Working Note 203 for details */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgeqr2p_(integer *m, integer *n, doublecomplex *a, + integer *lda, doublecomplex *tau, doublecomplex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublecomplex z__1; + + /* Local variables */ + integer i__, k; + doublecomplex alpha; + extern /* Subroutine */ int zlarf_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *), xerbla_(char *, integer *, ftnlen), zlarfgp_(integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *); + + +/* -- 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..-- */ +/* November 2019 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEQR2P", &i__1, (ftnlen)7); + return 0; + } + + k = f2cmin(*m,*n); + + i__1 = k; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Generate elementary reflector H(i) to annihilate A(i+1:m,i) */ + + i__2 = *m - i__ + 1; +/* Computing MIN */ + i__3 = i__ + 1; + zlarfgp_(&i__2, &a[i__ + i__ * a_dim1], &a[f2cmin(i__3,*m) + i__ * + a_dim1], &c__1, &tau[i__]); + if (i__ < *n) { + +/* Apply H(i)**H to A(i:m,i+1:n) from the left */ + + i__2 = i__ + i__ * a_dim1; + alpha.r = a[i__2].r, alpha.i = a[i__2].i; + i__2 = i__ + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + i__2 = *m - i__ + 1; + i__3 = *n - i__; + d_cnjg(&z__1, &tau[i__]); + zlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &z__1, + &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]); + i__2 = i__ + i__ * a_dim1; + a[i__2].r = alpha.r, a[i__2].i = alpha.i; + } +/* L10: */ + } + return 0; + +/* End of ZGEQR2P */ + +} /* zgeqr2p_ */ + diff --git a/lapack-netlib/SRC/zgeqrf.c b/lapack-netlib/SRC/zgeqrf.c new file mode 100644 index 000000000..387511741 --- /dev/null +++ b/lapack-netlib/SRC/zgeqrf.c @@ -0,0 +1,705 @@ +/* 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 ZGEQRF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEQRF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) */ + +/* INTEGER INFO, LDA, LWORK, M, N */ +/* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEQRF computes a QR factorization of a complex M-by-N matrix A: */ +/* > */ +/* > A = Q * ( R ), */ +/* > ( 0 ) */ +/* > */ +/* > where: */ +/* > */ +/* > Q is a M-by-M orthogonal matrix; */ +/* > R is an upper-triangular N-by-N matrix; */ +/* > 0 is a (M-N)-by-N zero matrix, if M > N. */ +/* > */ +/* > \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 elements on and above the diagonal of the array */ +/* > contain the f2cmin(M,N)-by-N upper trapezoidal matrix R (R is */ +/* > upper triangular if m >= n); the elements below the diagonal, */ +/* > with the array TAU, represent the unitary matrix Q as a */ +/* > product of f2cmin(m,n) elementary reflectors (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] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 array, dimension (f2cmin(M,N)) */ +/* > The scalar factors of the elementary reflectors (see Further */ +/* > Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,N). */ +/* > For optimum performance LWORK >= N*NB, where NB is */ +/* > the optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2019 */ + +/* > \ingroup complex16GEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix Q is represented as a product of elementary reflectors */ +/* > */ +/* > Q = H(1) H(2) . . . H(k), where k = f2cmin(m,n). */ +/* > */ +/* > 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-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */ +/* > and tau in TAU(i). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgeqrf_(integer *m, integer *n, doublecomplex *a, + integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, k, nbmin, iinfo; + extern /* Subroutine */ int zgeqr2_(integer *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + integer ib, nb, nx; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *, + integer *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + integer ldwork; + extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + integer lwkopt; + logical lquery; + integer iws; + + +/* -- 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..-- */ +/* November 2019 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + nb = ilaenv_(&c__1, "ZGEQRF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen) + 1); + lwkopt = *n * nb; + work[1].r = (doublereal) lwkopt, work[1].i = 0.; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } else if (*lwork < f2cmax(1,*n) && ! lquery) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEQRF", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + k = f2cmin(*m,*n); + if (k == 0) { + work[1].r = 1., work[1].i = 0.; + return 0; + } + + nbmin = 2; + nx = 0; + iws = *n; + if (nb > 1 && nb < k) { + +/* Determine when to cross over from blocked to unblocked code. */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "ZGEQRF", " ", m, n, &c_n1, &c_n1, ( + ftnlen)6, (ftnlen)1); + nx = f2cmax(i__1,i__2); + if (nx < k) { + +/* Determine if workspace is large enough for blocked code. */ + + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: reduce NB and */ +/* determine the minimum value of NB. */ + + nb = *lwork / ldwork; +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "ZGEQRF", " ", m, n, &c_n1, & + c_n1, (ftnlen)6, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + } + } + } + + if (nb >= nbmin && nb < k && nx < k) { + +/* Use blocked code initially */ + + i__1 = k - nx; + i__2 = nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = k - i__ + 1; + ib = f2cmin(i__3,nb); + +/* Compute the QR factorization of the current block */ +/* A(i:m,i:i+ib-1) */ + + i__3 = *m - i__ + 1; + zgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[ + 1], &iinfo); + if (i__ + ib <= *n) { + +/* Form the triangular factor of the block reflector */ +/* H = H(i) H(i+1) . . . H(i+ib-1) */ + + i__3 = *m - i__ + 1; + zlarft_("Forward", "Columnwise", &i__3, &ib, &a[i__ + i__ * + a_dim1], lda, &tau[i__], &work[1], &ldwork); + +/* Apply H**H to A(i:m,i+ib:n) from the left */ + + i__3 = *m - i__ + 1; + i__4 = *n - i__ - ib + 1; + zlarfb_("Left", "Conjugate transpose", "Forward", "Columnwise" + , &i__3, &i__4, &ib, &a[i__ + i__ * a_dim1], lda, & + work[1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, + &work[ib + 1], &ldwork); + } +/* L10: */ + } + } else { + i__ = 1; + } + +/* Use unblocked code to factor the last or only block. */ + + if (i__ <= k) { + i__2 = *m - i__ + 1; + i__1 = *n - i__ + 1; + zgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1] + , &iinfo); + } + + work[1].r = (doublereal) iws, work[1].i = 0.; + return 0; + +/* End of ZGEQRF */ + +} /* zgeqrf_ */ + diff --git a/lapack-netlib/SRC/zgeqrfp.c b/lapack-netlib/SRC/zgeqrfp.c new file mode 100644 index 000000000..41cec7b6a --- /dev/null +++ b/lapack-netlib/SRC/zgeqrfp.c @@ -0,0 +1,708 @@ +/* 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 ZGEQRFP */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEQRFP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEQRFP( M, N, A, LDA, TAU, WORK, LWORK, INFO ) */ + +/* INTEGER INFO, LDA, LWORK, M, N */ +/* COMPLEX*16 A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEQR2P computes a QR factorization of a complex M-by-N matrix A: */ +/* > */ +/* > A = Q * ( R ), */ +/* > ( 0 ) */ +/* > */ +/* > where: */ +/* > */ +/* > Q is a M-by-M orthogonal matrix; */ +/* > R is an upper-triangular N-by-N matrix with nonnegative diagonal */ +/* > entries; */ +/* > 0 is a (M-N)-by-N zero matrix, if M > N. */ +/* > */ +/* > \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 elements on and above the diagonal of the array */ +/* > contain the f2cmin(M,N)-by-N upper trapezoidal matrix R (R is */ +/* > upper triangular if m >= n). The diagonal entries of R */ +/* > are real and nonnegative; The elements below the diagonal, */ +/* > with the array TAU, represent the unitary matrix Q as a */ +/* > product of f2cmin(m,n) elementary reflectors (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] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 array, dimension (f2cmin(M,N)) */ +/* > The scalar factors of the elementary reflectors (see Further */ +/* > Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,N). */ +/* > For optimum performance LWORK >= N*NB, where NB is */ +/* > the optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2019 */ + +/* > \ingroup complex16GEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix Q is represented as a product of elementary reflectors */ +/* > */ +/* > Q = H(1) H(2) . . . H(k), where k = f2cmin(m,n). */ +/* > */ +/* > 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-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */ +/* > and tau in TAU(i). */ +/* > */ +/* > See Lapack Working Note 203 for details */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgeqrfp_(integer *m, integer *n, doublecomplex *a, + integer *lda, doublecomplex *tau, doublecomplex *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, k, nbmin, iinfo, ib, nb, nx; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int zlarfb_(char *, char *, char *, char *, + integer *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + integer ldwork; + extern /* Subroutine */ int zlarft_(char *, char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + integer lwkopt; + logical lquery; + extern /* Subroutine */ int zgeqr2p_(integer *, integer *, doublecomplex * + , integer *, doublecomplex *, doublecomplex *, integer *); + integer iws; + + +/* -- 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..-- */ +/* November 2019 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + nb = ilaenv_(&c__1, "ZGEQRF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, (ftnlen) + 1); + lwkopt = *n * nb; + work[1].r = (doublereal) lwkopt, work[1].i = 0.; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } else if (*lwork < f2cmax(1,*n) && ! lquery) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEQRFP", &i__1, (ftnlen)7); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + k = f2cmin(*m,*n); + if (k == 0) { + work[1].r = 1., work[1].i = 0.; + return 0; + } + + nbmin = 2; + nx = 0; + iws = *n; + if (nb > 1 && nb < k) { + +/* Determine when to cross over from blocked to unblocked code. */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "ZGEQRF", " ", m, n, &c_n1, &c_n1, ( + ftnlen)6, (ftnlen)1); + nx = f2cmax(i__1,i__2); + if (nx < k) { + +/* Determine if workspace is large enough for blocked code. */ + + ldwork = *n; + iws = ldwork * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: reduce NB and */ +/* determine the minimum value of NB. */ + + nb = *lwork / ldwork; +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "ZGEQRF", " ", m, n, &c_n1, & + c_n1, (ftnlen)6, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + } + } + } + + if (nb >= nbmin && nb < k && nx < k) { + +/* Use blocked code initially */ + + i__1 = k - nx; + i__2 = nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = k - i__ + 1; + ib = f2cmin(i__3,nb); + +/* Compute the QR factorization of the current block */ +/* A(i:m,i:i+ib-1) */ + + i__3 = *m - i__ + 1; + zgeqr2p_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], & + work[1], &iinfo); + if (i__ + ib <= *n) { + +/* Form the triangular factor of the block reflector */ +/* H = H(i) H(i+1) . . . H(i+ib-1) */ + + i__3 = *m - i__ + 1; + zlarft_("Forward", "Columnwise", &i__3, &ib, &a[i__ + i__ * + a_dim1], lda, &tau[i__], &work[1], &ldwork); + +/* Apply H**H to A(i:m,i+ib:n) from the left */ + + i__3 = *m - i__ + 1; + i__4 = *n - i__ - ib + 1; + zlarfb_("Left", "Conjugate transpose", "Forward", "Columnwise" + , &i__3, &i__4, &ib, &a[i__ + i__ * a_dim1], lda, & + work[1], &ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, + &work[ib + 1], &ldwork); + } +/* L10: */ + } + } else { + i__ = 1; + } + +/* Use unblocked code to factor the last or only block. */ + + if (i__ <= k) { + i__2 = *m - i__ + 1; + i__1 = *n - i__ + 1; + zgeqr2p_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[ + 1], &iinfo); + } + + work[1].r = (doublereal) iws, work[1].i = 0.; + return 0; + +/* End of ZGEQRFP */ + +} /* zgeqrfp_ */ + diff --git a/lapack-netlib/SRC/zgeqrt.c b/lapack-netlib/SRC/zgeqrt.c new file mode 100644 index 000000000..d19675cd4 --- /dev/null +++ b/lapack-netlib/SRC/zgeqrt.c @@ -0,0 +1,630 @@ +/* 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 ZGEQRT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZGEQRT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZGEQRT( M, N, NB, A, LDA, T, LDT, WORK, INFO ) */ + +/* INTEGER INFO, LDA, LDT, M, N, NB */ +/* COMPLEX*16 A( LDA, * ), T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZGEQRT computes a blocked QR factorization of a complex M-by-N matrix A */ +/* > using the compact WY representation of Q. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The block size to be used in the blocked QR. MIN(M,N) >= NB >= 1. */ +/* > \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 above the diagonal of the array */ +/* > contain the f2cmin(M,N)-by-N upper trapezoidal matrix R (R is */ +/* > upper triangular if M >= N); the elements below the diagonal */ +/* > are the columns of V. */ +/* > \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,MIN(M,N)) */ +/* > The 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[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (NB*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 complex16GEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix V stores the elementary reflectors H(i) in the i-th column */ +/* > below the diagonal. For example, if M=5 and N=3, the matrix V is */ +/* > */ +/* > V = ( 1 ) */ +/* > ( v1 1 ) */ +/* > ( v1 v2 1 ) */ +/* > ( v1 v2 v3 ) */ +/* > ( v1 v2 v3 ) */ +/* > */ +/* > where the vi's represent the vectors which define H(i), which are returned */ +/* > in the matrix A. The 1's along the diagonal of V are not stored in A. */ +/* > */ +/* > Let K=MIN(M,N). The number of blocks is B = ceiling(K/NB), where each */ +/* > block is of order NB except for the last block, which is of order */ +/* > IB = K - (B-1)*NB. For each of the B blocks, a upper triangular block */ +/* > reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB */ +/* > for the last block) T's are stored in the NB-by-K matrix T as */ +/* > */ +/* > T = (T1 T2 ... TB). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zgeqrt_(integer *m, integer *n, integer *nb, + doublecomplex *a, integer *lda, doublecomplex *t, integer *ldt, + doublecomplex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, t_dim1, t_offset, i__1, i__2, i__3, i__4, i__5; + + /* Local variables */ + integer i__, k, iinfo, ib; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zlarfb_( + char *, char *, char *, char *, integer *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *), zgeqrt2_(integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *) + , zgeqrt3_(integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, integer *); + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 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; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nb < 1 || *nb > f2cmin(*m,*n) && f2cmin(*m,*n) > 0) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } else if (*ldt < *nb) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZGEQRT", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + k = f2cmin(*m,*n); + if (k == 0) { + return 0; + } + +/* Blocked loop of length K */ + + i__1 = k; + i__2 = *nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = k - i__ + 1; + ib = f2cmin(i__3,*nb); + +/* Compute the QR factorization of the current block A(I:M,I:I+IB-1) */ + + if (TRUE_) { + i__3 = *m - i__ + 1; + zgeqrt3_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &t[i__ * t_dim1 + + 1], ldt, &iinfo); + } else { + i__3 = *m - i__ + 1; + zgeqrt2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &t[i__ * t_dim1 + + 1], ldt, &iinfo); + } + if (i__ + ib <= *n) { + +/* Update by applying H**H to A(I:M,I+IB:N) from the left */ + + i__3 = *m - i__ + 1; + i__4 = *n - i__ - ib + 1; + i__5 = *n - i__ - ib + 1; + zlarfb_("L", "C", "F", "C", &i__3, &i__4, &ib, &a[i__ + i__ * + a_dim1], lda, &t[i__ * t_dim1 + 1], ldt, &a[i__ + (i__ + + ib) * a_dim1], lda, &work[1], &i__5); + } + } + return 0; + +/* End of ZGEQRT */ + +} /* zgeqrt_ */ +