diff --git a/lapack-netlib/SRC/slaorhr_col_getrfnp2.c b/lapack-netlib/SRC/slaorhr_col_getrfnp2.c new file mode 100644 index 000000000..71155947e --- /dev/null +++ b/lapack-netlib/SRC/slaorhr_col_getrfnp2.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 SLAORHR_COL_GETRFNP2 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DLAORHR_GETRF2NP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAORHR_COL_GETRFNP2( M, N, A, LDA, D, INFO ) */ + +/* INTEGER INFO, LDA, M, N */ +/* REAL A( LDA, * ), D( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAORHR_COL_GETRFNP2 computes the modified LU factorization without */ +/* > pivoting of a real general M-by-N matrix A. The factorization has */ +/* > the form: */ +/* > */ +/* > A - S = L * U, */ +/* > */ +/* > where: */ +/* > S is a m-by-n diagonal sign matrix with the diagonal D, so that */ +/* > D(i) = S(i,i), 1 <= i <= f2cmin(M,N). The diagonal D is constructed */ +/* > as D(i)=-SIGN(A(i,i)), where A(i,i) is the value after performing */ +/* > i-1 steps of Gaussian elimination. This means that the diagonal */ +/* > element at each step of "modified" Gaussian elimination is at */ +/* > least one in absolute value (so that division-by-zero not */ +/* > possible during the division by the diagonal element); */ +/* > */ +/* > L is a M-by-N lower triangular matrix with unit diagonal elements */ +/* > (lower trapezoidal if M > N); */ +/* > */ +/* > and U is a M-by-N upper triangular matrix */ +/* > (upper trapezoidal if M < N). */ +/* > */ +/* > This routine is an auxiliary routine used in the Householder */ +/* > reconstruction routine SORHR_COL. In SORHR_COL, this routine is */ +/* > applied to an M-by-N matrix A with orthonormal columns, where each */ +/* > element is bounded by one in absolute value. With the choice of */ +/* > the matrix S above, one can show that the diagonal element at each */ +/* > step of Gaussian elimination is the largest (in absolute value) in */ +/* > the column on or below the diagonal, so that no pivoting is required */ +/* > for numerical stability [1]. */ +/* > */ +/* > For more details on the Householder reconstruction algorithm, */ +/* > including the modified LU factorization, see [1]. */ +/* > */ +/* > This is the recursive version of the LU factorization algorithm. */ +/* > Denote A - S by B. The algorithm divides the matrix B into four */ +/* > submatrices: */ +/* > */ +/* > [ B11 | B12 ] where B11 is n1 by n1, */ +/* > B = [ -----|----- ] B21 is (m-n1) by n1, */ +/* > [ B21 | B22 ] B12 is n1 by n2, */ +/* > B22 is (m-n1) by n2, */ +/* > with n1 = f2cmin(m,n)/2, n2 = n-n1. */ +/* > */ +/* > */ +/* > The subroutine calls itself to factor B11, solves for B21, */ +/* > solves for B12, updates B22, then calls itself to factor B22. */ +/* > */ +/* > For more details on the recursive LU algorithm, see [2]. */ +/* > */ +/* > SLAORHR_COL_GETRFNP2 is called to factorize a block by the blocked */ +/* > routine SLAORHR_COL_GETRFNP, which uses blocked code calling */ +/* . Level 3 BLAS to update the submatrix. However, SLAORHR_COL_GETRFNP2 */ +/* > is self-sufficient and can be used without SLAORHR_COL_GETRFNP. */ +/* > */ +/* > [1] "Reconstructing Householder vectors from tall-skinny QR", */ +/* > G. Ballard, J. Demmel, L. Grigori, M. Jacquelin, H.D. Nguyen, */ +/* > E. Solomonik, J. Parallel Distrib. Comput., */ +/* > vol. 85, pp. 3-31, 2015. */ +/* > */ +/* > [2] "Recursion leads to automatic variable blocking for dense linear */ +/* > algebra algorithms", F. Gustavson, IBM J. of Res. and Dev., */ +/* > vol. 41, no. 6, pp. 737-755, 1997. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix to be factored. */ +/* > On exit, the factors L and U from the factorization */ +/* > A-S=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,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension f2cmin(M,N) */ +/* > The diagonal elements of the diagonal M-by-N sign matrix S, */ +/* > D(i) = S(i,i), where 1 <= i <= f2cmin(M,N). The elements can */ +/* > be only plus or minus one. */ +/* > \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 realGEcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2019, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int slaorhr_col_getrfnp2_(integer *m, integer *n, real *a, + integer *lda, real *d__, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + real r__1; + + /* Local variables */ + integer i__, iinfo; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), + sgemm_(char *, char *, integer *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *); + real sfmin; + integer n1, n2; + extern /* Subroutine */ int strsm_(char *, char *, char *, char *, + integer *, integer *, real *, real *, integer *, real *, integer * + ); + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + + +/* -- 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 parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --d__; + + /* 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_("SLAORHR_COL_GETRFNP2", &i__1, (ftnlen)20); + return 0; + } + +/* Quick return if possible */ + + if (f2cmin(*m,*n) == 0) { + return 0; + } + if (*m == 1) { + +/* One row case, (also recursion termination case), */ +/* use unblocked code */ + +/* Transfer the sign */ + + d__[1] = -r_sign(&c_b3, &a[a_dim1 + 1]); + +/* Construct the row of U */ + + a[a_dim1 + 1] -= d__[1]; + + } else if (*n == 1) { + +/* One column case, (also recursion termination case), */ +/* use unblocked code */ + +/* Transfer the sign */ + + d__[1] = -r_sign(&c_b3, &a[a_dim1 + 1]); + +/* Construct the row of U */ + + a[a_dim1 + 1] -= d__[1]; + +/* Scale the elements 2:M of the column */ + +/* Determine machine safe minimum */ + + sfmin = slamch_("S"); + +/* Construct the subdiagonal elements of L */ + + if ((r__1 = a[a_dim1 + 1], abs(r__1)) >= sfmin) { + i__1 = *m - 1; + r__1 = 1.f / a[a_dim1 + 1]; + sscal_(&i__1, &r__1, &a[a_dim1 + 2], &c__1); + } else { + i__1 = *m; + for (i__ = 2; i__ <= i__1; ++i__) { + a[i__ + a_dim1] /= a[a_dim1 + 1]; + } + } + + } else { + +/* Divide the matrix B into four submatrices */ + + n1 = f2cmin(*m,*n) / 2; + n2 = *n - n1; + +/* Factor B11, recursive call */ + + slaorhr_col_getrfnp2_(&n1, &n1, &a[a_offset], lda, &d__[1], &iinfo); + +/* Solve for B21 */ + + i__1 = *m - n1; + strsm_("R", "U", "N", "N", &i__1, &n1, &c_b3, &a[a_offset], lda, &a[ + n1 + 1 + a_dim1], lda); + +/* Solve for B12 */ + + strsm_("L", "L", "N", "U", &n1, &n2, &c_b3, &a[a_offset], lda, &a[(n1 + + 1) * a_dim1 + 1], lda); + +/* Update B22, i.e. compute the Schur complement */ +/* B22 := B22 - B21*B12 */ + + i__1 = *m - n1; + sgemm_("N", "N", &i__1, &n2, &n1, &c_b19, &a[n1 + 1 + a_dim1], lda, & + a[(n1 + 1) * a_dim1 + 1], lda, &c_b3, &a[n1 + 1 + (n1 + 1) * + a_dim1], lda); + +/* Factor B22, recursive call */ + + i__1 = *m - n1; + slaorhr_col_getrfnp2_(&i__1, &n2, &a[n1 + 1 + (n1 + 1) * a_dim1], + lda, &d__[n1 + 1], &iinfo); + + } + return 0; + +/* End of SLAORHR_COL_GETRFNP2 */ + +} /* slaorhr_col_getrfnp2__ */ + diff --git a/lapack-netlib/SRC/slapll.c b/lapack-netlib/SRC/slapll.c new file mode 100644 index 000000000..4e7e99946 --- /dev/null +++ b/lapack-netlib/SRC/slapll.c @@ -0,0 +1,554 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLAPLL measures the linear dependence of two vectors. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAPLL + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAPLL( N, X, INCX, Y, INCY, SSMIN ) */ + +/* INTEGER INCX, INCY, N */ +/* REAL SSMIN */ +/* REAL X( * ), Y( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Given two column vectors X and Y, let */ +/* > */ +/* > A = ( X Y ). */ +/* > */ +/* > The subroutine first computes the QR factorization of A = Q*R, */ +/* > and then computes the SVD of the 2-by-2 upper triangular matrix R. */ +/* > The smaller singular value of R is returned in SSMIN, which is used */ +/* > as the measurement of the linear dependency of the vectors X and Y. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The length of the vectors X and Y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is REAL array, */ +/* > dimension (1+(N-1)*INCX) */ +/* > On entry, X contains the N-vector X. */ +/* > On exit, X is overwritten. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The increment between successive elements of X. INCX > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is REAL array, */ +/* > dimension (1+(N-1)*INCY) */ +/* > On entry, Y contains the N-vector Y. */ +/* > On exit, Y is overwritten. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCY */ +/* > \verbatim */ +/* > INCY is INTEGER */ +/* > The increment between successive elements of Y. INCY > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SSMIN */ +/* > \verbatim */ +/* > SSMIN is REAL */ +/* > The smallest singular value of the N-by-2 matrix A = ( X Y ). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slapll_(integer *n, real *x, integer *incx, real *y, + integer *incy, real *ssmin) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + extern real sdot_(integer *, real *, integer *, real *, integer *); + extern /* Subroutine */ int slas2_(real *, real *, real *, real *, real *) + ; + real c__, ssmax; + extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, + real *, integer *); + real a11, a12, a22; + extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *, + real *); + real tau; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + --y; + --x; + + /* Function Body */ + if (*n <= 1) { + *ssmin = 0.f; + return 0; + } + +/* Compute the QR factorization of the N-by-2 matrix ( X Y ) */ + + slarfg_(n, &x[1], &x[*incx + 1], incx, &tau); + a11 = x[1]; + x[1] = 1.f; + + c__ = -tau * sdot_(n, &x[1], incx, &y[1], incy); + saxpy_(n, &c__, &x[1], incx, &y[1], incy); + + i__1 = *n - 1; + slarfg_(&i__1, &y[*incy + 1], &y[(*incy << 1) + 1], incy, &tau); + + a12 = y[1]; + a22 = y[*incy + 1]; + +/* Compute the SVD of 2-by-2 Upper triangular matrix. */ + + slas2_(&a11, &a12, &a22, ssmin, &ssmax); + + return 0; + +/* End of SLAPLL */ + +} /* slapll_ */ + diff --git a/lapack-netlib/SRC/slapmr.c b/lapack-netlib/SRC/slapmr.c new file mode 100644 index 000000000..234d2ddd5 --- /dev/null +++ b/lapack-netlib/SRC/slapmr.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 SLAPMR rearranges rows of a matrix as specified by a permutation vector. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAPMR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAPMR( FORWRD, M, N, X, LDX, K ) */ + +/* LOGICAL FORWRD */ +/* INTEGER LDX, M, N */ +/* INTEGER K( * ) */ +/* REAL X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAPMR rearranges the rows of the M by N matrix X as specified */ +/* > by the permutation K(1),K(2),...,K(M) of the integers 1,...,M. */ +/* > If FORWRD = .TRUE., forward permutation: */ +/* > */ +/* > X(K(I),*) is moved X(I,*) for I = 1,2,...,M. */ +/* > */ +/* > If FORWRD = .FALSE., backward permutation: */ +/* > */ +/* > X(I,*) is moved to X(K(I),*) for I = 1,2,...,M. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] FORWRD */ +/* > \verbatim */ +/* > FORWRD is LOGICAL */ +/* > = .TRUE., forward permutation */ +/* > = .FALSE., backward permutation */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix X. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix X. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (LDX,N) */ +/* > On entry, the M by N matrix X. */ +/* > On exit, X contains the permuted matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X, LDX >= MAX(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] K */ +/* > \verbatim */ +/* > K is INTEGER array, dimension (M) */ +/* > On entry, K contains the permutation vector. K is used as */ +/* > internal workspace, but reset to its original value on */ +/* > output. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slapmr_(logical *forwrd, integer *m, integer *n, real *x, + integer *ldx, integer *k) +{ + /* System generated locals */ + integer x_dim1, x_offset, i__1, i__2; + + /* Local variables */ + real temp; + integer i__, j, jj, in; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --k; + + /* Function Body */ + if (*m <= 1) { + return 0; + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + k[i__] = -k[i__]; +/* L10: */ + } + + if (*forwrd) { + +/* Forward permutation */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + + if (k[i__] > 0) { + goto L40; + } + + j = i__; + k[j] = -k[j]; + in = k[j]; + +L20: + if (k[in] > 0) { + goto L40; + } + + i__2 = *n; + for (jj = 1; jj <= i__2; ++jj) { + temp = x[j + jj * x_dim1]; + x[j + jj * x_dim1] = x[in + jj * x_dim1]; + x[in + jj * x_dim1] = temp; +/* L30: */ + } + + k[in] = -k[in]; + j = in; + in = k[in]; + goto L20; + +L40: + +/* L50: */ + ; + } + + } else { + +/* Backward permutation */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + + if (k[i__] > 0) { + goto L80; + } + + k[i__] = -k[i__]; + j = k[i__]; +L60: + if (j == i__) { + goto L80; + } + + i__2 = *n; + for (jj = 1; jj <= i__2; ++jj) { + temp = x[i__ + jj * x_dim1]; + x[i__ + jj * x_dim1] = x[j + jj * x_dim1]; + x[j + jj * x_dim1] = temp; +/* L70: */ + } + + k[j] = -k[j]; + j = k[j]; + goto L60; + +L80: + +/* L90: */ + ; + } + + } + + return 0; + +/* End of ZLAPMT */ + +} /* slapmr_ */ + diff --git a/lapack-netlib/SRC/slapmt.c b/lapack-netlib/SRC/slapmt.c new file mode 100644 index 000000000..ea7541eed --- /dev/null +++ b/lapack-netlib/SRC/slapmt.c @@ -0,0 +1,610 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLAPMT performs a forward or backward permutation of the columns of a matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAPMT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAPMT( FORWRD, M, N, X, LDX, K ) */ + +/* LOGICAL FORWRD */ +/* INTEGER LDX, M, N */ +/* INTEGER K( * ) */ +/* REAL X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAPMT rearranges the columns of the M by N matrix X as specified */ +/* > by the permutation K(1),K(2),...,K(N) of the integers 1,...,N. */ +/* > If FORWRD = .TRUE., forward permutation: */ +/* > */ +/* > X(*,K(J)) is moved X(*,J) for J = 1,2,...,N. */ +/* > */ +/* > If FORWRD = .FALSE., backward permutation: */ +/* > */ +/* > X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] FORWRD */ +/* > \verbatim */ +/* > FORWRD is LOGICAL */ +/* > = .TRUE., forward permutation */ +/* > = .FALSE., backward permutation */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix X. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix X. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (LDX,N) */ +/* > On entry, the M by N matrix X. */ +/* > On exit, X contains the permuted matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X, LDX >= MAX(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] K */ +/* > \verbatim */ +/* > K is INTEGER array, dimension (N) */ +/* > On entry, K contains the permutation vector. K is used as */ +/* > internal workspace, but reset to its original value on */ +/* > output. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slapmt_(logical *forwrd, integer *m, integer *n, real *x, + integer *ldx, integer *k) +{ + /* System generated locals */ + integer x_dim1, x_offset, i__1, i__2; + + /* Local variables */ + real temp; + integer i__, j, ii, in; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --k; + + /* Function Body */ + if (*n <= 1) { + return 0; + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + k[i__] = -k[i__]; +/* L10: */ + } + + if (*forwrd) { + +/* Forward permutation */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + + if (k[i__] > 0) { + goto L40; + } + + j = i__; + k[j] = -k[j]; + in = k[j]; + +L20: + if (k[in] > 0) { + goto L40; + } + + i__2 = *m; + for (ii = 1; ii <= i__2; ++ii) { + temp = x[ii + j * x_dim1]; + x[ii + j * x_dim1] = x[ii + in * x_dim1]; + x[ii + in * x_dim1] = temp; +/* L30: */ + } + + k[in] = -k[in]; + j = in; + in = k[in]; + goto L20; + +L40: + +/* L60: */ + ; + } + + } else { + +/* Backward permutation */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + + if (k[i__] > 0) { + goto L100; + } + + k[i__] = -k[i__]; + j = k[i__]; +L80: + if (j == i__) { + goto L100; + } + + i__2 = *m; + for (ii = 1; ii <= i__2; ++ii) { + temp = x[ii + i__ * x_dim1]; + x[ii + i__ * x_dim1] = x[ii + j * x_dim1]; + x[ii + j * x_dim1] = temp; +/* L90: */ + } + + k[j] = -k[j]; + j = k[j]; + goto L80; + +L100: +/* L110: */ + ; + } + + } + + return 0; + +/* End of SLAPMT */ + +} /* slapmt_ */ + diff --git a/lapack-netlib/SRC/slapy2.c b/lapack-netlib/SRC/slapy2.c new file mode 100644 index 000000000..e35d34c21 --- /dev/null +++ b/lapack-netlib/SRC/slapy2.c @@ -0,0 +1,502 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLAPY2 returns sqrt(x2+y2). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAPY2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SLAPY2( X, Y ) */ + +/* REAL X, Y */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary */ +/* > overflow. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] X */ +/* > \verbatim */ +/* > X is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Y */ +/* > \verbatim */ +/* > Y is REAL */ +/* > X and Y specify the values x and y. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup OTHERauxiliary */ + +/* ===================================================================== */ +real slapy2_(real *x, real *y) +{ + /* System generated locals */ + real ret_val, r__1; + + /* Local variables */ + real xabs, yabs; + logical x_is_nan__, y_is_nan__; + real w, z__; + extern logical sisnan_(real *); + + +/* -- 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 */ + + +/* ===================================================================== */ + + + + x_is_nan__ = sisnan_(x); + y_is_nan__ = sisnan_(y); + if (x_is_nan__) { + ret_val = *x; + } + if (y_is_nan__) { + ret_val = *y; + } + + if (! (x_is_nan__ || y_is_nan__)) { + xabs = abs(*x); + yabs = abs(*y); + w = f2cmax(xabs,yabs); + z__ = f2cmin(xabs,yabs); + if (z__ == 0.f) { + ret_val = w; + } else { +/* Computing 2nd power */ + r__1 = z__ / w; + ret_val = w * sqrt(r__1 * r__1 + 1.f); + } + } + return ret_val; + +/* End of SLAPY2 */ + +} /* slapy2_ */ + diff --git a/lapack-netlib/SRC/slapy3.c b/lapack-netlib/SRC/slapy3.c new file mode 100644 index 000000000..cb1d846e8 --- /dev/null +++ b/lapack-netlib/SRC/slapy3.c @@ -0,0 +1,501 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLAPY3 returns sqrt(x2+y2+z2). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAPY3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SLAPY3( X, Y, Z ) */ + +/* REAL X, Y, Z */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause */ +/* > unnecessary overflow. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] X */ +/* > \verbatim */ +/* > X is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Y */ +/* > \verbatim */ +/* > Y is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Z */ +/* > \verbatim */ +/* > Z is REAL */ +/* > X, Y and Z specify the values x, y and z. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* ===================================================================== */ +real slapy3_(real *x, real *y, real *z__) +{ + /* System generated locals */ + real ret_val, r__1, r__2, r__3; + + /* Local variables */ + real xabs, yabs, zabs, w; + + +/* -- 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 */ + + +/* ===================================================================== */ + + + xabs = abs(*x); + yabs = abs(*y); + zabs = abs(*z__); +/* Computing MAX */ + r__1 = f2cmax(xabs,yabs); + w = f2cmax(r__1,zabs); + if (w == 0.f) { +/* W can be zero for f2cmax(0,nan,0) */ +/* adding all three entries together will make sure */ +/* NaN will not disappear. */ + ret_val = xabs + yabs + zabs; + } else { +/* Computing 2nd power */ + r__1 = xabs / w; +/* Computing 2nd power */ + r__2 = yabs / w; +/* Computing 2nd power */ + r__3 = zabs / w; + ret_val = w * sqrt(r__1 * r__1 + r__2 * r__2 + r__3 * r__3); + } + return ret_val; + +/* End of SLAPY3 */ + +} /* slapy3_ */ + diff --git a/lapack-netlib/SRC/slaqgb.c b/lapack-netlib/SRC/slaqgb.c new file mode 100644 index 000000000..9cb364fad --- /dev/null +++ b/lapack-netlib/SRC/slaqgb.c @@ -0,0 +1,665 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLAQGB scales a general band matrix, using row and column scaling factors computed by sgbequ. +*/ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAQGB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, */ +/* AMAX, EQUED ) */ + +/* CHARACTER EQUED */ +/* INTEGER KL, KU, LDAB, M, N */ +/* REAL AMAX, COLCND, ROWCND */ +/* REAL AB( LDAB, * ), C( * ), R( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAQGB equilibrates a general M by N band matrix A with KL */ +/* > subdiagonals and KU superdiagonals using the row and scaling factors */ +/* > in the vectors R and C. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of subdiagonals within the band of A. KL >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of superdiagonals within the band of A. KU >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is REAL array, dimension (LDAB,N) */ +/* > On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */ +/* > The j-th column of A is stored in the j-th column of the */ +/* > array AB as follows: */ +/* > AB(ku+1+i-j,j) = A(i,j) for f2cmax(1,j-ku)<=i<=f2cmin(m,j+kl) */ +/* > */ +/* > On exit, the equilibrated matrix, in the same storage format */ +/* > as A. See EQUED for the form of the equilibrated matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDA >= KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] R */ +/* > \verbatim */ +/* > R is REAL array, dimension (M) */ +/* > The row scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (N) */ +/* > The column scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ROWCND */ +/* > \verbatim */ +/* > ROWCND is REAL */ +/* > Ratio of the smallest R(i) to the largest R(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COLCND */ +/* > \verbatim */ +/* > COLCND is REAL */ +/* > Ratio of the smallest C(i) to the largest C(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AMAX */ +/* > \verbatim */ +/* > AMAX is REAL */ +/* > Absolute value of largest matrix entry. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies the form of equilibration that was done. */ +/* > = 'N': No equilibration */ +/* > = 'R': Row equilibration, i.e., A has been premultiplied by */ +/* > diag(R). */ +/* > = 'C': Column equilibration, i.e., A has been postmultiplied */ +/* > by diag(C). */ +/* > = 'B': Both row and column equilibration, i.e., A has been */ +/* > replaced by diag(R) * A * diag(C). */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > THRESH is a threshold value used to decide if row or column scaling */ +/* > should be done based on the ratio of the row or column scaling */ +/* > factors. If ROWCND < THRESH, row scaling is done, and if */ +/* > COLCND < THRESH, column scaling is done. */ +/* > */ +/* > LARGE and SMALL are threshold values used to decide if row scaling */ +/* > should be done based on the absolute size of the largest matrix */ +/* > element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realGBauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slaqgb_(integer *m, integer *n, integer *kl, integer *ku, + real *ab, integer *ldab, real *r__, real *c__, real *rowcnd, real * + colcnd, real *amax, char *equed) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6; + + /* Local variables */ + integer i__, j; + real large, small, cj; + extern real slamch_(char *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --r__; + --c__; + + /* Function Body */ + if (*m <= 0 || *n <= 0) { + *(unsigned char *)equed = 'N'; + return 0; + } + +/* Initialize LARGE and SMALL. */ + + small = slamch_("Safe minimum") / slamch_("Precision"); + large = 1.f / small; + + if (*rowcnd >= .1f && *amax >= small && *amax <= large) { + +/* No row scaling */ + + if (*colcnd >= .1f) { + +/* No column scaling */ + + *(unsigned char *)equed = 'N'; + } else { + +/* Column scaling */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = c__[j]; +/* Computing MAX */ + i__2 = 1, i__3 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__4 = f2cmin(i__5,i__6); + for (i__ = f2cmax(i__2,i__3); i__ <= i__4; ++i__) { + ab[*ku + 1 + i__ - j + j * ab_dim1] = cj * ab[*ku + 1 + + i__ - j + j * ab_dim1]; +/* L10: */ + } +/* L20: */ + } + *(unsigned char *)equed = 'C'; + } + } else if (*colcnd >= .1f) { + +/* Row scaling, no column scaling */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__4 = 1, i__2 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__3 = f2cmin(i__5,i__6); + for (i__ = f2cmax(i__4,i__2); i__ <= i__3; ++i__) { + ab[*ku + 1 + i__ - j + j * ab_dim1] = r__[i__] * ab[*ku + 1 + + i__ - j + j * ab_dim1]; +/* L30: */ + } +/* L40: */ + } + *(unsigned char *)equed = 'R'; + } else { + +/* Row and column scaling */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = c__[j]; +/* Computing MAX */ + i__3 = 1, i__4 = j - *ku; +/* Computing MIN */ + i__5 = *m, i__6 = j + *kl; + i__2 = f2cmin(i__5,i__6); + for (i__ = f2cmax(i__3,i__4); i__ <= i__2; ++i__) { + ab[*ku + 1 + i__ - j + j * ab_dim1] = cj * r__[i__] * ab[*ku + + 1 + i__ - j + j * ab_dim1]; +/* L50: */ + } +/* L60: */ + } + *(unsigned char *)equed = 'B'; + } + + return 0; + +/* End of SLAQGB */ + +} /* slaqgb_ */ + diff --git a/lapack-netlib/SRC/slaqge.c b/lapack-netlib/SRC/slaqge.c new file mode 100644 index 000000000..2746441e0 --- /dev/null +++ b/lapack-netlib/SRC/slaqge.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 SLAQGE scales a general rectangular matrix, using row and column scaling factors computed by sg +eequ. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAQGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX, */ +/* EQUED ) */ + +/* CHARACTER EQUED */ +/* INTEGER LDA, M, N */ +/* REAL AMAX, COLCND, ROWCND */ +/* REAL A( LDA, * ), C( * ), R( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAQGE equilibrates a general M by N matrix A using the row and */ +/* > column scaling factors in the vectors R and C. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the M by N matrix A. */ +/* > On exit, the equilibrated matrix. See EQUED for the form of */ +/* > the equilibrated matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(M,1). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] R */ +/* > \verbatim */ +/* > R is REAL array, dimension (M) */ +/* > The row scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (N) */ +/* > The column scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ROWCND */ +/* > \verbatim */ +/* > ROWCND is REAL */ +/* > Ratio of the smallest R(i) to the largest R(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COLCND */ +/* > \verbatim */ +/* > COLCND is REAL */ +/* > Ratio of the smallest C(i) to the largest C(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AMAX */ +/* > \verbatim */ +/* > AMAX is REAL */ +/* > Absolute value of largest matrix entry. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies the form of equilibration that was done. */ +/* > = 'N': No equilibration */ +/* > = 'R': Row equilibration, i.e., A has been premultiplied by */ +/* > diag(R). */ +/* > = 'C': Column equilibration, i.e., A has been postmultiplied */ +/* > by diag(C). */ +/* > = 'B': Both row and column equilibration, i.e., A has been */ +/* > replaced by diag(R) * A * diag(C). */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > THRESH is a threshold value used to decide if row or column scaling */ +/* > should be done based on the ratio of the row or column scaling */ +/* > factors. If ROWCND < THRESH, row scaling is done, and if */ +/* > COLCND < THRESH, column scaling is done. */ +/* > */ +/* > LARGE and SMALL are threshold values used to decide if row scaling */ +/* > should be done based on the absolute size of the largest matrix */ +/* > element. If AMAX > LARGE or AMAX < SMALL, row scaling is done. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realGEauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slaqge_(integer *m, integer *n, real *a, integer *lda, + real *r__, real *c__, real *rowcnd, real *colcnd, real *amax, char * + equed) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j; + real large, small, cj; + extern real slamch_(char *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --r__; + --c__; + + /* Function Body */ + if (*m <= 0 || *n <= 0) { + *(unsigned char *)equed = 'N'; + return 0; + } + +/* Initialize LARGE and SMALL. */ + + small = slamch_("Safe minimum") / slamch_("Precision"); + large = 1.f / small; + + if (*rowcnd >= .1f && *amax >= small && *amax <= large) { + +/* No row scaling */ + + if (*colcnd >= .1f) { + +/* No column scaling */ + + *(unsigned char *)equed = 'N'; + } else { + +/* Column scaling */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = c__[j]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = cj * a[i__ + j * a_dim1]; +/* L10: */ + } +/* L20: */ + } + *(unsigned char *)equed = 'C'; + } + } else if (*colcnd >= .1f) { + +/* Row scaling, no column scaling */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = r__[i__] * a[i__ + j * a_dim1]; +/* L30: */ + } +/* L40: */ + } + *(unsigned char *)equed = 'R'; + } else { + +/* Row and column scaling */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = c__[j]; + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = cj * r__[i__] * a[i__ + j * a_dim1]; +/* L50: */ + } +/* L60: */ + } + *(unsigned char *)equed = 'B'; + } + + return 0; + +/* End of SLAQGE */ + +} /* slaqge_ */ + diff --git a/lapack-netlib/SRC/slaqp2.c b/lapack-netlib/SRC/slaqp2.c new file mode 100644 index 000000000..da750e47b --- /dev/null +++ b/lapack-netlib/SRC/slaqp2.c @@ -0,0 +1,680 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLAQP2 computes a QR factorization with column pivoting of the matrix block. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAQP2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2, */ +/* WORK ) */ + +/* INTEGER LDA, M, N, OFFSET */ +/* INTEGER JPVT( * ) */ +/* REAL A( LDA, * ), TAU( * ), VN1( * ), VN2( * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAQP2 computes a QR factorization with column pivoting of */ +/* > the block A(OFFSET+1:M,1:N). */ +/* > The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] OFFSET */ +/* > \verbatim */ +/* > OFFSET is INTEGER */ +/* > The number of rows of the matrix A that must be pivoted */ +/* > but no factorized. OFFSET >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, the upper triangle of block A(OFFSET+1:M,1:N) is */ +/* > the triangular factor obtained; the elements in block */ +/* > A(OFFSET+1:M,1:N) below the diagonal, together with the */ +/* > array TAU, represent the orthogonal matrix Q as a product of */ +/* > elementary reflectors. Block A(1:OFFSET,1:N) has been */ +/* > accordingly pivoted, but no factorized. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] JPVT */ +/* > \verbatim */ +/* > JPVT is INTEGER array, dimension (N) */ +/* > On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted */ +/* > to the front of A*P (a leading column); if JPVT(i) = 0, */ +/* > the i-th column of A is a free column. */ +/* > On exit, if JPVT(i) = k, then the i-th column of A*P */ +/* > was the k-th column of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is REAL array, dimension (f2cmin(M,N)) */ +/* > The scalar factors of the elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VN1 */ +/* > \verbatim */ +/* > VN1 is REAL array, dimension (N) */ +/* > The vector with the partial column norms. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VN2 */ +/* > \verbatim */ +/* > VN2 is REAL array, dimension (N) */ +/* > The vector with the exact column norms. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (N) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */ +/* > X. Sun, Computer Science Dept., Duke University, USA */ +/* > \n */ +/* > Partial column norm updating strategy modified on April 2011 */ +/* > Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */ +/* > University of Zagreb, Croatia. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > LAPACK Working Note 176 */ + +/* > \htmlonly */ +/* > [PDF] */ +/* > \endhtmlonly */ + +/* ===================================================================== */ +/* Subroutine */ int slaqp2_(integer *m, integer *n, integer *offset, real *a, + integer *lda, integer *jpvt, real *tau, real *vn1, real *vn2, real * + work) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + real r__1, r__2; + + /* Local variables */ + real temp, temp2; + extern real snrm2_(integer *, real *, integer *); + integer i__, j; + real tol3z; + integer offpi; + extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *, + integer *, real *, real *, integer *, real *); + integer itemp; + extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, + integer *); + integer mn; + extern real slamch_(char *); + extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *, + real *); + extern integer isamax_(integer *, real *, integer *); + real aii; + integer pvt; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --jpvt; + --tau; + --vn1; + --vn2; + --work; + + /* Function Body */ +/* Computing MIN */ + i__1 = *m - *offset; + mn = f2cmin(i__1,*n); + tol3z = sqrt(slamch_("Epsilon")); + +/* Compute factorization. */ + + i__1 = mn; + for (i__ = 1; i__ <= i__1; ++i__) { + + offpi = *offset + i__; + +/* Determine ith pivot column and swap if necessary. */ + + i__2 = *n - i__ + 1; + pvt = i__ - 1 + isamax_(&i__2, &vn1[i__], &c__1); + + if (pvt != i__) { + sswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[i__ * a_dim1 + 1], & + c__1); + itemp = jpvt[pvt]; + jpvt[pvt] = jpvt[i__]; + jpvt[i__] = itemp; + vn1[pvt] = vn1[i__]; + vn2[pvt] = vn2[i__]; + } + +/* Generate elementary reflector H(i). */ + + if (offpi < *m) { + i__2 = *m - offpi + 1; + slarfg_(&i__2, &a[offpi + i__ * a_dim1], &a[offpi + 1 + i__ * + a_dim1], &c__1, &tau[i__]); + } else { + slarfg_(&c__1, &a[*m + i__ * a_dim1], &a[*m + i__ * a_dim1], & + c__1, &tau[i__]); + } + + if (i__ < *n) { + +/* Apply H(i)**T to A(offset+i:m,i+1:n) from the left. */ + + aii = a[offpi + i__ * a_dim1]; + a[offpi + i__ * a_dim1] = 1.f; + i__2 = *m - offpi + 1; + i__3 = *n - i__; + slarf_("Left", &i__2, &i__3, &a[offpi + i__ * a_dim1], &c__1, & + tau[i__], &a[offpi + (i__ + 1) * a_dim1], lda, &work[1]); + a[offpi + i__ * a_dim1] = aii; + } + +/* Update partial column norms. */ + + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + if (vn1[j] != 0.f) { + +/* NOTE: The following 4 lines follow from the analysis in */ +/* Lapack Working Note 176. */ + +/* Computing 2nd power */ + r__2 = (r__1 = a[offpi + j * a_dim1], abs(r__1)) / vn1[j]; + temp = 1.f - r__2 * r__2; + temp = f2cmax(temp,0.f); +/* Computing 2nd power */ + r__1 = vn1[j] / vn2[j]; + temp2 = temp * (r__1 * r__1); + if (temp2 <= tol3z) { + if (offpi < *m) { + i__3 = *m - offpi; + vn1[j] = snrm2_(&i__3, &a[offpi + 1 + j * a_dim1], & + c__1); + vn2[j] = vn1[j]; + } else { + vn1[j] = 0.f; + vn2[j] = 0.f; + } + } else { + vn1[j] *= sqrt(temp); + } + } +/* L10: */ + } + +/* L20: */ + } + + return 0; + +/* End of SLAQP2 */ + +} /* slaqp2_ */ + diff --git a/lapack-netlib/SRC/slaqps.c b/lapack-netlib/SRC/slaqps.c new file mode 100644 index 000000000..cc5b68c98 --- /dev/null +++ b/lapack-netlib/SRC/slaqps.c @@ -0,0 +1,798 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLAQPS computes a step of QR factorization with column pivoting of a real m-by-n matrix A by us +ing BLAS level 3. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAQPS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1, */ +/* VN2, AUXV, F, LDF ) */ + +/* INTEGER KB, LDA, LDF, M, N, NB, OFFSET */ +/* INTEGER JPVT( * ) */ +/* REAL A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ), */ +/* $ VN1( * ), VN2( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAQPS computes a step of QR factorization with column pivoting */ +/* > of a real M-by-N matrix A by using Blas-3. It tries to factorize */ +/* > NB columns from A starting from the row OFFSET+1, and updates all */ +/* > of the matrix with Blas-3 xGEMM. */ +/* > */ +/* > In some cases, due to catastrophic cancellations, it cannot */ +/* > factorize NB columns. Hence, the actual number of factorized */ +/* > columns is returned in KB. */ +/* > */ +/* > Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0 */ +/* > \endverbatim */ +/* > */ +/* > \param[in] OFFSET */ +/* > \verbatim */ +/* > OFFSET is INTEGER */ +/* > The number of rows of A that have been factorized in */ +/* > previous steps. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The number of columns to factorize. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] KB */ +/* > \verbatim */ +/* > KB is INTEGER */ +/* > The number of columns actually factorized. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, block A(OFFSET+1:M,1:KB) is the triangular */ +/* > factor obtained and block A(1:OFFSET,1:N) has been */ +/* > accordingly pivoted, but no factorized. */ +/* > The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has */ +/* > been updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] JPVT */ +/* > \verbatim */ +/* > JPVT is INTEGER array, dimension (N) */ +/* > JPVT(I) = K <==> Column K of the full matrix A has been */ +/* > permuted into position I in AP. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is REAL array, dimension (KB) */ +/* > The scalar factors of the elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VN1 */ +/* > \verbatim */ +/* > VN1 is REAL array, dimension (N) */ +/* > The vector with the partial column norms. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VN2 */ +/* > \verbatim */ +/* > VN2 is REAL array, dimension (N) */ +/* > The vector with the exact column norms. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AUXV */ +/* > \verbatim */ +/* > AUXV is REAL array, dimension (NB) */ +/* > Auxiliary vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] F */ +/* > \verbatim */ +/* > F is REAL array, dimension (LDF,NB) */ +/* > Matrix F**T = L*Y**T*A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDF */ +/* > \verbatim */ +/* > LDF is INTEGER */ +/* > The leading dimension of the array F. LDF >= f2cmax(1,N). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain */ +/* > X. Sun, Computer Science Dept., Duke University, USA */ +/* > */ +/* > \n */ +/* > Partial column norm updating strategy modified on April 2011 */ +/* > Z. Drmac and Z. Bujanovic, Dept. of Mathematics, */ +/* > University of Zagreb, Croatia. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > LAPACK Working Note 176 */ + +/* > \htmlonly */ +/* > [PDF] */ +/* > \endhtmlonly */ + +/* ===================================================================== */ +/* Subroutine */ int slaqps_(integer *m, integer *n, integer *offset, integer + *nb, integer *kb, real *a, integer *lda, integer *jpvt, real *tau, + real *vn1, real *vn2, real *auxv, real *f, integer *ldf) +{ + /* System generated locals */ + integer a_dim1, a_offset, f_dim1, f_offset, i__1, i__2; + real r__1, r__2; + + /* Local variables */ + real temp, temp2; + extern real snrm2_(integer *, real *, integer *); + integer j, k; + real tol3z; + extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *); + integer itemp; + extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *), sswap_(integer *, real *, integer *, real *, integer *); + integer rk; + extern real slamch_(char *); + extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *, + real *); + integer lsticc; + extern integer isamax_(integer *, real *, integer *); + integer lastrk; + real akk; + integer pvt; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --jpvt; + --tau; + --vn1; + --vn2; + --auxv; + f_dim1 = *ldf; + f_offset = 1 + f_dim1 * 1; + f -= f_offset; + + /* Function Body */ +/* Computing MIN */ + i__1 = *m, i__2 = *n + *offset; + lastrk = f2cmin(i__1,i__2); + lsticc = 0; + k = 0; + tol3z = sqrt(slamch_("Epsilon")); + +/* Beginning of while loop. */ + +L10: + if (k < *nb && lsticc == 0) { + ++k; + rk = *offset + k; + +/* Determine ith pivot column and swap if necessary */ + + i__1 = *n - k + 1; + pvt = k - 1 + isamax_(&i__1, &vn1[k], &c__1); + if (pvt != k) { + sswap_(m, &a[pvt * a_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + i__1 = k - 1; + sswap_(&i__1, &f[pvt + f_dim1], ldf, &f[k + f_dim1], ldf); + itemp = jpvt[pvt]; + jpvt[pvt] = jpvt[k]; + jpvt[k] = itemp; + vn1[pvt] = vn1[k]; + vn2[pvt] = vn2[k]; + } + +/* Apply previous Householder reflectors to column K: */ +/* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)**T. */ + + if (k > 1) { + i__1 = *m - rk + 1; + i__2 = k - 1; + sgemv_("No transpose", &i__1, &i__2, &c_b8, &a[rk + a_dim1], lda, + &f[k + f_dim1], ldf, &c_b9, &a[rk + k * a_dim1], &c__1); + } + +/* Generate elementary reflector H(k). */ + + if (rk < *m) { + i__1 = *m - rk + 1; + slarfg_(&i__1, &a[rk + k * a_dim1], &a[rk + 1 + k * a_dim1], & + c__1, &tau[k]); + } else { + slarfg_(&c__1, &a[rk + k * a_dim1], &a[rk + k * a_dim1], &c__1, & + tau[k]); + } + + akk = a[rk + k * a_dim1]; + a[rk + k * a_dim1] = 1.f; + +/* Compute Kth column of F: */ + +/* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)**T*A(RK:M,K). */ + + if (k < *n) { + i__1 = *m - rk + 1; + i__2 = *n - k; + sgemv_("Transpose", &i__1, &i__2, &tau[k], &a[rk + (k + 1) * + a_dim1], lda, &a[rk + k * a_dim1], &c__1, &c_b16, &f[k + + 1 + k * f_dim1], &c__1); + } + +/* Padding F(1:K,K) with zeros. */ + + i__1 = k; + for (j = 1; j <= i__1; ++j) { + f[j + k * f_dim1] = 0.f; +/* L20: */ + } + +/* Incremental updating of F: */ +/* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)**T */ +/* *A(RK:M,K). */ + + if (k > 1) { + i__1 = *m - rk + 1; + i__2 = k - 1; + r__1 = -tau[k]; + sgemv_("Transpose", &i__1, &i__2, &r__1, &a[rk + a_dim1], lda, &a[ + rk + k * a_dim1], &c__1, &c_b16, &auxv[1], &c__1); + + i__1 = k - 1; + sgemv_("No transpose", n, &i__1, &c_b9, &f[f_dim1 + 1], ldf, & + auxv[1], &c__1, &c_b9, &f[k * f_dim1 + 1], &c__1); + } + +/* Update the current row of A: */ +/* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)**T. */ + + if (k < *n) { + i__1 = *n - k; + sgemv_("No transpose", &i__1, &k, &c_b8, &f[k + 1 + f_dim1], ldf, + &a[rk + a_dim1], lda, &c_b9, &a[rk + (k + 1) * a_dim1], + lda); + } + +/* Update partial column norms. */ + + if (rk < lastrk) { + i__1 = *n; + for (j = k + 1; j <= i__1; ++j) { + if (vn1[j] != 0.f) { + +/* NOTE: The following 4 lines follow from the analysis in */ +/* Lapack Working Note 176. */ + + temp = (r__1 = a[rk + j * a_dim1], abs(r__1)) / vn1[j]; +/* Computing MAX */ + r__1 = 0.f, r__2 = (temp + 1.f) * (1.f - temp); + temp = f2cmax(r__1,r__2); +/* Computing 2nd power */ + r__1 = vn1[j] / vn2[j]; + temp2 = temp * (r__1 * r__1); + if (temp2 <= tol3z) { + vn2[j] = (real) lsticc; + lsticc = j; + } else { + vn1[j] *= sqrt(temp); + } + } +/* L30: */ + } + } + + a[rk + k * a_dim1] = akk; + +/* End of while loop. */ + + goto L10; + } + *kb = k; + rk = *offset + *kb; + +/* Apply the block reflector to the rest of the matrix: */ +/* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) - */ +/* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)**T. */ + +/* Computing MIN */ + i__1 = *n, i__2 = *m - *offset; + if (*kb < f2cmin(i__1,i__2)) { + i__1 = *m - rk; + i__2 = *n - *kb; + sgemm_("No transpose", "Transpose", &i__1, &i__2, kb, &c_b8, &a[rk + + 1 + a_dim1], lda, &f[*kb + 1 + f_dim1], ldf, &c_b9, &a[rk + 1 + + (*kb + 1) * a_dim1], lda); + } + +/* Recomputation of difficult columns. */ + +L40: + if (lsticc > 0) { + itemp = i_nint(&vn2[lsticc]); + i__1 = *m - rk; + vn1[lsticc] = snrm2_(&i__1, &a[rk + 1 + lsticc * a_dim1], &c__1); + +/* NOTE: The computation of VN1( LSTICC ) relies on the fact that */ +/* SNRM2 does not fail on vectors with norm below the value of */ +/* SQRT(DLAMCH('S')) */ + + vn2[lsticc] = vn1[lsticc]; + lsticc = itemp; + goto L40; + } + + return 0; + +/* End of SLAQPS */ + +} /* slaqps_ */ + diff --git a/lapack-netlib/SRC/slaqr0.c b/lapack-netlib/SRC/slaqr0.c new file mode 100644 index 000000000..dbbac5574 --- /dev/null +++ b/lapack-netlib/SRC/slaqr0.c @@ -0,0 +1,1219 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLAQR0 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Sc +hur decomposition. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAQR0 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, */ +/* ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) */ + +/* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N */ +/* LOGICAL WANTT, WANTZ */ +/* REAL H( LDH, * ), WI( * ), WORK( * ), WR( * ), */ +/* $ Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAQR0 computes the eigenvalues of a Hessenberg matrix H */ +/* > and, optionally, the matrices T and Z from the Schur decomposition */ +/* > H = Z T Z**T, where T is an upper quasi-triangular matrix (the */ +/* > Schur form), and Z is the orthogonal matrix of Schur vectors. */ +/* > */ +/* > Optionally Z may be postmultiplied into an input orthogonal */ +/* > matrix Q so that this routine can give the Schur factorization */ +/* > of a matrix A which has been reduced to the Hessenberg form H */ +/* > by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] WANTT */ +/* > \verbatim */ +/* > WANTT is LOGICAL */ +/* > = .TRUE. : the full Schur form T is required; */ +/* > = .FALSE.: only eigenvalues are required. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTZ */ +/* > \verbatim */ +/* > WANTZ is LOGICAL */ +/* > = .TRUE. : the matrix of Schur vectors Z is required; */ +/* > = .FALSE.: Schur vectors are not required. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix H. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILO */ +/* > \verbatim */ +/* > ILO is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHI */ +/* > \verbatim */ +/* > IHI is INTEGER */ +/* > It is assumed that H is already upper triangular in rows */ +/* > and columns 1:ILO-1 and IHI+1:N and, if ILO > 1, */ +/* > H(ILO,ILO-1) is zero. ILO and IHI are normally set by a */ +/* > previous call to SGEBAL, and then passed to SGEHRD when the */ +/* > matrix output by SGEBAL is reduced to Hessenberg form. */ +/* > Otherwise, ILO and IHI should be set to 1 and N, */ +/* > respectively. If N > 0, then 1 <= ILO <= IHI <= N. */ +/* > If N = 0, then ILO = 1 and IHI = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] H */ +/* > \verbatim */ +/* > H is REAL array, dimension (LDH,N) */ +/* > On entry, the upper Hessenberg matrix H. */ +/* > On exit, if INFO = 0 and WANTT is .TRUE., then H contains */ +/* > the upper quasi-triangular matrix T from the Schur */ +/* > decomposition (the Schur form); 2-by-2 diagonal blocks */ +/* > (corresponding to complex conjugate pairs of eigenvalues) */ +/* > are returned in standard form, with H(i,i) = H(i+1,i+1) */ +/* > and H(i+1,i)*H(i,i+1) < 0. If INFO = 0 and WANTT is */ +/* > .FALSE., then the contents of H are unspecified on exit. */ +/* > (The output value of H when INFO > 0 is given under the */ +/* > description of INFO below.) */ +/* > */ +/* > This subroutine may explicitly set H(i,j) = 0 for i > j and */ +/* > j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > The leading dimension of the array H. LDH >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WR */ +/* > \verbatim */ +/* > WR is REAL array, dimension (IHI) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WI */ +/* > \verbatim */ +/* > WI is REAL array, dimension (IHI) */ +/* > The real and imaginary parts, respectively, of the computed */ +/* > eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) */ +/* > and WI(ILO:IHI). If two eigenvalues are computed as a */ +/* > complex conjugate pair, they are stored in consecutive */ +/* > elements of WR and WI, say the i-th and (i+1)th, with */ +/* > WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., then */ +/* > the eigenvalues are stored in the same order as on the */ +/* > diagonal of the Schur form returned in H, with */ +/* > WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal */ +/* > block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and */ +/* > WI(i+1) = -WI(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILOZ */ +/* > \verbatim */ +/* > ILOZ is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHIZ */ +/* > \verbatim */ +/* > IHIZ is INTEGER */ +/* > Specify the rows of Z to which transformations must be */ +/* > applied if WANTZ is .TRUE.. */ +/* > 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension (LDZ,IHI) */ +/* > If WANTZ is .FALSE., then Z is not referenced. */ +/* > If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is */ +/* > replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the */ +/* > orthogonal Schur factor of H(ILO:IHI,ILO:IHI). */ +/* > (The output value of Z when INFO > 0 is given under */ +/* > the description of INFO below.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. if WANTZ is .TRUE. */ +/* > then LDZ >= MAX(1,IHIZ). Otherwise, LDZ >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension LWORK */ +/* > On exit, if LWORK = -1, WORK(1) returns an estimate of */ +/* > the optimal value for LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,N) */ +/* > is sufficient, but LWORK typically as large as 6*N may */ +/* > be required for optimal performance. A workspace query */ +/* > to determine the optimal workspace size is recommended. */ +/* > */ +/* > If LWORK = -1, then SLAQR0 does a workspace query. */ +/* > In this case, SLAQR0 checks the input parameters and */ +/* > estimates the optimal workspace size for the given */ +/* > values of N, ILO and IHI. The estimate is returned */ +/* > in WORK(1). No error message related to LWORK is */ +/* > issued by XERBLA. Neither H nor Z are accessed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > > 0: if INFO = i, SLAQR0 failed to compute all of */ +/* > the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */ +/* > and WI contain those eigenvalues which have been */ +/* > successfully computed. (Failures are rare.) */ +/* > */ +/* > If INFO > 0 and WANT is .FALSE., then on exit, */ +/* > the remaining unconverged eigenvalues are the eigen- */ +/* > values of the upper Hessenberg matrix rows and */ +/* > columns ILO through INFO of the final, output */ +/* > value of H. */ +/* > */ +/* > If INFO > 0 and WANTT is .TRUE., then on exit */ +/* > */ +/* > (*) (initial value of H)*U = U*(final value of H) */ +/* > */ +/* > where U is an orthogonal matrix. The final */ +/* > value of H is upper Hessenberg and quasi-triangular */ +/* > in rows and columns INFO+1 through IHI. */ +/* > */ +/* > If INFO > 0 and WANTZ is .TRUE., then on exit */ +/* > */ +/* > (final value of Z(ILO:IHI,ILOZ:IHIZ) */ +/* > = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U */ +/* > */ +/* > where U is the orthogonal matrix in (*) (regard- */ +/* > less of the value of WANTT.) */ +/* > */ +/* > If INFO > 0 and WANTZ is .FALSE., then Z is not */ +/* > accessed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Karen Braman and Ralph Byers, Department of Mathematics, */ +/* > University of Kansas, USA */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ +/* > Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */ +/* > Performance, SIAM Journal of Matrix Analysis, volume 23, pages */ +/* > 929--947, 2002. */ +/* > \n */ +/* > K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ +/* > Algorithm Part II: Aggressive Early Deflation, SIAM Journal */ +/* > of Matrix Analysis, volume 23, pages 948--973, 2002. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slaqr0_(logical *wantt, logical *wantz, integer *n, + integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real * + wi, integer *iloz, integer *ihiz, real *z__, integer *ldz, real *work, + integer *lwork, integer *info) +{ + /* System generated locals */ + integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2, r__3, r__4; + + /* Local variables */ + integer ndec, ndfl, kbot, nmin; + real swap; + integer ktop; + real zdum[1] /* was [1][1] */; + integer kacc22, i__, k, itmax, nsmax, nwmax, kwtop; + real aa, bb; + extern /* Subroutine */ int slanv2_(real *, real *, real *, real *, real * + , real *, real *, real *, real *, real *); + real cc; + extern /* Subroutine */ int slaqr3_(logical *, logical *, integer *, + integer *, integer *, integer *, real *, integer *, integer *, + integer *, real *, integer *, integer *, integer *, real *, real * + , real *, integer *, integer *, real *, integer *, integer *, + real *, integer *, real *, integer *); + real dd; + extern /* Subroutine */ int slaqr4_(logical *, logical *, integer *, + integer *, integer *, real *, integer *, real *, real *, integer * + , integer *, real *, integer *, real *, integer *, integer *), + slaqr5_(logical *, logical *, integer *, integer *, integer *, + integer *, integer *, real *, real *, real *, integer *, integer * + , integer *, real *, integer *, real *, integer *, real *, + integer *, integer *, real *, integer *, integer *, real *, + integer *); + integer ld; + real cs; + integer nh, nibble, it, ks, kt; + real sn; + integer ku, kv, ls, ns; + real ss; + integer nw; + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + char jbcmpz[2]; + extern /* Subroutine */ int slahqr_(logical *, logical *, integer *, + integer *, integer *, real *, integer *, real *, real *, integer * + , integer *, real *, integer *, integer *), slacpy_(char *, + integer *, integer *, real *, integer *, real *, integer *); + integer nwupbd; + logical sorted; + integer lwkopt, inf, kdu, nho, nve, kwh, nsr, nwr, kwv; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ================================================================ */ + +/* ==== Matrices of order NTINY or smaller must be processed by */ +/* . SLAHQR because of insufficient subdiagonal scratch space. */ +/* . (This is a hard limit.) ==== */ + +/* ==== Exceptional deflation windows: try to cure rare */ +/* . slow convergence by varying the size of the */ +/* . deflation window after KEXNW iterations. ==== */ + +/* ==== Exceptional shifts: try to cure rare slow convergence */ +/* . with ad-hoc exceptional shifts every KEXSH iterations. */ +/* . ==== */ + +/* ==== The constants WILK1 and WILK2 are used to form the */ +/* . exceptional shifts. ==== */ + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + --wr; + --wi; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + + /* Function Body */ + *info = 0; + +/* ==== Quick return for N = 0: nothing to do. ==== */ + + if (*n == 0) { + work[1] = 1.f; + return 0; + } + + if (*n <= 15) { + +/* ==== Tiny matrices must use SLAHQR. ==== */ + + lwkopt = 1; + if (*lwork != -1) { + slahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], & + wi[1], iloz, ihiz, &z__[z_offset], ldz, info); + } + } else { + +/* ==== Use small bulge multi-shift QR with aggressive early */ +/* . deflation on larger-than-tiny matrices. ==== */ + +/* ==== Hope for the best. ==== */ + + *info = 0; + +/* ==== Set up job flags for ILAENV. ==== */ + + if (*wantt) { + *(unsigned char *)jbcmpz = 'S'; + } else { + *(unsigned char *)jbcmpz = 'E'; + } + if (*wantz) { + *(unsigned char *)&jbcmpz[1] = 'V'; + } else { + *(unsigned char *)&jbcmpz[1] = 'N'; + } + +/* ==== NWR = recommended deflation window size. At this */ +/* . point, N .GT. NTINY = 15, so there is enough */ +/* . subdiagonal workspace for NWR.GE.2 as required. */ +/* . (In fact, there is enough subdiagonal space for */ +/* . NWR.GE.4.) ==== */ + + nwr = ilaenv_(&c__13, "SLAQR0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, + (ftnlen)2); + nwr = f2cmax(2,nwr); +/* Computing MIN */ + i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = f2cmin(i__1,i__2); + nwr = f2cmin(i__1,nwr); + +/* ==== NSR = recommended number of simultaneous shifts. */ +/* . At this point N .GT. NTINY = 15, so there is at */ +/* . enough subdiagonal workspace for NSR to be even */ +/* . and greater than or equal to two as required. ==== */ + + nsr = ilaenv_(&c__15, "SLAQR0", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, + (ftnlen)2); +/* Computing MIN */ + i__1 = nsr, i__2 = (*n - 3) / 6, i__1 = f2cmin(i__1,i__2), i__2 = *ihi - + *ilo; + nsr = f2cmin(i__1,i__2); +/* Computing MAX */ + i__1 = 2, i__2 = nsr - nsr % 2; + nsr = f2cmax(i__1,i__2); + +/* ==== Estimate optimal workspace ==== */ + +/* ==== Workspace query call to SLAQR3 ==== */ + + i__1 = nwr + 1; + slaqr3_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz, + ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[ + h_offset], ldh, n, &h__[h_offset], ldh, n, &h__[h_offset], + ldh, &work[1], &c_n1); + +/* ==== Optimal workspace = MAX(SLAQR5, SLAQR3) ==== */ + +/* Computing MAX */ + i__1 = nsr * 3 / 2, i__2 = (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + +/* ==== Quick return in case of workspace query. ==== */ + + if (*lwork == -1) { + work[1] = (real) lwkopt; + return 0; + } + +/* ==== SLAHQR/SLAQR0 crossover point ==== */ + + nmin = ilaenv_(&c__12, "SLAQR0", jbcmpz, n, ilo, ihi, lwork, (ftnlen) + 6, (ftnlen)2); + nmin = f2cmax(15,nmin); + +/* ==== Nibble crossover point ==== */ + + nibble = ilaenv_(&c__14, "SLAQR0", jbcmpz, n, ilo, ihi, lwork, ( + ftnlen)6, (ftnlen)2); + nibble = f2cmax(0,nibble); + +/* ==== Accumulate reflections during ttswp? Use block */ +/* . 2-by-2 structure during matrix-matrix multiply? ==== */ + + kacc22 = ilaenv_(&c__16, "SLAQR0", jbcmpz, n, ilo, ihi, lwork, ( + ftnlen)6, (ftnlen)2); + kacc22 = f2cmax(0,kacc22); + kacc22 = f2cmin(2,kacc22); + +/* ==== NWMAX = the largest possible deflation window for */ +/* . which there is sufficient workspace. ==== */ + +/* Computing MIN */ + i__1 = (*n - 1) / 3, i__2 = *lwork / 2; + nwmax = f2cmin(i__1,i__2); + nw = nwmax; + +/* ==== NSMAX = the Largest number of simultaneous shifts */ +/* . for which there is sufficient workspace. ==== */ + +/* Computing MIN */ + i__1 = (*n - 3) / 6, i__2 = (*lwork << 1) / 3; + nsmax = f2cmin(i__1,i__2); + nsmax -= nsmax % 2; + +/* ==== NDFL: an iteration count restarted at deflation. ==== */ + + ndfl = 1; + +/* ==== ITMAX = iteration limit ==== */ + +/* Computing MAX */ + i__1 = 10, i__2 = *ihi - *ilo + 1; + itmax = 30 * f2cmax(i__1,i__2); + +/* ==== Last row and column in the active block ==== */ + + kbot = *ihi; + +/* ==== Main Loop ==== */ + + i__1 = itmax; + for (it = 1; it <= i__1; ++it) { + +/* ==== Done when KBOT falls below ILO ==== */ + + if (kbot < *ilo) { + goto L90; + } + +/* ==== Locate active block ==== */ + + i__2 = *ilo + 1; + for (k = kbot; k >= i__2; --k) { + if (h__[k + (k - 1) * h_dim1] == 0.f) { + goto L20; + } +/* L10: */ + } + k = *ilo; +L20: + ktop = k; + +/* ==== Select deflation window size: */ +/* . Typical Case: */ +/* . If possible and advisable, nibble the entire */ +/* . active block. If not, use size MIN(NWR,NWMAX) */ +/* . or MIN(NWR+1,NWMAX) depending upon which has */ +/* . the smaller corresponding subdiagonal entry */ +/* . (a heuristic). */ +/* . */ +/* . Exceptional Case: */ +/* . If there have been no deflations in KEXNW or */ +/* . more iterations, then vary the deflation window */ +/* . size. At first, because, larger windows are, */ +/* . in general, more powerful than smaller ones, */ +/* . rapidly increase the window to the maximum possible. */ +/* . Then, gradually reduce the window size. ==== */ + + nh = kbot - ktop + 1; + nwupbd = f2cmin(nh,nwmax); + if (ndfl < 5) { + nw = f2cmin(nwupbd,nwr); + } else { +/* Computing MIN */ + i__2 = nwupbd, i__3 = nw << 1; + nw = f2cmin(i__2,i__3); + } + if (nw < nwmax) { + if (nw >= nh - 1) { + nw = nh; + } else { + kwtop = kbot - nw + 1; + if ((r__1 = h__[kwtop + (kwtop - 1) * h_dim1], abs(r__1)) + > (r__2 = h__[kwtop - 1 + (kwtop - 2) * h_dim1], + abs(r__2))) { + ++nw; + } + } + } + if (ndfl < 5) { + ndec = -1; + } else if (ndec >= 0 || nw >= nwupbd) { + ++ndec; + if (nw - ndec < 2) { + ndec = 0; + } + nw -= ndec; + } + +/* ==== Aggressive early deflation: */ +/* . split workspace under the subdiagonal into */ +/* . - an nw-by-nw work array V in the lower */ +/* . left-hand-corner, */ +/* . - an NW-by-at-least-NW-but-more-is-better */ +/* . (NW-by-NHO) horizontal work array along */ +/* . the bottom edge, */ +/* . - an at-least-NW-but-more-is-better (NHV-by-NW) */ +/* . vertical work array along the left-hand-edge. */ +/* . ==== */ + + kv = *n - nw + 1; + kt = nw + 1; + nho = *n - nw - 1 - kt + 1; + kwv = nw + 2; + nve = *n - nw - kwv + 1; + +/* ==== Aggressive early deflation ==== */ + + slaqr3_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh, + iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], + &h__[kv + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1], + ldh, &nve, &h__[kwv + h_dim1], ldh, &work[1], lwork); + +/* ==== Adjust KBOT accounting for new deflations. ==== */ + + kbot -= ld; + +/* ==== KS points to the shifts. ==== */ + + ks = kbot - ls + 1; + +/* ==== Skip an expensive QR sweep if there is a (partly */ +/* . heuristic) reason to expect that many eigenvalues */ +/* . will deflate without it. Here, the QR sweep is */ +/* . skipped if many eigenvalues have just been deflated */ +/* . or if the remaining active block is small. */ + + if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > f2cmin( + nmin,nwmax)) { + +/* ==== NS = nominal number of simultaneous shifts. */ +/* . This may be lowered (slightly) if SLAQR3 */ +/* . did not provide that many shifts. ==== */ + +/* Computing MIN */ +/* Computing MAX */ + i__4 = 2, i__5 = kbot - ktop; + i__2 = f2cmin(nsmax,nsr), i__3 = f2cmax(i__4,i__5); + ns = f2cmin(i__2,i__3); + ns -= ns % 2; + +/* ==== If there have been no deflations */ +/* . in a multiple of KEXSH iterations, */ +/* . then try exceptional shifts. */ +/* . Otherwise use shifts provided by */ +/* . SLAQR3 above or from the eigenvalues */ +/* . of a trailing principal submatrix. ==== */ + + if (ndfl % 6 == 0) { + ks = kbot - ns + 1; +/* Computing MAX */ + i__3 = ks + 1, i__4 = ktop + 2; + i__2 = f2cmax(i__3,i__4); + for (i__ = kbot; i__ >= i__2; i__ += -2) { + ss = (r__1 = h__[i__ + (i__ - 1) * h_dim1], abs(r__1)) + + (r__2 = h__[i__ - 1 + (i__ - 2) * h_dim1], + abs(r__2)); + aa = ss * .75f + h__[i__ + i__ * h_dim1]; + bb = ss; + cc = ss * -.4375f; + dd = aa; + slanv2_(&aa, &bb, &cc, &dd, &wr[i__ - 1], &wi[i__ - 1] + , &wr[i__], &wi[i__], &cs, &sn); +/* L30: */ + } + if (ks == ktop) { + wr[ks + 1] = h__[ks + 1 + (ks + 1) * h_dim1]; + wi[ks + 1] = 0.f; + wr[ks] = wr[ks + 1]; + wi[ks] = wi[ks + 1]; + } + } else { + +/* ==== Got NS/2 or fewer shifts? Use SLAQR4 or */ +/* . SLAHQR on a trailing principal submatrix to */ +/* . get more. (Since NS.LE.NSMAX.LE.(N-3)/6, */ +/* . there is enough space below the subdiagonal */ +/* . to fit an NS-by-NS scratch array.) ==== */ + + if (kbot - ks + 1 <= ns / 2) { + ks = kbot - ns + 1; + kt = *n - ns + 1; + slacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, & + h__[kt + h_dim1], ldh); + if (ns > nmin) { + slaqr4_(&c_false, &c_false, &ns, &c__1, &ns, &h__[ + kt + h_dim1], ldh, &wr[ks], &wi[ks], & + c__1, &c__1, zdum, &c__1, &work[1], lwork, + &inf); + } else { + slahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[ + kt + h_dim1], ldh, &wr[ks], &wi[ks], & + c__1, &c__1, zdum, &c__1, &inf); + } + ks += inf; + +/* ==== In case of a rare QR failure use */ +/* . eigenvalues of the trailing 2-by-2 */ +/* . principal submatrix. ==== */ + + if (ks >= kbot) { + aa = h__[kbot - 1 + (kbot - 1) * h_dim1]; + cc = h__[kbot + (kbot - 1) * h_dim1]; + bb = h__[kbot - 1 + kbot * h_dim1]; + dd = h__[kbot + kbot * h_dim1]; + slanv2_(&aa, &bb, &cc, &dd, &wr[kbot - 1], &wi[ + kbot - 1], &wr[kbot], &wi[kbot], &cs, &sn) + ; + ks = kbot - 1; + } + } + + if (kbot - ks + 1 > ns) { + +/* ==== Sort the shifts (Helps a little) */ +/* . Bubble sort keeps complex conjugate */ +/* . pairs together. ==== */ + + sorted = FALSE_; + i__2 = ks + 1; + for (k = kbot; k >= i__2; --k) { + if (sorted) { + goto L60; + } + sorted = TRUE_; + i__3 = k - 1; + for (i__ = ks; i__ <= i__3; ++i__) { + if ((r__1 = wr[i__], abs(r__1)) + (r__2 = wi[ + i__], abs(r__2)) < (r__3 = wr[i__ + 1] + , abs(r__3)) + (r__4 = wi[i__ + 1], + abs(r__4))) { + sorted = FALSE_; + + swap = wr[i__]; + wr[i__] = wr[i__ + 1]; + wr[i__ + 1] = swap; + + swap = wi[i__]; + wi[i__] = wi[i__ + 1]; + wi[i__ + 1] = swap; + } +/* L40: */ + } +/* L50: */ + } +L60: + ; + } + +/* ==== Shuffle shifts into pairs of real shifts */ +/* . and pairs of complex conjugate shifts */ +/* . assuming complex conjugate shifts are */ +/* . already adjacent to one another. (Yes, */ +/* . they are.) ==== */ + + i__2 = ks + 2; + for (i__ = kbot; i__ >= i__2; i__ += -2) { + if (wi[i__] != -wi[i__ - 1]) { + + swap = wr[i__]; + wr[i__] = wr[i__ - 1]; + wr[i__ - 1] = wr[i__ - 2]; + wr[i__ - 2] = swap; + + swap = wi[i__]; + wi[i__] = wi[i__ - 1]; + wi[i__ - 1] = wi[i__ - 2]; + wi[i__ - 2] = swap; + } +/* L70: */ + } + } + +/* ==== If there are only two shifts and both are */ +/* . real, then use only one. ==== */ + + if (kbot - ks + 1 == 2) { + if (wi[kbot] == 0.f) { + if ((r__1 = wr[kbot] - h__[kbot + kbot * h_dim1], abs( + r__1)) < (r__2 = wr[kbot - 1] - h__[kbot + + kbot * h_dim1], abs(r__2))) { + wr[kbot - 1] = wr[kbot]; + } else { + wr[kbot] = wr[kbot - 1]; + } + } + } + +/* ==== Use up to NS of the the smallest magnitude */ +/* . shifts. If there aren't NS shifts available, */ +/* . then use them all, possibly dropping one to */ +/* . make the number of shifts even. ==== */ + +/* Computing MIN */ + i__2 = ns, i__3 = kbot - ks + 1; + ns = f2cmin(i__2,i__3); + ns -= ns % 2; + ks = kbot - ns + 1; + +/* ==== Small-bulge multi-shift QR sweep: */ +/* . split workspace under the subdiagonal into */ +/* . - a KDU-by-KDU work array U in the lower */ +/* . left-hand-corner, */ +/* . - a KDU-by-at-least-KDU-but-more-is-better */ +/* . (KDU-by-NHo) horizontal work array WH along */ +/* . the bottom edge, */ +/* . - and an at-least-KDU-but-more-is-better-by-KDU */ +/* . (NVE-by-KDU) vertical work WV arrow along */ +/* . the left-hand-edge. ==== */ + + kdu = ns << 1; + ku = *n - kdu + 1; + kwh = kdu + 1; + nho = *n - kdu - 3 - (kdu + 1) + 1; + kwv = kdu + 4; + nve = *n - kdu - kwv + 1; + +/* ==== Small-bulge multi-shift QR sweep ==== */ + + slaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &wr[ks], + &wi[ks], &h__[h_offset], ldh, iloz, ihiz, &z__[ + z_offset], ldz, &work[1], &c__3, &h__[ku + h_dim1], + ldh, &nve, &h__[kwv + h_dim1], ldh, &nho, &h__[ku + + kwh * h_dim1], ldh); + } + +/* ==== Note progress (or the lack of it). ==== */ + + if (ld > 0) { + ndfl = 1; + } else { + ++ndfl; + } + +/* ==== End of main loop ==== */ +/* L80: */ + } + +/* ==== Iteration limit exceeded. Set INFO to show where */ +/* . the problem occurred and exit. ==== */ + + *info = kbot; +L90: + ; + } + +/* ==== Return the optimal value of LWORK. ==== */ + + work[1] = (real) lwkopt; + +/* ==== End of SLAQR0 ==== */ + + return 0; +} /* slaqr0_ */ + diff --git a/lapack-netlib/SRC/slaqr1.c b/lapack-netlib/SRC/slaqr1.c new file mode 100644 index 000000000..911b2c22f --- /dev/null +++ b/lapack-netlib/SRC/slaqr1.c @@ -0,0 +1,578 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLAQR1 sets a scalar multiple of the first column of the product of 2-by-2 or 3-by-3 matrix H a +nd specified shifts. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAQR1 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V ) */ + +/* REAL SI1, SI2, SR1, SR2 */ +/* INTEGER LDH, N */ +/* REAL H( LDH, * ), V( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Given a 2-by-2 or 3-by-3 matrix H, SLAQR1 sets v to a */ +/* > scalar multiple of the first column of the product */ +/* > */ +/* > (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I) */ +/* > */ +/* > scaling to avoid overflows and most underflows. It */ +/* > is assumed that either */ +/* > */ +/* > 1) sr1 = sr2 and si1 = -si2 */ +/* > or */ +/* > 2) si1 = si2 = 0. */ +/* > */ +/* > This is useful for starting double implicit shift bulges */ +/* > in the QR algorithm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > Order of the matrix H. N must be either 2 or 3. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] H */ +/* > \verbatim */ +/* > H is REAL array, dimension (LDH,N) */ +/* > The 2-by-2 or 3-by-3 matrix H in (*). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > The leading dimension of H as declared in */ +/* > the calling procedure. LDH >= N */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SR1 */ +/* > \verbatim */ +/* > SR1 is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SI1 */ +/* > \verbatim */ +/* > SI1 is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SR2 */ +/* > \verbatim */ +/* > SR2 is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SI2 */ +/* > \verbatim */ +/* > SI2 is REAL */ +/* > The shifts in (*). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is REAL array, dimension (N) */ +/* > A scalar multiple of the first column of the */ +/* > matrix K in (*). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Karen Braman and Ralph Byers, Department of Mathematics, */ +/* > University of Kansas, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slaqr1_(integer *n, real *h__, integer *ldh, real *sr1, + real *si1, real *sr2, real *si2, real *v) +{ + /* System generated locals */ + integer h_dim1, h_offset; + real r__1, r__2, r__3; + + /* Local variables */ + real s, h21s, h31s; + + +/* -- LAPACK auxiliary routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ================================================================ */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + --v; + + /* Function Body */ + if (*n != 2 && *n != 3) { + return 0; + } + + if (*n == 2) { + s = (r__1 = h__[h_dim1 + 1] - *sr2, abs(r__1)) + abs(*si2) + (r__2 = + h__[h_dim1 + 2], abs(r__2)); + if (s == 0.f) { + v[1] = 0.f; + v[2] = 0.f; + } else { + h21s = h__[h_dim1 + 2] / s; + v[1] = h21s * h__[(h_dim1 << 1) + 1] + (h__[h_dim1 + 1] - *sr1) * + ((h__[h_dim1 + 1] - *sr2) / s) - *si1 * (*si2 / s); + v[2] = h21s * (h__[h_dim1 + 1] + h__[(h_dim1 << 1) + 2] - *sr1 - * + sr2); + } + } else { + s = (r__1 = h__[h_dim1 + 1] - *sr2, abs(r__1)) + abs(*si2) + (r__2 = + h__[h_dim1 + 2], abs(r__2)) + (r__3 = h__[h_dim1 + 3], abs( + r__3)); + if (s == 0.f) { + v[1] = 0.f; + v[2] = 0.f; + v[3] = 0.f; + } else { + h21s = h__[h_dim1 + 2] / s; + h31s = h__[h_dim1 + 3] / s; + v[1] = (h__[h_dim1 + 1] - *sr1) * ((h__[h_dim1 + 1] - *sr2) / s) + - *si1 * (*si2 / s) + h__[(h_dim1 << 1) + 1] * h21s + h__[ + h_dim1 * 3 + 1] * h31s; + v[2] = h21s * (h__[h_dim1 + 1] + h__[(h_dim1 << 1) + 2] - *sr1 - * + sr2) + h__[h_dim1 * 3 + 2] * h31s; + v[3] = h31s * (h__[h_dim1 + 1] + h__[h_dim1 * 3 + 3] - *sr1 - * + sr2) + h21s * h__[(h_dim1 << 1) + 3]; + } + } + return 0; +} /* slaqr1_ */ + diff --git a/lapack-netlib/SRC/slaqr2.c b/lapack-netlib/SRC/slaqr2.c new file mode 100644 index 000000000..967bcaab5 --- /dev/null +++ b/lapack-netlib/SRC/slaqr2.c @@ -0,0 +1,1188 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLAQR2 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and d +eflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). +*/ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAQR2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, */ +/* IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, */ +/* LDT, NV, WV, LDWV, WORK, LWORK ) */ + +/* INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, */ +/* $ LDZ, LWORK, N, ND, NH, NS, NV, NW */ +/* LOGICAL WANTT, WANTZ */ +/* REAL H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), */ +/* $ V( LDV, * ), WORK( * ), WV( LDWV, * ), */ +/* $ Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAQR2 is identical to SLAQR3 except that it avoids */ +/* > recursion by calling SLAHQR instead of SLAQR4. */ +/* > */ +/* > Aggressive early deflation: */ +/* > */ +/* > This subroutine accepts as input an upper Hessenberg matrix */ +/* > H and performs an orthogonal similarity transformation */ +/* > designed to detect and deflate fully converged eigenvalues from */ +/* > a trailing principal submatrix. On output H has been over- */ +/* > written by a new Hessenberg matrix that is a perturbation of */ +/* > an orthogonal similarity transformation of H. It is to be */ +/* > hoped that the final version of H has many zero subdiagonal */ +/* > entries. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] WANTT */ +/* > \verbatim */ +/* > WANTT is LOGICAL */ +/* > If .TRUE., then the Hessenberg matrix H is fully updated */ +/* > so that the quasi-triangular Schur factor may be */ +/* > computed (in cooperation with the calling subroutine). */ +/* > If .FALSE., then only enough of H is updated to preserve */ +/* > the eigenvalues. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTZ */ +/* > \verbatim */ +/* > WANTZ is LOGICAL */ +/* > If .TRUE., then the orthogonal matrix Z is updated so */ +/* > so that the orthogonal Schur factor may be computed */ +/* > (in cooperation with the calling subroutine). */ +/* > If .FALSE., then Z is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix H and (if WANTZ is .TRUE.) the */ +/* > order of the orthogonal matrix Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KTOP */ +/* > \verbatim */ +/* > KTOP is INTEGER */ +/* > It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */ +/* > KBOT and KTOP together determine an isolated block */ +/* > along the diagonal of the Hessenberg matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KBOT */ +/* > \verbatim */ +/* > KBOT is INTEGER */ +/* > It is assumed without a check that either */ +/* > KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */ +/* > determine an isolated block along the diagonal of the */ +/* > Hessenberg matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NW */ +/* > \verbatim */ +/* > NW is INTEGER */ +/* > Deflation window size. 1 <= NW <= (KBOT-KTOP+1). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] H */ +/* > \verbatim */ +/* > H is REAL array, dimension (LDH,N) */ +/* > On input the initial N-by-N section of H stores the */ +/* > Hessenberg matrix undergoing aggressive early deflation. */ +/* > On output H has been transformed by an orthogonal */ +/* > similarity transformation, perturbed, and the returned */ +/* > to Hessenberg form that (it is to be hoped) has some */ +/* > zero subdiagonal entries. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > Leading dimension of H just as declared in the calling */ +/* > subroutine. N <= LDH */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILOZ */ +/* > \verbatim */ +/* > ILOZ is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHIZ */ +/* > \verbatim */ +/* > IHIZ is INTEGER */ +/* > Specify the rows of Z to which transformations must be */ +/* > applied if WANTZ is .TRUE.. 1 <= ILOZ <= IHIZ <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension (LDZ,N) */ +/* > IF WANTZ is .TRUE., then on output, the orthogonal */ +/* > similarity transformation mentioned above has been */ +/* > accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. */ +/* > If WANTZ is .FALSE., then Z is unreferenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of Z just as declared in the */ +/* > calling subroutine. 1 <= LDZ. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] NS */ +/* > \verbatim */ +/* > NS is INTEGER */ +/* > The number of unconverged (ie approximate) eigenvalues */ +/* > returned in SR and SI that may be used as shifts by the */ +/* > calling subroutine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ND */ +/* > \verbatim */ +/* > ND is INTEGER */ +/* > The number of converged eigenvalues uncovered by this */ +/* > subroutine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SR */ +/* > \verbatim */ +/* > SR is REAL array, dimension (KBOT) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SI */ +/* > \verbatim */ +/* > SI is REAL array, dimension (KBOT) */ +/* > On output, the real and imaginary parts of approximate */ +/* > eigenvalues that may be used for shifts are stored in */ +/* > SR(KBOT-ND-NS+1) through SR(KBOT-ND) and */ +/* > SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. */ +/* > The real and imaginary parts of converged eigenvalues */ +/* > are stored in SR(KBOT-ND+1) through SR(KBOT) and */ +/* > SI(KBOT-ND+1) through SI(KBOT), respectively. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is REAL array, dimension (LDV,NW) */ +/* > An NW-by-NW work array. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of V just as declared in the */ +/* > calling subroutine. NW <= LDV */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NH */ +/* > \verbatim */ +/* > NH is INTEGER */ +/* > The number of columns of T. NH >= NW. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is REAL array, dimension (LDT,NW) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of T just as declared in the */ +/* > calling subroutine. NW <= LDT */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NV */ +/* > \verbatim */ +/* > NV is INTEGER */ +/* > The number of rows of work array WV available for */ +/* > workspace. NV >= NW. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WV */ +/* > \verbatim */ +/* > WV is REAL array, dimension (LDWV,NW) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDWV */ +/* > \verbatim */ +/* > LDWV is INTEGER */ +/* > The leading dimension of W just as declared in the */ +/* > calling subroutine. NW <= LDV */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (LWORK) */ +/* > On exit, WORK(1) is set to an estimate of the optimal value */ +/* > of LWORK for the given values of N, NW, KTOP and KBOT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the work array WORK. LWORK = 2*NW */ +/* > suffices, but greater efficiency may result from larger */ +/* > values of LWORK. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; SLAQR2 */ +/* > only estimates the optimal workspace size for the given */ +/* > values of N, NW, KTOP and KBOT. The estimate is returned */ +/* > in WORK(1). No error message related to LWORK is issued */ +/* > by XERBLA. Neither H nor Z are accessed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Karen Braman and Ralph Byers, Department of Mathematics, */ +/* > University of Kansas, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slaqr2_(logical *wantt, logical *wantz, integer *n, + integer *ktop, integer *kbot, integer *nw, real *h__, integer *ldh, + integer *iloz, integer *ihiz, real *z__, integer *ldz, integer *ns, + integer *nd, real *sr, real *si, real *v, integer *ldv, integer *nh, + real *t, integer *ldt, integer *nv, real *wv, integer *ldwv, real * + work, integer *lwork) +{ + /* System generated locals */ + integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1, + wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4; + real r__1, r__2, r__3, r__4, r__5, r__6; + + /* Local variables */ + real beta; + integer kend, kcol, info, ifst, ilst, ltop, krow, i__, j, k; + real s; + logical bulge; + extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *, + integer *, real *, real *, integer *, real *), sgemm_( + char *, char *, integer *, integer *, integer *, real *, real *, + integer *, real *, integer *, real *, real *, integer *); + integer infqr; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + integer kwtop; + real aa, bb, cc; + extern /* Subroutine */ int slanv2_(real *, real *, real *, real *, real * + , real *, real *, real *, real *, real *); + real dd, cs; + extern /* Subroutine */ int slabad_(real *, real *); + real sn; + integer jw; + extern real slamch_(char *); + extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real + *, integer *, real *, real *, integer *, integer *); + real safmin, safmax; + extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *, + real *), slahqr_(logical *, logical *, integer *, integer *, + integer *, real *, integer *, real *, real *, integer *, integer * + , real *, integer *, integer *), slacpy_(char *, integer *, + integer *, real *, integer *, real *, integer *), slaset_( + char *, integer *, integer *, real *, real *, real *, integer *); + logical sorted; + extern /* Subroutine */ int strexc_(char *, integer *, real *, integer *, + real *, integer *, integer *, integer *, real *, integer *), sormhr_(char *, char *, integer *, integer *, integer *, + integer *, real *, integer *, real *, real *, integer *, real *, + integer *, integer *); + real smlnum; + integer lwkopt; + real evi, evk, foo; + integer kln; + real tau, ulp; + integer lwk1, lwk2; + + +/* -- LAPACK auxiliary routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ================================================================ */ + +/* ==== Estimate optimal workspace. ==== */ + + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --sr; + --si; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + wv_dim1 = *ldwv; + wv_offset = 1 + wv_dim1 * 1; + wv -= wv_offset; + --work; + + /* Function Body */ +/* Computing MIN */ + i__1 = *nw, i__2 = *kbot - *ktop + 1; + jw = f2cmin(i__1,i__2); + if (jw <= 2) { + lwkopt = 1; + } else { + +/* ==== Workspace query call to SGEHRD ==== */ + + i__1 = jw - 1; + sgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & + c_n1, &info); + lwk1 = (integer) work[1]; + +/* ==== Workspace query call to SORMHR ==== */ + + i__1 = jw - 1; + sormhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], + &v[v_offset], ldv, &work[1], &c_n1, &info); + lwk2 = (integer) work[1]; + +/* ==== Optimal workspace ==== */ + + lwkopt = jw + f2cmax(lwk1,lwk2); + } + +/* ==== Quick return in case of workspace query. ==== */ + + if (*lwork == -1) { + work[1] = (real) lwkopt; + return 0; + } + +/* ==== Nothing to do ... */ +/* ... for an empty active block ... ==== */ + *ns = 0; + *nd = 0; + work[1] = 1.f; + if (*ktop > *kbot) { + return 0; + } +/* ... nor for an empty deflation window. ==== */ + if (*nw < 1) { + return 0; + } + +/* ==== Machine constants ==== */ + + safmin = slamch_("SAFE MINIMUM"); + safmax = 1.f / safmin; + slabad_(&safmin, &safmax); + ulp = slamch_("PRECISION"); + smlnum = safmin * ((real) (*n) / ulp); + +/* ==== Setup deflation window ==== */ + +/* Computing MIN */ + i__1 = *nw, i__2 = *kbot - *ktop + 1; + jw = f2cmin(i__1,i__2); + kwtop = *kbot - jw + 1; + if (kwtop == *ktop) { + s = 0.f; + } else { + s = h__[kwtop + (kwtop - 1) * h_dim1]; + } + + if (*kbot == kwtop) { + +/* ==== 1-by-1 deflation window: not much to do ==== */ + + sr[kwtop] = h__[kwtop + kwtop * h_dim1]; + si[kwtop] = 0.f; + *ns = 1; + *nd = 0; +/* Computing MAX */ + r__2 = smlnum, r__3 = ulp * (r__1 = h__[kwtop + kwtop * h_dim1], abs( + r__1)); + if (abs(s) <= f2cmax(r__2,r__3)) { + *ns = 0; + *nd = 1; + if (kwtop > *ktop) { + h__[kwtop + (kwtop - 1) * h_dim1] = 0.f; + } + } + work[1] = 1.f; + return 0; + } + +/* ==== Convert to spike-triangular form. (In case of a */ +/* . rare QR failure, this routine continues to do */ +/* . aggressive early deflation using that part of */ +/* . the deflation window that converged using INFQR */ +/* . here and there to keep track.) ==== */ + + slacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset], + ldt); + i__1 = jw - 1; + i__2 = *ldh + 1; + i__3 = *ldt + 1; + scopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], & + i__3); + + slaset_("A", &jw, &jw, &c_b12, &c_b13, &v[v_offset], ldv); + slahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[kwtop], + &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr); + +/* ==== STREXC needs a clean margin near the diagonal ==== */ + + i__1 = jw - 3; + for (j = 1; j <= i__1; ++j) { + t[j + 2 + j * t_dim1] = 0.f; + t[j + 3 + j * t_dim1] = 0.f; +/* L10: */ + } + if (jw > 2) { + t[jw + (jw - 2) * t_dim1] = 0.f; + } + +/* ==== Deflation detection loop ==== */ + + *ns = jw; + ilst = infqr + 1; +L20: + if (ilst <= *ns) { + if (*ns == 1) { + bulge = FALSE_; + } else { + bulge = t[*ns + (*ns - 1) * t_dim1] != 0.f; + } + +/* ==== Small spike tip test for deflation ==== */ + + if (! bulge) { + +/* ==== Real eigenvalue ==== */ + + foo = (r__1 = t[*ns + *ns * t_dim1], abs(r__1)); + if (foo == 0.f) { + foo = abs(s); + } +/* Computing MAX */ + r__2 = smlnum, r__3 = ulp * foo; + if ((r__1 = s * v[*ns * v_dim1 + 1], abs(r__1)) <= f2cmax(r__2,r__3)) + { + +/* ==== Deflatable ==== */ + + --(*ns); + } else { + +/* ==== Undeflatable. Move it up out of the way. */ +/* . (STREXC can not fail in this case.) ==== */ + + ifst = *ns; + strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, + &ilst, &work[1], &info); + ++ilst; + } + } else { + +/* ==== Complex conjugate pair ==== */ + + foo = (r__3 = t[*ns + *ns * t_dim1], abs(r__3)) + sqrt((r__1 = t[* + ns + (*ns - 1) * t_dim1], abs(r__1))) * sqrt((r__2 = t[* + ns - 1 + *ns * t_dim1], abs(r__2))); + if (foo == 0.f) { + foo = abs(s); + } +/* Computing MAX */ + r__3 = (r__1 = s * v[*ns * v_dim1 + 1], abs(r__1)), r__4 = (r__2 = + s * v[(*ns - 1) * v_dim1 + 1], abs(r__2)); +/* Computing MAX */ + r__5 = smlnum, r__6 = ulp * foo; + if (f2cmax(r__3,r__4) <= f2cmax(r__5,r__6)) { + +/* ==== Deflatable ==== */ + + *ns += -2; + } else { + +/* ==== Undeflatable. Move them up out of the way. */ +/* . Fortunately, STREXC does the right thing with */ +/* . ILST in case of a rare exchange failure. ==== */ + + ifst = *ns; + strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, + &ilst, &work[1], &info); + ilst += 2; + } + } + +/* ==== End deflation detection loop ==== */ + + goto L20; + } + +/* ==== Return to Hessenberg form ==== */ + + if (*ns == 0) { + s = 0.f; + } + + if (*ns < jw) { + +/* ==== sorting diagonal blocks of T improves accuracy for */ +/* . graded matrices. Bubble sort deals well with */ +/* . exchange failures. ==== */ + + sorted = FALSE_; + i__ = *ns + 1; +L30: + if (sorted) { + goto L50; + } + sorted = TRUE_; + + kend = i__ - 1; + i__ = infqr + 1; + if (i__ == *ns) { + k = i__ + 1; + } else if (t[i__ + 1 + i__ * t_dim1] == 0.f) { + k = i__ + 1; + } else { + k = i__ + 2; + } +L40: + if (k <= kend) { + if (k == i__ + 1) { + evi = (r__1 = t[i__ + i__ * t_dim1], abs(r__1)); + } else { + evi = (r__3 = t[i__ + i__ * t_dim1], abs(r__3)) + sqrt((r__1 = + t[i__ + 1 + i__ * t_dim1], abs(r__1))) * sqrt((r__2 = + t[i__ + (i__ + 1) * t_dim1], abs(r__2))); + } + + if (k == kend) { + evk = (r__1 = t[k + k * t_dim1], abs(r__1)); + } else if (t[k + 1 + k * t_dim1] == 0.f) { + evk = (r__1 = t[k + k * t_dim1], abs(r__1)); + } else { + evk = (r__3 = t[k + k * t_dim1], abs(r__3)) + sqrt((r__1 = t[ + k + 1 + k * t_dim1], abs(r__1))) * sqrt((r__2 = t[k + + (k + 1) * t_dim1], abs(r__2))); + } + + if (evi >= evk) { + i__ = k; + } else { + sorted = FALSE_; + ifst = i__; + ilst = k; + strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, + &ilst, &work[1], &info); + if (info == 0) { + i__ = ilst; + } else { + i__ = k; + } + } + if (i__ == kend) { + k = i__ + 1; + } else if (t[i__ + 1 + i__ * t_dim1] == 0.f) { + k = i__ + 1; + } else { + k = i__ + 2; + } + goto L40; + } + goto L30; +L50: + ; + } + +/* ==== Restore shift/eigenvalue array from T ==== */ + + i__ = jw; +L60: + if (i__ >= infqr + 1) { + if (i__ == infqr + 1) { + sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; + si[kwtop + i__ - 1] = 0.f; + --i__; + } else if (t[i__ + (i__ - 1) * t_dim1] == 0.f) { + sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; + si[kwtop + i__ - 1] = 0.f; + --i__; + } else { + aa = t[i__ - 1 + (i__ - 1) * t_dim1]; + cc = t[i__ + (i__ - 1) * t_dim1]; + bb = t[i__ - 1 + i__ * t_dim1]; + dd = t[i__ + i__ * t_dim1]; + slanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__ + - 2], &sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, & + sn); + i__ += -2; + } + goto L60; + } + + if (*ns < jw || s == 0.f) { + if (*ns > 1 && s != 0.f) { + +/* ==== Reflect spike back into lower triangle ==== */ + + scopy_(ns, &v[v_offset], ldv, &work[1], &c__1); + beta = work[1]; + slarfg_(ns, &beta, &work[2], &c__1, &tau); + work[1] = 1.f; + + i__1 = jw - 2; + i__2 = jw - 2; + slaset_("L", &i__1, &i__2, &c_b12, &c_b12, &t[t_dim1 + 3], ldt); + + slarf_("L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, & + work[jw + 1]); + slarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, & + work[jw + 1]); + slarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, & + work[jw + 1]); + + i__1 = *lwork - jw; + sgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1] + , &i__1, &info); + } + +/* ==== Copy updated reduced window into place ==== */ + + if (kwtop > 1) { + h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1]; + } + slacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1] + , ldh); + i__1 = jw - 1; + i__2 = *ldt + 1; + i__3 = *ldh + 1; + scopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1], + &i__3); + +/* ==== Accumulate orthogonal matrix in order update */ +/* . H and Z, if requested. ==== */ + + if (*ns > 1 && s != 0.f) { + i__1 = *lwork - jw; + sormhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1], + &v[v_offset], ldv, &work[jw + 1], &i__1, &info); + } + +/* ==== Update vertical slab in H ==== */ + + if (*wantt) { + ltop = 1; + } else { + ltop = *ktop; + } + i__1 = kwtop - 1; + i__2 = *nv; + for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += + i__2) { +/* Computing MIN */ + i__3 = *nv, i__4 = kwtop - krow; + kln = f2cmin(i__3,i__4); + sgemm_("N", "N", &kln, &jw, &jw, &c_b13, &h__[krow + kwtop * + h_dim1], ldh, &v[v_offset], ldv, &c_b12, &wv[wv_offset], + ldwv); + slacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * + h_dim1], ldh); +/* L70: */ + } + +/* ==== Update horizontal slab in H ==== */ + + if (*wantt) { + i__2 = *n; + i__1 = *nh; + for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2; + kcol += i__1) { +/* Computing MIN */ + i__3 = *nh, i__4 = *n - kcol + 1; + kln = f2cmin(i__3,i__4); + sgemm_("C", "N", &jw, &kln, &jw, &c_b13, &v[v_offset], ldv, & + h__[kwtop + kcol * h_dim1], ldh, &c_b12, &t[t_offset], + ldt); + slacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * + h_dim1], ldh); +/* L80: */ + } + } + +/* ==== Update vertical slab in Z ==== */ + + if (*wantz) { + i__1 = *ihiz; + i__2 = *nv; + for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += + i__2) { +/* Computing MIN */ + i__3 = *nv, i__4 = *ihiz - krow + 1; + kln = f2cmin(i__3,i__4); + sgemm_("N", "N", &kln, &jw, &jw, &c_b13, &z__[krow + kwtop * + z_dim1], ldz, &v[v_offset], ldv, &c_b12, &wv[ + wv_offset], ldwv); + slacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + + kwtop * z_dim1], ldz); +/* L90: */ + } + } + } + +/* ==== Return the number of deflations ... ==== */ + + *nd = jw - *ns; + +/* ==== ... and the number of shifts. (Subtracting */ +/* . INFQR from the spike length takes care */ +/* . of the case of a rare QR failure while */ +/* . calculating eigenvalues of the deflation */ +/* . window.) ==== */ + + *ns -= infqr; + +/* ==== Return optimal workspace. ==== */ + + work[1] = (real) lwkopt; + +/* ==== End of SLAQR2 ==== */ + + return 0; +} /* slaqr2_ */ + diff --git a/lapack-netlib/SRC/slaqr3.c b/lapack-netlib/SRC/slaqr3.c new file mode 100644 index 000000000..17eed4383 --- /dev/null +++ b/lapack-netlib/SRC/slaqr3.c @@ -0,0 +1,1209 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAQR3 performs the orthogonal similarity transformation of a Hessenberg matrix to detect and d +eflate fully converged eigenvalues from a trailing principal submatrix (aggressive early deflation). +*/ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAQR3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ, */ +/* IHIZ, Z, LDZ, NS, ND, SR, SI, V, LDV, NH, T, */ +/* LDT, NV, WV, LDWV, WORK, LWORK ) */ + +/* INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV, */ +/* $ LDZ, LWORK, N, ND, NH, NS, NV, NW */ +/* LOGICAL WANTT, WANTZ */ +/* REAL H( LDH, * ), SI( * ), SR( * ), T( LDT, * ), */ +/* $ V( LDV, * ), WORK( * ), WV( LDWV, * ), */ +/* $ Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Aggressive early deflation: */ +/* > */ +/* > SLAQR3 accepts as input an upper Hessenberg matrix */ +/* > H and performs an orthogonal similarity transformation */ +/* > designed to detect and deflate fully converged eigenvalues from */ +/* > a trailing principal submatrix. On output H has been over- */ +/* > written by a new Hessenberg matrix that is a perturbation of */ +/* > an orthogonal similarity transformation of H. It is to be */ +/* > hoped that the final version of H has many zero subdiagonal */ +/* > entries. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] WANTT */ +/* > \verbatim */ +/* > WANTT is LOGICAL */ +/* > If .TRUE., then the Hessenberg matrix H is fully updated */ +/* > so that the quasi-triangular Schur factor may be */ +/* > computed (in cooperation with the calling subroutine). */ +/* > If .FALSE., then only enough of H is updated to preserve */ +/* > the eigenvalues. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTZ */ +/* > \verbatim */ +/* > WANTZ is LOGICAL */ +/* > If .TRUE., then the orthogonal matrix Z is updated so */ +/* > so that the orthogonal Schur factor may be computed */ +/* > (in cooperation with the calling subroutine). */ +/* > If .FALSE., then Z is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix H and (if WANTZ is .TRUE.) the */ +/* > order of the orthogonal matrix Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KTOP */ +/* > \verbatim */ +/* > KTOP is INTEGER */ +/* > It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0. */ +/* > KBOT and KTOP together determine an isolated block */ +/* > along the diagonal of the Hessenberg matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KBOT */ +/* > \verbatim */ +/* > KBOT is INTEGER */ +/* > It is assumed without a check that either */ +/* > KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together */ +/* > determine an isolated block along the diagonal of the */ +/* > Hessenberg matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NW */ +/* > \verbatim */ +/* > NW is INTEGER */ +/* > Deflation window size. 1 <= NW <= (KBOT-KTOP+1). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] H */ +/* > \verbatim */ +/* > H is REAL array, dimension (LDH,N) */ +/* > On input the initial N-by-N section of H stores the */ +/* > Hessenberg matrix undergoing aggressive early deflation. */ +/* > On output H has been transformed by an orthogonal */ +/* > similarity transformation, perturbed, and the returned */ +/* > to Hessenberg form that (it is to be hoped) has some */ +/* > zero subdiagonal entries. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > Leading dimension of H just as declared in the calling */ +/* > subroutine. N <= LDH */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILOZ */ +/* > \verbatim */ +/* > ILOZ is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHIZ */ +/* > \verbatim */ +/* > IHIZ is INTEGER */ +/* > Specify the rows of Z to which transformations must be */ +/* > applied if WANTZ is .TRUE.. 1 <= ILOZ <= IHIZ <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension (LDZ,N) */ +/* > IF WANTZ is .TRUE., then on output, the orthogonal */ +/* > similarity transformation mentioned above has been */ +/* > accumulated into Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. */ +/* > If WANTZ is .FALSE., then Z is unreferenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of Z just as declared in the */ +/* > calling subroutine. 1 <= LDZ. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] NS */ +/* > \verbatim */ +/* > NS is INTEGER */ +/* > The number of unconverged (ie approximate) eigenvalues */ +/* > returned in SR and SI that may be used as shifts by the */ +/* > calling subroutine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ND */ +/* > \verbatim */ +/* > ND is INTEGER */ +/* > The number of converged eigenvalues uncovered by this */ +/* > subroutine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SR */ +/* > \verbatim */ +/* > SR is REAL array, dimension (KBOT) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SI */ +/* > \verbatim */ +/* > SI is REAL array, dimension (KBOT) */ +/* > On output, the real and imaginary parts of approximate */ +/* > eigenvalues that may be used for shifts are stored in */ +/* > SR(KBOT-ND-NS+1) through SR(KBOT-ND) and */ +/* > SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively. */ +/* > The real and imaginary parts of converged eigenvalues */ +/* > are stored in SR(KBOT-ND+1) through SR(KBOT) and */ +/* > SI(KBOT-ND+1) through SI(KBOT), respectively. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is REAL array, dimension (LDV,NW) */ +/* > An NW-by-NW work array. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of V just as declared in the */ +/* > calling subroutine. NW <= LDV */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NH */ +/* > \verbatim */ +/* > NH is INTEGER */ +/* > The number of columns of T. NH >= NW. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is REAL array, dimension (LDT,NW) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of T just as declared in the */ +/* > calling subroutine. NW <= LDT */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NV */ +/* > \verbatim */ +/* > NV is INTEGER */ +/* > The number of rows of work array WV available for */ +/* > workspace. NV >= NW. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WV */ +/* > \verbatim */ +/* > WV is REAL array, dimension (LDWV,NW) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDWV */ +/* > \verbatim */ +/* > LDWV is INTEGER */ +/* > The leading dimension of W just as declared in the */ +/* > calling subroutine. NW <= LDV */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (LWORK) */ +/* > On exit, WORK(1) is set to an estimate of the optimal value */ +/* > of LWORK for the given values of N, NW, KTOP and KBOT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the work array WORK. LWORK = 2*NW */ +/* > suffices, but greater efficiency may result from larger */ +/* > values of LWORK. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; SLAQR3 */ +/* > only estimates the optimal workspace size for the given */ +/* > values of N, NW, KTOP and KBOT. The estimate is returned */ +/* > in WORK(1). No error message related to LWORK is issued */ +/* > by XERBLA. Neither H nor Z are accessed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Karen Braman and Ralph Byers, Department of Mathematics, */ +/* > University of Kansas, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slaqr3_(logical *wantt, logical *wantz, integer *n, + integer *ktop, integer *kbot, integer *nw, real *h__, integer *ldh, + integer *iloz, integer *ihiz, real *z__, integer *ldz, integer *ns, + integer *nd, real *sr, real *si, real *v, integer *ldv, integer *nh, + real *t, integer *ldt, integer *nv, real *wv, integer *ldwv, real * + work, integer *lwork) +{ + /* System generated locals */ + integer h_dim1, h_offset, t_dim1, t_offset, v_dim1, v_offset, wv_dim1, + wv_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4; + real r__1, r__2, r__3, r__4, r__5, r__6; + + /* Local variables */ + real beta; + integer kend, kcol, info, nmin, ifst, ilst, ltop, krow, i__, j, k; + real s; + logical bulge; + extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *, + integer *, real *, real *, integer *, real *), sgemm_( + char *, char *, integer *, integer *, integer *, real *, real *, + integer *, real *, integer *, real *, real *, integer *); + integer infqr; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + integer kwtop; + real aa, bb, cc; + extern /* Subroutine */ int slanv2_(real *, real *, real *, real *, real * + , real *, real *, real *, real *, real *); + real dd; + extern /* Subroutine */ int slaqr4_(logical *, logical *, integer *, + integer *, integer *, real *, integer *, real *, real *, integer * + , integer *, real *, integer *, real *, integer *, integer *); + real cs; + extern /* Subroutine */ int slabad_(real *, real *); + real sn; + integer jw; + extern real slamch_(char *); + extern /* Subroutine */ int sgehrd_(integer *, integer *, integer *, real + *, integer *, real *, real *, integer *, integer *); + real safmin, safmax; + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *, + real *), slahqr_(logical *, logical *, integer *, integer *, + integer *, real *, integer *, real *, real *, integer *, integer * + , real *, integer *, integer *), slacpy_(char *, integer *, + integer *, real *, integer *, real *, integer *), slaset_( + char *, integer *, integer *, real *, real *, real *, integer *); + logical sorted; + extern /* Subroutine */ int strexc_(char *, integer *, real *, integer *, + real *, integer *, integer *, integer *, real *, integer *), sormhr_(char *, char *, integer *, integer *, integer *, + integer *, real *, integer *, real *, real *, integer *, real *, + integer *, integer *); + real smlnum; + integer lwkopt; + real evi, evk, foo; + integer kln; + real tau, ulp; + integer lwk1, lwk2, lwk3; + + +/* -- LAPACK auxiliary routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ================================================================ */ + +/* ==== Estimate optimal workspace. ==== */ + + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --sr; + --si; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + wv_dim1 = *ldwv; + wv_offset = 1 + wv_dim1 * 1; + wv -= wv_offset; + --work; + + /* Function Body */ +/* Computing MIN */ + i__1 = *nw, i__2 = *kbot - *ktop + 1; + jw = f2cmin(i__1,i__2); + if (jw <= 2) { + lwkopt = 1; + } else { + +/* ==== Workspace query call to SGEHRD ==== */ + + i__1 = jw - 1; + sgehrd_(&jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], &work[1], & + c_n1, &info); + lwk1 = (integer) work[1]; + +/* ==== Workspace query call to SORMHR ==== */ + + i__1 = jw - 1; + sormhr_("R", "N", &jw, &jw, &c__1, &i__1, &t[t_offset], ldt, &work[1], + &v[v_offset], ldv, &work[1], &c_n1, &info); + lwk2 = (integer) work[1]; + +/* ==== Workspace query call to SLAQR4 ==== */ + + slaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[1], + &si[1], &c__1, &jw, &v[v_offset], ldv, &work[1], &c_n1, & + infqr); + lwk3 = (integer) work[1]; + +/* ==== Optimal workspace ==== */ + +/* Computing MAX */ + i__1 = jw + f2cmax(lwk1,lwk2); + lwkopt = f2cmax(i__1,lwk3); + } + +/* ==== Quick return in case of workspace query. ==== */ + + if (*lwork == -1) { + work[1] = (real) lwkopt; + return 0; + } + +/* ==== Nothing to do ... */ +/* ... for an empty active block ... ==== */ + *ns = 0; + *nd = 0; + work[1] = 1.f; + if (*ktop > *kbot) { + return 0; + } +/* ... nor for an empty deflation window. ==== */ + if (*nw < 1) { + return 0; + } + +/* ==== Machine constants ==== */ + + safmin = slamch_("SAFE MINIMUM"); + safmax = 1.f / safmin; + slabad_(&safmin, &safmax); + ulp = slamch_("PRECISION"); + smlnum = safmin * ((real) (*n) / ulp); + +/* ==== Setup deflation window ==== */ + +/* Computing MIN */ + i__1 = *nw, i__2 = *kbot - *ktop + 1; + jw = f2cmin(i__1,i__2); + kwtop = *kbot - jw + 1; + if (kwtop == *ktop) { + s = 0.f; + } else { + s = h__[kwtop + (kwtop - 1) * h_dim1]; + } + + if (*kbot == kwtop) { + +/* ==== 1-by-1 deflation window: not much to do ==== */ + + sr[kwtop] = h__[kwtop + kwtop * h_dim1]; + si[kwtop] = 0.f; + *ns = 1; + *nd = 0; +/* Computing MAX */ + r__2 = smlnum, r__3 = ulp * (r__1 = h__[kwtop + kwtop * h_dim1], abs( + r__1)); + if (abs(s) <= f2cmax(r__2,r__3)) { + *ns = 0; + *nd = 1; + if (kwtop > *ktop) { + h__[kwtop + (kwtop - 1) * h_dim1] = 0.f; + } + } + work[1] = 1.f; + return 0; + } + +/* ==== Convert to spike-triangular form. (In case of a */ +/* . rare QR failure, this routine continues to do */ +/* . aggressive early deflation using that part of */ +/* . the deflation window that converged using INFQR */ +/* . here and there to keep track.) ==== */ + + slacpy_("U", &jw, &jw, &h__[kwtop + kwtop * h_dim1], ldh, &t[t_offset], + ldt); + i__1 = jw - 1; + i__2 = *ldh + 1; + i__3 = *ldt + 1; + scopy_(&i__1, &h__[kwtop + 1 + kwtop * h_dim1], &i__2, &t[t_dim1 + 2], & + i__3); + + slaset_("A", &jw, &jw, &c_b17, &c_b18, &v[v_offset], ldv); + nmin = ilaenv_(&c__12, "SLAQR3", "SV", &jw, &c__1, &jw, lwork, (ftnlen)6, + (ftnlen)2); + if (jw > nmin) { + slaqr4_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[ + kwtop], &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &work[1], + lwork, &infqr); + } else { + slahqr_(&c_true, &c_true, &jw, &c__1, &jw, &t[t_offset], ldt, &sr[ + kwtop], &si[kwtop], &c__1, &jw, &v[v_offset], ldv, &infqr); + } + +/* ==== STREXC needs a clean margin near the diagonal ==== */ + + i__1 = jw - 3; + for (j = 1; j <= i__1; ++j) { + t[j + 2 + j * t_dim1] = 0.f; + t[j + 3 + j * t_dim1] = 0.f; +/* L10: */ + } + if (jw > 2) { + t[jw + (jw - 2) * t_dim1] = 0.f; + } + +/* ==== Deflation detection loop ==== */ + + *ns = jw; + ilst = infqr + 1; +L20: + if (ilst <= *ns) { + if (*ns == 1) { + bulge = FALSE_; + } else { + bulge = t[*ns + (*ns - 1) * t_dim1] != 0.f; + } + +/* ==== Small spike tip test for deflation ==== */ + + if (! bulge) { + +/* ==== Real eigenvalue ==== */ + + foo = (r__1 = t[*ns + *ns * t_dim1], abs(r__1)); + if (foo == 0.f) { + foo = abs(s); + } +/* Computing MAX */ + r__2 = smlnum, r__3 = ulp * foo; + if ((r__1 = s * v[*ns * v_dim1 + 1], abs(r__1)) <= f2cmax(r__2,r__3)) + { + +/* ==== Deflatable ==== */ + + --(*ns); + } else { + +/* ==== Undeflatable. Move it up out of the way. */ +/* . (STREXC can not fail in this case.) ==== */ + + ifst = *ns; + strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, + &ilst, &work[1], &info); + ++ilst; + } + } else { + +/* ==== Complex conjugate pair ==== */ + + foo = (r__3 = t[*ns + *ns * t_dim1], abs(r__3)) + sqrt((r__1 = t[* + ns + (*ns - 1) * t_dim1], abs(r__1))) * sqrt((r__2 = t[* + ns - 1 + *ns * t_dim1], abs(r__2))); + if (foo == 0.f) { + foo = abs(s); + } +/* Computing MAX */ + r__3 = (r__1 = s * v[*ns * v_dim1 + 1], abs(r__1)), r__4 = (r__2 = + s * v[(*ns - 1) * v_dim1 + 1], abs(r__2)); +/* Computing MAX */ + r__5 = smlnum, r__6 = ulp * foo; + if (f2cmax(r__3,r__4) <= f2cmax(r__5,r__6)) { + +/* ==== Deflatable ==== */ + + *ns += -2; + } else { + +/* ==== Undeflatable. Move them up out of the way. */ +/* . Fortunately, STREXC does the right thing with */ +/* . ILST in case of a rare exchange failure. ==== */ + + ifst = *ns; + strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, + &ilst, &work[1], &info); + ilst += 2; + } + } + +/* ==== End deflation detection loop ==== */ + + goto L20; + } + +/* ==== Return to Hessenberg form ==== */ + + if (*ns == 0) { + s = 0.f; + } + + if (*ns < jw) { + +/* ==== sorting diagonal blocks of T improves accuracy for */ +/* . graded matrices. Bubble sort deals well with */ +/* . exchange failures. ==== */ + + sorted = FALSE_; + i__ = *ns + 1; +L30: + if (sorted) { + goto L50; + } + sorted = TRUE_; + + kend = i__ - 1; + i__ = infqr + 1; + if (i__ == *ns) { + k = i__ + 1; + } else if (t[i__ + 1 + i__ * t_dim1] == 0.f) { + k = i__ + 1; + } else { + k = i__ + 2; + } +L40: + if (k <= kend) { + if (k == i__ + 1) { + evi = (r__1 = t[i__ + i__ * t_dim1], abs(r__1)); + } else { + evi = (r__3 = t[i__ + i__ * t_dim1], abs(r__3)) + sqrt((r__1 = + t[i__ + 1 + i__ * t_dim1], abs(r__1))) * sqrt((r__2 = + t[i__ + (i__ + 1) * t_dim1], abs(r__2))); + } + + if (k == kend) { + evk = (r__1 = t[k + k * t_dim1], abs(r__1)); + } else if (t[k + 1 + k * t_dim1] == 0.f) { + evk = (r__1 = t[k + k * t_dim1], abs(r__1)); + } else { + evk = (r__3 = t[k + k * t_dim1], abs(r__3)) + sqrt((r__1 = t[ + k + 1 + k * t_dim1], abs(r__1))) * sqrt((r__2 = t[k + + (k + 1) * t_dim1], abs(r__2))); + } + + if (evi >= evk) { + i__ = k; + } else { + sorted = FALSE_; + ifst = i__; + ilst = k; + strexc_("V", &jw, &t[t_offset], ldt, &v[v_offset], ldv, &ifst, + &ilst, &work[1], &info); + if (info == 0) { + i__ = ilst; + } else { + i__ = k; + } + } + if (i__ == kend) { + k = i__ + 1; + } else if (t[i__ + 1 + i__ * t_dim1] == 0.f) { + k = i__ + 1; + } else { + k = i__ + 2; + } + goto L40; + } + goto L30; +L50: + ; + } + +/* ==== Restore shift/eigenvalue array from T ==== */ + + i__ = jw; +L60: + if (i__ >= infqr + 1) { + if (i__ == infqr + 1) { + sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; + si[kwtop + i__ - 1] = 0.f; + --i__; + } else if (t[i__ + (i__ - 1) * t_dim1] == 0.f) { + sr[kwtop + i__ - 1] = t[i__ + i__ * t_dim1]; + si[kwtop + i__ - 1] = 0.f; + --i__; + } else { + aa = t[i__ - 1 + (i__ - 1) * t_dim1]; + cc = t[i__ + (i__ - 1) * t_dim1]; + bb = t[i__ - 1 + i__ * t_dim1]; + dd = t[i__ + i__ * t_dim1]; + slanv2_(&aa, &bb, &cc, &dd, &sr[kwtop + i__ - 2], &si[kwtop + i__ + - 2], &sr[kwtop + i__ - 1], &si[kwtop + i__ - 1], &cs, & + sn); + i__ += -2; + } + goto L60; + } + + if (*ns < jw || s == 0.f) { + if (*ns > 1 && s != 0.f) { + +/* ==== Reflect spike back into lower triangle ==== */ + + scopy_(ns, &v[v_offset], ldv, &work[1], &c__1); + beta = work[1]; + slarfg_(ns, &beta, &work[2], &c__1, &tau); + work[1] = 1.f; + + i__1 = jw - 2; + i__2 = jw - 2; + slaset_("L", &i__1, &i__2, &c_b17, &c_b17, &t[t_dim1 + 3], ldt); + + slarf_("L", ns, &jw, &work[1], &c__1, &tau, &t[t_offset], ldt, & + work[jw + 1]); + slarf_("R", ns, ns, &work[1], &c__1, &tau, &t[t_offset], ldt, & + work[jw + 1]); + slarf_("R", &jw, ns, &work[1], &c__1, &tau, &v[v_offset], ldv, & + work[jw + 1]); + + i__1 = *lwork - jw; + sgehrd_(&jw, &c__1, ns, &t[t_offset], ldt, &work[1], &work[jw + 1] + , &i__1, &info); + } + +/* ==== Copy updated reduced window into place ==== */ + + if (kwtop > 1) { + h__[kwtop + (kwtop - 1) * h_dim1] = s * v[v_dim1 + 1]; + } + slacpy_("U", &jw, &jw, &t[t_offset], ldt, &h__[kwtop + kwtop * h_dim1] + , ldh); + i__1 = jw - 1; + i__2 = *ldt + 1; + i__3 = *ldh + 1; + scopy_(&i__1, &t[t_dim1 + 2], &i__2, &h__[kwtop + 1 + kwtop * h_dim1], + &i__3); + +/* ==== Accumulate orthogonal matrix in order update */ +/* . H and Z, if requested. ==== */ + + if (*ns > 1 && s != 0.f) { + i__1 = *lwork - jw; + sormhr_("R", "N", &jw, ns, &c__1, ns, &t[t_offset], ldt, &work[1], + &v[v_offset], ldv, &work[jw + 1], &i__1, &info); + } + +/* ==== Update vertical slab in H ==== */ + + if (*wantt) { + ltop = 1; + } else { + ltop = *ktop; + } + i__1 = kwtop - 1; + i__2 = *nv; + for (krow = ltop; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += + i__2) { +/* Computing MIN */ + i__3 = *nv, i__4 = kwtop - krow; + kln = f2cmin(i__3,i__4); + sgemm_("N", "N", &kln, &jw, &jw, &c_b18, &h__[krow + kwtop * + h_dim1], ldh, &v[v_offset], ldv, &c_b17, &wv[wv_offset], + ldwv); + slacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &h__[krow + kwtop * + h_dim1], ldh); +/* L70: */ + } + +/* ==== Update horizontal slab in H ==== */ + + if (*wantt) { + i__2 = *n; + i__1 = *nh; + for (kcol = *kbot + 1; i__1 < 0 ? kcol >= i__2 : kcol <= i__2; + kcol += i__1) { +/* Computing MIN */ + i__3 = *nh, i__4 = *n - kcol + 1; + kln = f2cmin(i__3,i__4); + sgemm_("C", "N", &jw, &kln, &jw, &c_b18, &v[v_offset], ldv, & + h__[kwtop + kcol * h_dim1], ldh, &c_b17, &t[t_offset], + ldt); + slacpy_("A", &jw, &kln, &t[t_offset], ldt, &h__[kwtop + kcol * + h_dim1], ldh); +/* L80: */ + } + } + +/* ==== Update vertical slab in Z ==== */ + + if (*wantz) { + i__1 = *ihiz; + i__2 = *nv; + for (krow = *iloz; i__2 < 0 ? krow >= i__1 : krow <= i__1; krow += + i__2) { +/* Computing MIN */ + i__3 = *nv, i__4 = *ihiz - krow + 1; + kln = f2cmin(i__3,i__4); + sgemm_("N", "N", &kln, &jw, &jw, &c_b18, &z__[krow + kwtop * + z_dim1], ldz, &v[v_offset], ldv, &c_b17, &wv[ + wv_offset], ldwv); + slacpy_("A", &kln, &jw, &wv[wv_offset], ldwv, &z__[krow + + kwtop * z_dim1], ldz); +/* L90: */ + } + } + } + +/* ==== Return the number of deflations ... ==== */ + + *nd = jw - *ns; + +/* ==== ... and the number of shifts. (Subtracting */ +/* . INFQR from the spike length takes care */ +/* . of the case of a rare QR failure while */ +/* . calculating eigenvalues of the deflation */ +/* . window.) ==== */ + + *ns -= infqr; + +/* ==== Return optimal workspace. ==== */ + + work[1] = (real) lwkopt; + +/* ==== End of SLAQR3 ==== */ + + return 0; +} /* slaqr3_ */ + diff --git a/lapack-netlib/SRC/slaqr4.c b/lapack-netlib/SRC/slaqr4.c new file mode 100644 index 000000000..aaf3a7a55 --- /dev/null +++ b/lapack-netlib/SRC/slaqr4.c @@ -0,0 +1,1217 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLAQR4 computes the eigenvalues of a Hessenberg matrix, and optionally the matrices from the Sc +hur decomposition. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAQR4 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, */ +/* ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO ) */ + +/* INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N */ +/* LOGICAL WANTT, WANTZ */ +/* REAL H( LDH, * ), WI( * ), WORK( * ), WR( * ), */ +/* $ Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAQR4 implements one level of recursion for SLAQR0. */ +/* > It is a complete implementation of the small bulge multi-shift */ +/* > QR algorithm. It may be called by SLAQR0 and, for large enough */ +/* > deflation window size, it may be called by SLAQR3. This */ +/* > subroutine is identical to SLAQR0 except that it calls SLAQR2 */ +/* > instead of SLAQR3. */ +/* > */ +/* > SLAQR4 computes the eigenvalues of a Hessenberg matrix H */ +/* > and, optionally, the matrices T and Z from the Schur decomposition */ +/* > H = Z T Z**T, where T is an upper quasi-triangular matrix (the */ +/* > Schur form), and Z is the orthogonal matrix of Schur vectors. */ +/* > */ +/* > Optionally Z may be postmultiplied into an input orthogonal */ +/* > matrix Q so that this routine can give the Schur factorization */ +/* > of a matrix A which has been reduced to the Hessenberg form H */ +/* > by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] WANTT */ +/* > \verbatim */ +/* > WANTT is LOGICAL */ +/* > = .TRUE. : the full Schur form T is required; */ +/* > = .FALSE.: only eigenvalues are required. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTZ */ +/* > \verbatim */ +/* > WANTZ is LOGICAL */ +/* > = .TRUE. : the matrix of Schur vectors Z is required; */ +/* > = .FALSE.: Schur vectors are not required. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix H. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILO */ +/* > \verbatim */ +/* > ILO is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHI */ +/* > \verbatim */ +/* > IHI is INTEGER */ +/* > It is assumed that H is already upper triangular in rows */ +/* > and columns 1:ILO-1 and IHI+1:N and, if ILO > 1, */ +/* > H(ILO,ILO-1) is zero. ILO and IHI are normally set by a */ +/* > previous call to SGEBAL, and then passed to SGEHRD when the */ +/* > matrix output by SGEBAL is reduced to Hessenberg form. */ +/* > Otherwise, ILO and IHI should be set to 1 and N, */ +/* > respectively. If N > 0, then 1 <= ILO <= IHI <= N. */ +/* > If N = 0, then ILO = 1 and IHI = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] H */ +/* > \verbatim */ +/* > H is REAL array, dimension (LDH,N) */ +/* > On entry, the upper Hessenberg matrix H. */ +/* > On exit, if INFO = 0 and WANTT is .TRUE., then H contains */ +/* > the upper quasi-triangular matrix T from the Schur */ +/* > decomposition (the Schur form); 2-by-2 diagonal blocks */ +/* > (corresponding to complex conjugate pairs of eigenvalues) */ +/* > are returned in standard form, with H(i,i) = H(i+1,i+1) */ +/* > and H(i+1,i)*H(i,i+1) < 0. If INFO = 0 and WANTT is */ +/* > .FALSE., then the contents of H are unspecified on exit. */ +/* > (The output value of H when INFO > 0 is given under the */ +/* > description of INFO below.) */ +/* > */ +/* > This subroutine may explicitly set H(i,j) = 0 for i > j and */ +/* > j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > The leading dimension of the array H. LDH >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WR */ +/* > \verbatim */ +/* > WR is REAL array, dimension (IHI) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WI */ +/* > \verbatim */ +/* > WI is REAL array, dimension (IHI) */ +/* > The real and imaginary parts, respectively, of the computed */ +/* > eigenvalues of H(ILO:IHI,ILO:IHI) are stored in WR(ILO:IHI) */ +/* > and WI(ILO:IHI). If two eigenvalues are computed as a */ +/* > complex conjugate pair, they are stored in consecutive */ +/* > elements of WR and WI, say the i-th and (i+1)th, with */ +/* > WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., then */ +/* > the eigenvalues are stored in the same order as on the */ +/* > diagonal of the Schur form returned in H, with */ +/* > WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal */ +/* > block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and */ +/* > WI(i+1) = -WI(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILOZ */ +/* > \verbatim */ +/* > ILOZ is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHIZ */ +/* > \verbatim */ +/* > IHIZ is INTEGER */ +/* > Specify the rows of Z to which transformations must be */ +/* > applied if WANTZ is .TRUE.. */ +/* > 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension (LDZ,IHI) */ +/* > If WANTZ is .FALSE., then Z is not referenced. */ +/* > If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is */ +/* > replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the */ +/* > orthogonal Schur factor of H(ILO:IHI,ILO:IHI). */ +/* > (The output value of Z when INFO > 0 is given under */ +/* > the description of INFO below.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. if WANTZ is .TRUE. */ +/* > then LDZ >= MAX(1,IHIZ). Otherwise, LDZ >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension LWORK */ +/* > On exit, if LWORK = -1, WORK(1) returns an estimate of */ +/* > the optimal value for LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,N) */ +/* > is sufficient, but LWORK typically as large as 6*N may */ +/* > be required for optimal performance. A workspace query */ +/* > to determine the optimal workspace size is recommended. */ +/* > */ +/* > If LWORK = -1, then SLAQR4 does a workspace query. */ +/* > In this case, SLAQR4 checks the input parameters and */ +/* > estimates the optimal workspace size for the given */ +/* > values of N, ILO and IHI. The estimate is returned */ +/* > in WORK(1). No error message related to LWORK is */ +/* > issued by XERBLA. Neither H nor Z are accessed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > > 0: if INFO = i, SLAQR4 failed to compute all of */ +/* > the eigenvalues. Elements 1:ilo-1 and i+1:n of WR */ +/* > and WI contain those eigenvalues which have been */ +/* > successfully computed. (Failures are rare.) */ +/* > */ +/* > If INFO > 0 and WANT is .FALSE., then on exit, */ +/* > the remaining unconverged eigenvalues are the eigen- */ +/* > values of the upper Hessenberg matrix rows and */ +/* > columns ILO through INFO of the final, output */ +/* > value of H. */ +/* > */ +/* > If INFO > 0 and WANTT is .TRUE., then on exit */ +/* > */ +/* > (*) (initial value of H)*U = U*(final value of H) */ +/* > */ +/* > where U is a orthogonal matrix. The final */ +/* > value of H is upper Hessenberg and triangular in */ +/* > rows and columns INFO+1 through IHI. */ +/* > */ +/* > If INFO > 0 and WANTZ is .TRUE., then on exit */ +/* > */ +/* > (final value of Z(ILO:IHI,ILOZ:IHIZ) */ +/* > = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U */ +/* > */ +/* > where U is the orthogonal matrix in (*) (regard- */ +/* > less of the value of WANTT.) */ +/* > */ +/* > If INFO > 0 and WANTZ is .FALSE., then Z is not */ +/* > accessed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Karen Braman and Ralph Byers, Department of Mathematics, */ +/* > University of Kansas, USA */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ +/* > Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */ +/* > Performance, SIAM Journal of Matrix Analysis, volume 23, pages */ +/* > 929--947, 2002. */ +/* > \n */ +/* > K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ +/* > Algorithm Part II: Aggressive Early Deflation, SIAM Journal */ +/* > of Matrix Analysis, volume 23, pages 948--973, 2002. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slaqr4_(logical *wantt, logical *wantz, integer *n, + integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real * + wi, integer *iloz, integer *ihiz, real *z__, integer *ldz, real *work, + integer *lwork, integer *info) +{ + /* System generated locals */ + integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2, r__3, r__4; + + /* Local variables */ + integer ndec, ndfl, kbot, nmin; + real swap; + integer ktop; + real zdum[1] /* was [1][1] */; + integer kacc22, i__, k, itmax, nsmax, nwmax, kwtop; + real aa, bb; + extern /* Subroutine */ int slanv2_(real *, real *, real *, real *, real * + , real *, real *, real *, real *, real *); + real cc, dd; + extern /* Subroutine */ int slaqr2_(logical *, logical *, integer *, + integer *, integer *, integer *, real *, integer *, integer *, + integer *, real *, integer *, integer *, integer *, real *, real * + , real *, integer *, integer *, real *, integer *, integer *, + real *, integer *, real *, integer *), slaqr5_(logical *, logical + *, integer *, integer *, integer *, integer *, integer *, real *, + real *, real *, integer *, integer *, integer *, real *, integer * + , real *, integer *, real *, integer *, integer *, real *, + integer *, integer *, real *, integer *); + integer ld; + real cs; + integer nh, nibble, it, ks, kt; + real sn; + integer ku, kv, ls, ns; + real ss; + integer nw; + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + char jbcmpz[2]; + extern /* Subroutine */ int slahqr_(logical *, logical *, integer *, + integer *, integer *, real *, integer *, real *, real *, integer * + , integer *, real *, integer *, integer *), slacpy_(char *, + integer *, integer *, real *, integer *, real *, integer *); + integer nwupbd; + logical sorted; + integer lwkopt, inf, kdu, nho, nve, kwh, nsr, nwr, kwv; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ================================================================ */ + + +/* ==== Matrices of order NTINY or smaller must be processed by */ +/* . SLAHQR because of insufficient subdiagonal scratch space. */ +/* . (This is a hard limit.) ==== */ + +/* ==== Exceptional deflation windows: try to cure rare */ +/* . slow convergence by varying the size of the */ +/* . deflation window after KEXNW iterations. ==== */ + +/* ==== Exceptional shifts: try to cure rare slow convergence */ +/* . with ad-hoc exceptional shifts every KEXSH iterations. */ +/* . ==== */ + +/* ==== The constants WILK1 and WILK2 are used to form the */ +/* . exceptional shifts. ==== */ + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + --wr; + --wi; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + + /* Function Body */ + *info = 0; + +/* ==== Quick return for N = 0: nothing to do. ==== */ + + if (*n == 0) { + work[1] = 1.f; + return 0; + } + + if (*n <= 15) { + +/* ==== Tiny matrices must use SLAHQR. ==== */ + + lwkopt = 1; + if (*lwork != -1) { + slahqr_(wantt, wantz, n, ilo, ihi, &h__[h_offset], ldh, &wr[1], & + wi[1], iloz, ihiz, &z__[z_offset], ldz, info); + } + } else { + +/* ==== Use small bulge multi-shift QR with aggressive early */ +/* . deflation on larger-than-tiny matrices. ==== */ + +/* ==== Hope for the best. ==== */ + + *info = 0; + +/* ==== Set up job flags for ILAENV. ==== */ + + if (*wantt) { + *(unsigned char *)jbcmpz = 'S'; + } else { + *(unsigned char *)jbcmpz = 'E'; + } + if (*wantz) { + *(unsigned char *)&jbcmpz[1] = 'V'; + } else { + *(unsigned char *)&jbcmpz[1] = 'N'; + } + +/* ==== NWR = recommended deflation window size. At this */ +/* . point, N .GT. NTINY = 15, so there is enough */ +/* . subdiagonal workspace for NWR.GE.2 as required. */ +/* . (In fact, there is enough subdiagonal space for */ +/* . NWR.GE.4.) ==== */ + + nwr = ilaenv_(&c__13, "SLAQR4", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, + (ftnlen)2); + nwr = f2cmax(2,nwr); +/* Computing MIN */ + i__1 = *ihi - *ilo + 1, i__2 = (*n - 1) / 3, i__1 = f2cmin(i__1,i__2); + nwr = f2cmin(i__1,nwr); + +/* ==== NSR = recommended number of simultaneous shifts. */ +/* . At this point N .GT. NTINY = 15, so there is at */ +/* . enough subdiagonal workspace for NSR to be even */ +/* . and greater than or equal to two as required. ==== */ + + nsr = ilaenv_(&c__15, "SLAQR4", jbcmpz, n, ilo, ihi, lwork, (ftnlen)6, + (ftnlen)2); +/* Computing MIN */ + i__1 = nsr, i__2 = (*n - 3) / 6, i__1 = f2cmin(i__1,i__2), i__2 = *ihi - + *ilo; + nsr = f2cmin(i__1,i__2); +/* Computing MAX */ + i__1 = 2, i__2 = nsr - nsr % 2; + nsr = f2cmax(i__1,i__2); + +/* ==== Estimate optimal workspace ==== */ + +/* ==== Workspace query call to SLAQR2 ==== */ + + i__1 = nwr + 1; + slaqr2_(wantt, wantz, n, ilo, ihi, &i__1, &h__[h_offset], ldh, iloz, + ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], &h__[ + h_offset], ldh, n, &h__[h_offset], ldh, n, &h__[h_offset], + ldh, &work[1], &c_n1); + +/* ==== Optimal workspace = MAX(SLAQR5, SLAQR2) ==== */ + +/* Computing MAX */ + i__1 = nsr * 3 / 2, i__2 = (integer) work[1]; + lwkopt = f2cmax(i__1,i__2); + +/* ==== Quick return in case of workspace query. ==== */ + + if (*lwork == -1) { + work[1] = (real) lwkopt; + return 0; + } + +/* ==== SLAHQR/SLAQR0 crossover point ==== */ + + nmin = ilaenv_(&c__12, "SLAQR4", jbcmpz, n, ilo, ihi, lwork, (ftnlen) + 6, (ftnlen)2); + nmin = f2cmax(15,nmin); + +/* ==== Nibble crossover point ==== */ + + nibble = ilaenv_(&c__14, "SLAQR4", jbcmpz, n, ilo, ihi, lwork, ( + ftnlen)6, (ftnlen)2); + nibble = f2cmax(0,nibble); + +/* ==== Accumulate reflections during ttswp? Use block */ +/* . 2-by-2 structure during matrix-matrix multiply? ==== */ + + kacc22 = ilaenv_(&c__16, "SLAQR4", jbcmpz, n, ilo, ihi, lwork, ( + ftnlen)6, (ftnlen)2); + kacc22 = f2cmax(0,kacc22); + kacc22 = f2cmin(2,kacc22); + +/* ==== NWMAX = the largest possible deflation window for */ +/* . which there is sufficient workspace. ==== */ + +/* Computing MIN */ + i__1 = (*n - 1) / 3, i__2 = *lwork / 2; + nwmax = f2cmin(i__1,i__2); + nw = nwmax; + +/* ==== NSMAX = the Largest number of simultaneous shifts */ +/* . for which there is sufficient workspace. ==== */ + +/* Computing MIN */ + i__1 = (*n - 3) / 6, i__2 = (*lwork << 1) / 3; + nsmax = f2cmin(i__1,i__2); + nsmax -= nsmax % 2; + +/* ==== NDFL: an iteration count restarted at deflation. ==== */ + + ndfl = 1; + +/* ==== ITMAX = iteration limit ==== */ + +/* Computing MAX */ + i__1 = 10, i__2 = *ihi - *ilo + 1; + itmax = 30 * f2cmax(i__1,i__2); + +/* ==== Last row and column in the active block ==== */ + + kbot = *ihi; + +/* ==== Main Loop ==== */ + + i__1 = itmax; + for (it = 1; it <= i__1; ++it) { + +/* ==== Done when KBOT falls below ILO ==== */ + + if (kbot < *ilo) { + goto L90; + } + +/* ==== Locate active block ==== */ + + i__2 = *ilo + 1; + for (k = kbot; k >= i__2; --k) { + if (h__[k + (k - 1) * h_dim1] == 0.f) { + goto L20; + } +/* L10: */ + } + k = *ilo; +L20: + ktop = k; + +/* ==== Select deflation window size: */ +/* . Typical Case: */ +/* . If possible and advisable, nibble the entire */ +/* . active block. If not, use size MIN(NWR,NWMAX) */ +/* . or MIN(NWR+1,NWMAX) depending upon which has */ +/* . the smaller corresponding subdiagonal entry */ +/* . (a heuristic). */ +/* . */ +/* . Exceptional Case: */ +/* . If there have been no deflations in KEXNW or */ +/* . more iterations, then vary the deflation window */ +/* . size. At first, because, larger windows are, */ +/* . in general, more powerful than smaller ones, */ +/* . rapidly increase the window to the maximum possible. */ +/* . Then, gradually reduce the window size. ==== */ + + nh = kbot - ktop + 1; + nwupbd = f2cmin(nh,nwmax); + if (ndfl < 5) { + nw = f2cmin(nwupbd,nwr); + } else { +/* Computing MIN */ + i__2 = nwupbd, i__3 = nw << 1; + nw = f2cmin(i__2,i__3); + } + if (nw < nwmax) { + if (nw >= nh - 1) { + nw = nh; + } else { + kwtop = kbot - nw + 1; + if ((r__1 = h__[kwtop + (kwtop - 1) * h_dim1], abs(r__1)) + > (r__2 = h__[kwtop - 1 + (kwtop - 2) * h_dim1], + abs(r__2))) { + ++nw; + } + } + } + if (ndfl < 5) { + ndec = -1; + } else if (ndec >= 0 || nw >= nwupbd) { + ++ndec; + if (nw - ndec < 2) { + ndec = 0; + } + nw -= ndec; + } + +/* ==== Aggressive early deflation: */ +/* . split workspace under the subdiagonal into */ +/* . - an nw-by-nw work array V in the lower */ +/* . left-hand-corner, */ +/* . - an NW-by-at-least-NW-but-more-is-better */ +/* . (NW-by-NHO) horizontal work array along */ +/* . the bottom edge, */ +/* . - an at-least-NW-but-more-is-better (NHV-by-NW) */ +/* . vertical work array along the left-hand-edge. */ +/* . ==== */ + + kv = *n - nw + 1; + kt = nw + 1; + nho = *n - nw - 1 - kt + 1; + kwv = nw + 2; + nve = *n - nw - kwv + 1; + +/* ==== Aggressive early deflation ==== */ + + slaqr2_(wantt, wantz, n, &ktop, &kbot, &nw, &h__[h_offset], ldh, + iloz, ihiz, &z__[z_offset], ldz, &ls, &ld, &wr[1], &wi[1], + &h__[kv + h_dim1], ldh, &nho, &h__[kv + kt * h_dim1], + ldh, &nve, &h__[kwv + h_dim1], ldh, &work[1], lwork); + +/* ==== Adjust KBOT accounting for new deflations. ==== */ + + kbot -= ld; + +/* ==== KS points to the shifts. ==== */ + + ks = kbot - ls + 1; + +/* ==== Skip an expensive QR sweep if there is a (partly */ +/* . heuristic) reason to expect that many eigenvalues */ +/* . will deflate without it. Here, the QR sweep is */ +/* . skipped if many eigenvalues have just been deflated */ +/* . or if the remaining active block is small. */ + + if (ld == 0 || ld * 100 <= nw * nibble && kbot - ktop + 1 > f2cmin( + nmin,nwmax)) { + +/* ==== NS = nominal number of simultaneous shifts. */ +/* . This may be lowered (slightly) if SLAQR2 */ +/* . did not provide that many shifts. ==== */ + +/* Computing MIN */ +/* Computing MAX */ + i__4 = 2, i__5 = kbot - ktop; + i__2 = f2cmin(nsmax,nsr), i__3 = f2cmax(i__4,i__5); + ns = f2cmin(i__2,i__3); + ns -= ns % 2; + +/* ==== If there have been no deflations */ +/* . in a multiple of KEXSH iterations, */ +/* . then try exceptional shifts. */ +/* . Otherwise use shifts provided by */ +/* . SLAQR2 above or from the eigenvalues */ +/* . of a trailing principal submatrix. ==== */ + + if (ndfl % 6 == 0) { + ks = kbot - ns + 1; +/* Computing MAX */ + i__3 = ks + 1, i__4 = ktop + 2; + i__2 = f2cmax(i__3,i__4); + for (i__ = kbot; i__ >= i__2; i__ += -2) { + ss = (r__1 = h__[i__ + (i__ - 1) * h_dim1], abs(r__1)) + + (r__2 = h__[i__ - 1 + (i__ - 2) * h_dim1], + abs(r__2)); + aa = ss * .75f + h__[i__ + i__ * h_dim1]; + bb = ss; + cc = ss * -.4375f; + dd = aa; + slanv2_(&aa, &bb, &cc, &dd, &wr[i__ - 1], &wi[i__ - 1] + , &wr[i__], &wi[i__], &cs, &sn); +/* L30: */ + } + if (ks == ktop) { + wr[ks + 1] = h__[ks + 1 + (ks + 1) * h_dim1]; + wi[ks + 1] = 0.f; + wr[ks] = wr[ks + 1]; + wi[ks] = wi[ks + 1]; + } + } else { + +/* ==== Got NS/2 or fewer shifts? Use SLAHQR */ +/* . on a trailing principal submatrix to */ +/* . get more. (Since NS.LE.NSMAX.LE.(N-3)/6, */ +/* . there is enough space below the subdiagonal */ +/* . to fit an NS-by-NS scratch array.) ==== */ + + if (kbot - ks + 1 <= ns / 2) { + ks = kbot - ns + 1; + kt = *n - ns + 1; + slacpy_("A", &ns, &ns, &h__[ks + ks * h_dim1], ldh, & + h__[kt + h_dim1], ldh); + slahqr_(&c_false, &c_false, &ns, &c__1, &ns, &h__[kt + + h_dim1], ldh, &wr[ks], &wi[ks], &c__1, & + c__1, zdum, &c__1, &inf); + ks += inf; + +/* ==== In case of a rare QR failure use */ +/* . eigenvalues of the trailing 2-by-2 */ +/* . principal submatrix. ==== */ + + if (ks >= kbot) { + aa = h__[kbot - 1 + (kbot - 1) * h_dim1]; + cc = h__[kbot + (kbot - 1) * h_dim1]; + bb = h__[kbot - 1 + kbot * h_dim1]; + dd = h__[kbot + kbot * h_dim1]; + slanv2_(&aa, &bb, &cc, &dd, &wr[kbot - 1], &wi[ + kbot - 1], &wr[kbot], &wi[kbot], &cs, &sn) + ; + ks = kbot - 1; + } + } + + if (kbot - ks + 1 > ns) { + +/* ==== Sort the shifts (Helps a little) */ +/* . Bubble sort keeps complex conjugate */ +/* . pairs together. ==== */ + + sorted = FALSE_; + i__2 = ks + 1; + for (k = kbot; k >= i__2; --k) { + if (sorted) { + goto L60; + } + sorted = TRUE_; + i__3 = k - 1; + for (i__ = ks; i__ <= i__3; ++i__) { + if ((r__1 = wr[i__], abs(r__1)) + (r__2 = wi[ + i__], abs(r__2)) < (r__3 = wr[i__ + 1] + , abs(r__3)) + (r__4 = wi[i__ + 1], + abs(r__4))) { + sorted = FALSE_; + + swap = wr[i__]; + wr[i__] = wr[i__ + 1]; + wr[i__ + 1] = swap; + + swap = wi[i__]; + wi[i__] = wi[i__ + 1]; + wi[i__ + 1] = swap; + } +/* L40: */ + } +/* L50: */ + } +L60: + ; + } + +/* ==== Shuffle shifts into pairs of real shifts */ +/* . and pairs of complex conjugate shifts */ +/* . assuming complex conjugate shifts are */ +/* . already adjacent to one another. (Yes, */ +/* . they are.) ==== */ + + i__2 = ks + 2; + for (i__ = kbot; i__ >= i__2; i__ += -2) { + if (wi[i__] != -wi[i__ - 1]) { + + swap = wr[i__]; + wr[i__] = wr[i__ - 1]; + wr[i__ - 1] = wr[i__ - 2]; + wr[i__ - 2] = swap; + + swap = wi[i__]; + wi[i__] = wi[i__ - 1]; + wi[i__ - 1] = wi[i__ - 2]; + wi[i__ - 2] = swap; + } +/* L70: */ + } + } + +/* ==== If there are only two shifts and both are */ +/* . real, then use only one. ==== */ + + if (kbot - ks + 1 == 2) { + if (wi[kbot] == 0.f) { + if ((r__1 = wr[kbot] - h__[kbot + kbot * h_dim1], abs( + r__1)) < (r__2 = wr[kbot - 1] - h__[kbot + + kbot * h_dim1], abs(r__2))) { + wr[kbot - 1] = wr[kbot]; + } else { + wr[kbot] = wr[kbot - 1]; + } + } + } + +/* ==== Use up to NS of the the smallest magnitude */ +/* . shifts. If there aren't NS shifts available, */ +/* . then use them all, possibly dropping one to */ +/* . make the number of shifts even. ==== */ + +/* Computing MIN */ + i__2 = ns, i__3 = kbot - ks + 1; + ns = f2cmin(i__2,i__3); + ns -= ns % 2; + ks = kbot - ns + 1; + +/* ==== Small-bulge multi-shift QR sweep: */ +/* . split workspace under the subdiagonal into */ +/* . - a KDU-by-KDU work array U in the lower */ +/* . left-hand-corner, */ +/* . - a KDU-by-at-least-KDU-but-more-is-better */ +/* . (KDU-by-NHo) horizontal work array WH along */ +/* . the bottom edge, */ +/* . - and an at-least-KDU-but-more-is-better-by-KDU */ +/* . (NVE-by-KDU) vertical work WV arrow along */ +/* . the left-hand-edge. ==== */ + + kdu = ns << 1; + ku = *n - kdu + 1; + kwh = kdu + 1; + nho = *n - kdu - 3 - (kdu + 1) + 1; + kwv = kdu + 4; + nve = *n - kdu - kwv + 1; + +/* ==== Small-bulge multi-shift QR sweep ==== */ + + slaqr5_(wantt, wantz, &kacc22, n, &ktop, &kbot, &ns, &wr[ks], + &wi[ks], &h__[h_offset], ldh, iloz, ihiz, &z__[ + z_offset], ldz, &work[1], &c__3, &h__[ku + h_dim1], + ldh, &nve, &h__[kwv + h_dim1], ldh, &nho, &h__[ku + + kwh * h_dim1], ldh); + } + +/* ==== Note progress (or the lack of it). ==== */ + + if (ld > 0) { + ndfl = 1; + } else { + ++ndfl; + } + +/* ==== End of main loop ==== */ +/* L80: */ + } + +/* ==== Iteration limit exceeded. Set INFO to show where */ +/* . the problem occurred and exit. ==== */ + + *info = kbot; +L90: + ; + } + +/* ==== Return the optimal value of LWORK. ==== */ + + work[1] = (real) lwkopt; + +/* ==== End of SLAQR4 ==== */ + + return 0; +} /* slaqr4_ */ + diff --git a/lapack-netlib/SRC/slaqr5.c b/lapack-netlib/SRC/slaqr5.c new file mode 100644 index 000000000..24432efb7 --- /dev/null +++ b/lapack-netlib/SRC/slaqr5.c @@ -0,0 +1,1407 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLAQR5 performs a single small-bulge multi-shift QR sweep. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAQR5 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, */ +/* SR, SI, H, LDH, ILOZ, IHIZ, Z, LDZ, V, LDV, U, */ +/* LDU, NV, WV, LDWV, NH, WH, LDWH ) */ + +/* INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV, */ +/* $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV */ +/* LOGICAL WANTT, WANTZ */ +/* REAL H( LDH, * ), SI( * ), SR( * ), U( LDU, * ), */ +/* $ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ), */ +/* $ Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAQR5, called by SLAQR0, performs a */ +/* > single small-bulge multi-shift QR sweep. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] WANTT */ +/* > \verbatim */ +/* > WANTT is LOGICAL */ +/* > WANTT = .true. if the quasi-triangular Schur factor */ +/* > is being computed. WANTT is set to .false. otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTZ */ +/* > \verbatim */ +/* > WANTZ is LOGICAL */ +/* > WANTZ = .true. if the orthogonal Schur factor is being */ +/* > computed. WANTZ is set to .false. otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KACC22 */ +/* > \verbatim */ +/* > KACC22 is INTEGER with value 0, 1, or 2. */ +/* > Specifies the computation mode of far-from-diagonal */ +/* > orthogonal updates. */ +/* > = 0: SLAQR5 does not accumulate reflections and does not */ +/* > use matrix-matrix multiply to update far-from-diagonal */ +/* > matrix entries. */ +/* > = 1: SLAQR5 accumulates reflections and uses matrix-matrix */ +/* > multiply to update the far-from-diagonal matrix entries. */ +/* > = 2: Same as KACC22 = 1. This option used to enable exploiting */ +/* > the 2-by-2 structure during matrix multiplications, but */ +/* > this is no longer supported. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > N is the order of the Hessenberg matrix H upon which this */ +/* > subroutine operates. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KTOP */ +/* > \verbatim */ +/* > KTOP is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KBOT */ +/* > \verbatim */ +/* > KBOT is INTEGER */ +/* > These are the first and last rows and columns of an */ +/* > isolated diagonal block upon which the QR sweep is to be */ +/* > applied. It is assumed without a check that */ +/* > either KTOP = 1 or H(KTOP,KTOP-1) = 0 */ +/* > and */ +/* > either KBOT = N or H(KBOT+1,KBOT) = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NSHFTS */ +/* > \verbatim */ +/* > NSHFTS is INTEGER */ +/* > NSHFTS gives the number of simultaneous shifts. NSHFTS */ +/* > must be positive and even. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] SR */ +/* > \verbatim */ +/* > SR is REAL array, dimension (NSHFTS) */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] SI */ +/* > \verbatim */ +/* > SI is REAL array, dimension (NSHFTS) */ +/* > SR contains the real parts and SI contains the imaginary */ +/* > parts of the NSHFTS shifts of origin that define the */ +/* > multi-shift QR sweep. On output SR and SI may be */ +/* > reordered. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] H */ +/* > \verbatim */ +/* > H is REAL array, dimension (LDH,N) */ +/* > On input H contains a Hessenberg matrix. On output a */ +/* > multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied */ +/* > to the isolated diagonal block in rows and columns KTOP */ +/* > through KBOT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > LDH is the leading dimension of H just as declared in the */ +/* > calling procedure. LDH >= MAX(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILOZ */ +/* > \verbatim */ +/* > ILOZ is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHIZ */ +/* > \verbatim */ +/* > IHIZ is INTEGER */ +/* > Specify the rows of Z to which transformations must be */ +/* > applied if WANTZ is .TRUE.. 1 <= ILOZ <= IHIZ <= N */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension (LDZ,IHIZ) */ +/* > If WANTZ = .TRUE., then the QR Sweep orthogonal */ +/* > similarity transformation is accumulated into */ +/* > Z(ILOZ:IHIZ,ILOZ:IHIZ) from the right. */ +/* > If WANTZ = .FALSE., then Z is unreferenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > LDA is the leading dimension of Z just as declared in */ +/* > the calling procedure. LDZ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] V */ +/* > \verbatim */ +/* > V is REAL array, dimension (LDV,NSHFTS/2) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > LDV is the leading dimension of V as declared in the */ +/* > calling procedure. LDV >= 3. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] U */ +/* > \verbatim */ +/* > U is REAL array, dimension (LDU,2*NSHFTS) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > LDU is the leading dimension of U just as declared in the */ +/* > in the calling subroutine. LDU >= 2*NSHFTS. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NV */ +/* > \verbatim */ +/* > NV is INTEGER */ +/* > NV is the number of rows in WV agailable for workspace. */ +/* > NV >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WV */ +/* > \verbatim */ +/* > WV is REAL array, dimension (LDWV,2*NSHFTS) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDWV */ +/* > \verbatim */ +/* > LDWV is INTEGER */ +/* > LDWV is the leading dimension of WV as declared in the */ +/* > in the calling subroutine. LDWV >= NV. */ +/* > \endverbatim */ + +/* > \param[in] NH */ +/* > \verbatim */ +/* > NH is INTEGER */ +/* > NH is the number of columns in array WH available for */ +/* > workspace. NH >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WH */ +/* > \verbatim */ +/* > WH is REAL array, dimension (LDWH,NH) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDWH */ +/* > \verbatim */ +/* > LDWH is INTEGER */ +/* > Leading dimension of WH just as declared in the */ +/* > calling procedure. LDWH >= 2*NSHFTS. */ +/* > \endverbatim */ +/* > */ +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date January 2021 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Karen Braman and Ralph Byers, Department of Mathematics, */ +/* > University of Kansas, USA */ +/* > */ +/* > Lars Karlsson, Daniel Kressner, and Bruno Lang */ +/* > */ +/* > Thijs Steel, Department of Computer science, */ +/* > KU Leuven, Belgium */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ +/* > Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */ +/* > Performance, SIAM Journal of Matrix Analysis, volume 23, pages */ +/* > 929--947, 2002. */ +/* > */ +/* > Lars Karlsson, Daniel Kressner, and Bruno Lang, Optimally packed */ +/* > chains of bulges in multishift QR algorithms. */ +/* > ACM Trans. Math. Softw. 40, 2, Article 12 (February 2014). */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slaqr5_(logical *wantt, logical *wantz, integer *kacc22, + integer *n, integer *ktop, integer *kbot, integer *nshfts, real *sr, + real *si, real *h__, integer *ldh, integer *iloz, integer *ihiz, real + *z__, integer *ldz, real *v, integer *ldv, real *u, integer *ldu, + integer *nv, real *wv, integer *ldwv, integer *nh, real *wh, integer * + ldwh) +{ + /* System generated locals */ + integer h_dim1, h_offset, u_dim1, u_offset, v_dim1, v_offset, wh_dim1, + wh_offset, wv_dim1, wv_offset, z_dim1, z_offset, i__1, i__2, i__3, + i__4, i__5, i__6, i__7; + real r__1, r__2, r__3, r__4, r__5; + + /* Local variables */ + real beta; + logical bmp22; + integer jcol, jlen, jbot, mbot; + real swap; + integer jtop, jrow, mtop, i__, j, k, m; + real alpha; + logical accum; + integer ndcol, incol; + extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *); + integer krcol, nbmps, i2, k1, i4; + extern /* Subroutine */ int slaqr1_(integer *, real *, integer *, real *, + real *, real *, real *, real *); + real h11, h12, h21, h22; + integer m22; + extern /* Subroutine */ int slabad_(real *, real *); + integer ns, nu; + extern real slamch_(char *); + real vt[3], safmin, safmax; + extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *, + real *), slacpy_(char *, integer *, integer *, real *, integer *, + real *, integer *), slaset_(char *, integer *, integer *, + real *, real *, real *, integer *); + real refsum, smlnum, scl; + integer kdu, kms; + real ulp, tst1, tst2; + + +/* -- LAPACK auxiliary routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ================================================================ */ + + +/* ==== If there are no shifts, then there is nothing to do. ==== */ + + /* Parameter adjustments */ + --sr; + --si; + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + wv_dim1 = *ldwv; + wv_offset = 1 + wv_dim1 * 1; + wv -= wv_offset; + wh_dim1 = *ldwh; + wh_offset = 1 + wh_dim1 * 1; + wh -= wh_offset; + + /* Function Body */ + if (*nshfts < 2) { + return 0; + } + +/* ==== If the active block is empty or 1-by-1, then there */ +/* . is nothing to do. ==== */ + + if (*ktop >= *kbot) { + return 0; + } + +/* ==== Shuffle shifts into pairs of real shifts and pairs */ +/* . of complex conjugate shifts assuming complex */ +/* . conjugate shifts are already adjacent to one */ +/* . another. ==== */ + + i__1 = *nshfts - 2; + for (i__ = 1; i__ <= i__1; i__ += 2) { + if (si[i__] != -si[i__ + 1]) { + + swap = sr[i__]; + sr[i__] = sr[i__ + 1]; + sr[i__ + 1] = sr[i__ + 2]; + sr[i__ + 2] = swap; + + swap = si[i__]; + si[i__] = si[i__ + 1]; + si[i__ + 1] = si[i__ + 2]; + si[i__ + 2] = swap; + } +/* L10: */ + } + +/* ==== NSHFTS is supposed to be even, but if it is odd, */ +/* . then simply reduce it by one. The shuffle above */ +/* . ensures that the dropped shift is real and that */ +/* . the remaining shifts are paired. ==== */ + + ns = *nshfts - *nshfts % 2; + +/* ==== Machine constants for deflation ==== */ + + safmin = slamch_("SAFE MINIMUM"); + safmax = 1.f / safmin; + slabad_(&safmin, &safmax); + ulp = slamch_("PRECISION"); + smlnum = safmin * ((real) (*n) / ulp); + +/* ==== Use accumulated reflections to update far-from-diagonal */ +/* . entries ? ==== */ + + accum = *kacc22 == 1 || *kacc22 == 2; + +/* ==== clear trash ==== */ + + if (*ktop + 2 <= *kbot) { + h__[*ktop + 2 + *ktop * h_dim1] = 0.f; + } + +/* ==== NBMPS = number of 2-shift bulges in the chain ==== */ + + nbmps = ns / 2; + +/* ==== KDU = width of slab ==== */ + + kdu = nbmps << 2; + +/* ==== Create and chase chains of NBMPS bulges ==== */ + + i__1 = *kbot - 2; + i__2 = nbmps << 1; + for (incol = *ktop - (nbmps << 1) + 1; i__2 < 0 ? incol >= i__1 : incol <= + i__1; incol += i__2) { + +/* JTOP = Index from which updates from the right start. */ + + if (accum) { + jtop = f2cmax(*ktop,incol); + } else if (*wantt) { + jtop = 1; + } else { + jtop = *ktop; + } + + ndcol = incol + kdu; + if (accum) { + slaset_("ALL", &kdu, &kdu, &c_b7, &c_b8, &u[u_offset], ldu); + } + +/* ==== Near-the-diagonal bulge chase. The following loop */ +/* . performs the near-the-diagonal part of a small bulge */ +/* . multi-shift QR sweep. Each 4*NBMPS column diagonal */ +/* . chunk extends from column INCOL to column NDCOL */ +/* . (including both column INCOL and column NDCOL). The */ +/* . following loop chases a 2*NBMPS+1 column long chain of */ +/* . NBMPS bulges 2*NBMPS-1 columns to the right. (INCOL */ +/* . may be less than KTOP and and NDCOL may be greater than */ +/* . KBOT indicating phantom columns from which to chase */ +/* . bulges before they are actually introduced or to which */ +/* . to chase bulges beyond column KBOT.) ==== */ + +/* Computing MIN */ + i__4 = incol + (nbmps << 1) - 1, i__5 = *kbot - 2; + i__3 = f2cmin(i__4,i__5); + for (krcol = incol; krcol <= i__3; ++krcol) { + +/* ==== Bulges number MTOP to MBOT are active double implicit */ +/* . shift bulges. There may or may not also be small */ +/* . 2-by-2 bulge, if there is room. The inactive bulges */ +/* . (if any) must wait until the active bulges have moved */ +/* . down the diagonal to make room. The phantom matrix */ +/* . paradigm described above helps keep track. ==== */ + +/* Computing MAX */ + i__4 = 1, i__5 = (*ktop - krcol) / 2 + 1; + mtop = f2cmax(i__4,i__5); +/* Computing MIN */ + i__4 = nbmps, i__5 = (*kbot - krcol - 1) / 2; + mbot = f2cmin(i__4,i__5); + m22 = mbot + 1; + bmp22 = mbot < nbmps && krcol + (m22 - 1 << 1) == *kbot - 2; + +/* ==== Generate reflections to chase the chain right */ +/* . one column. (The minimum value of K is KTOP-1.) ==== */ + + if (bmp22) { + +/* ==== Special case: 2-by-2 reflection at bottom treated */ +/* . separately ==== */ + + k = krcol + (m22 - 1 << 1); + if (k == *ktop - 1) { + slaqr1_(&c__2, &h__[k + 1 + (k + 1) * h_dim1], ldh, &sr[( + m22 << 1) - 1], &si[(m22 << 1) - 1], &sr[m22 * 2], + &si[m22 * 2], &v[m22 * v_dim1 + 1]); + beta = v[m22 * v_dim1 + 1]; + slarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22 + * v_dim1 + 1]); + } else { + beta = h__[k + 1 + k * h_dim1]; + v[m22 * v_dim1 + 2] = h__[k + 2 + k * h_dim1]; + slarfg_(&c__2, &beta, &v[m22 * v_dim1 + 2], &c__1, &v[m22 + * v_dim1 + 1]); + h__[k + 1 + k * h_dim1] = beta; + h__[k + 2 + k * h_dim1] = 0.f; + } + +/* ==== Perform update from right within */ +/* . computational window. ==== */ + +/* Computing MIN */ + i__5 = *kbot, i__6 = k + 3; + i__4 = f2cmin(i__5,i__6); + for (j = jtop; j <= i__4; ++j) { + refsum = v[m22 * v_dim1 + 1] * (h__[j + (k + 1) * h_dim1] + + v[m22 * v_dim1 + 2] * h__[j + (k + 2) * h_dim1]) + ; + h__[j + (k + 1) * h_dim1] -= refsum; + h__[j + (k + 2) * h_dim1] -= refsum * v[m22 * v_dim1 + 2]; +/* L30: */ + } + +/* ==== Perform update from left within */ +/* . computational window. ==== */ + + if (accum) { + jbot = f2cmin(ndcol,*kbot); + } else if (*wantt) { + jbot = *n; + } else { + jbot = *kbot; + } + i__4 = jbot; + for (j = k + 1; j <= i__4; ++j) { + refsum = v[m22 * v_dim1 + 1] * (h__[k + 1 + j * h_dim1] + + v[m22 * v_dim1 + 2] * h__[k + 2 + j * h_dim1]); + h__[k + 1 + j * h_dim1] -= refsum; + h__[k + 2 + j * h_dim1] -= refsum * v[m22 * v_dim1 + 2]; +/* L40: */ + } + +/* ==== The following convergence test requires that */ +/* . the tradition small-compared-to-nearby-diagonals */ +/* . criterion and the Ahues & Tisseur (LAWN 122, 1997) */ +/* . criteria both be satisfied. The latter improves */ +/* . accuracy in some examples. Falling back on an */ +/* . alternate convergence criterion when TST1 or TST2 */ +/* . is zero (as done here) is traditional but probably */ +/* . unnecessary. ==== */ + + if (k >= *ktop) { + if (h__[k + 1 + k * h_dim1] != 0.f) { + tst1 = (r__1 = h__[k + k * h_dim1], abs(r__1)) + ( + r__2 = h__[k + 1 + (k + 1) * h_dim1], abs( + r__2)); + if (tst1 == 0.f) { + if (k >= *ktop + 1) { + tst1 += (r__1 = h__[k + (k - 1) * h_dim1], + abs(r__1)); + } + if (k >= *ktop + 2) { + tst1 += (r__1 = h__[k + (k - 2) * h_dim1], + abs(r__1)); + } + if (k >= *ktop + 3) { + tst1 += (r__1 = h__[k + (k - 3) * h_dim1], + abs(r__1)); + } + if (k <= *kbot - 2) { + tst1 += (r__1 = h__[k + 2 + (k + 1) * h_dim1], + abs(r__1)); + } + if (k <= *kbot - 3) { + tst1 += (r__1 = h__[k + 3 + (k + 1) * h_dim1], + abs(r__1)); + } + if (k <= *kbot - 4) { + tst1 += (r__1 = h__[k + 4 + (k + 1) * h_dim1], + abs(r__1)); + } + } +/* Computing MAX */ + r__2 = smlnum, r__3 = ulp * tst1; + if ((r__1 = h__[k + 1 + k * h_dim1], abs(r__1)) <= + f2cmax(r__2,r__3)) { +/* Computing MAX */ + r__3 = (r__1 = h__[k + 1 + k * h_dim1], abs(r__1)) + , r__4 = (r__2 = h__[k + (k + 1) * h_dim1] + , abs(r__2)); + h12 = f2cmax(r__3,r__4); +/* Computing MIN */ + r__3 = (r__1 = h__[k + 1 + k * h_dim1], abs(r__1)) + , r__4 = (r__2 = h__[k + (k + 1) * h_dim1] + , abs(r__2)); + h21 = f2cmin(r__3,r__4); +/* Computing MAX */ + r__3 = (r__1 = h__[k + 1 + (k + 1) * h_dim1], abs( + r__1)), r__4 = (r__2 = h__[k + k * h_dim1] + - h__[k + 1 + (k + 1) * h_dim1], abs( + r__2)); + h11 = f2cmax(r__3,r__4); +/* Computing MIN */ + r__3 = (r__1 = h__[k + 1 + (k + 1) * h_dim1], abs( + r__1)), r__4 = (r__2 = h__[k + k * h_dim1] + - h__[k + 1 + (k + 1) * h_dim1], abs( + r__2)); + h22 = f2cmin(r__3,r__4); + scl = h11 + h12; + tst2 = h22 * (h11 / scl); + +/* Computing MAX */ + r__1 = smlnum, r__2 = ulp * tst2; + if (tst2 == 0.f || h21 * (h12 / scl) <= f2cmax(r__1, + r__2)) { + h__[k + 1 + k * h_dim1] = 0.f; + } + } + } + } + +/* ==== Accumulate orthogonal transformations. ==== */ + + if (accum) { + kms = k - incol; +/* Computing MAX */ + i__4 = 1, i__5 = *ktop - incol; + i__6 = kdu; + for (j = f2cmax(i__4,i__5); j <= i__6; ++j) { + refsum = v[m22 * v_dim1 + 1] * (u[j + (kms + 1) * + u_dim1] + v[m22 * v_dim1 + 2] * u[j + (kms + + 2) * u_dim1]); + u[j + (kms + 1) * u_dim1] -= refsum; + u[j + (kms + 2) * u_dim1] -= refsum * v[m22 * v_dim1 + + 2]; +/* L50: */ + } + } else if (*wantz) { + i__6 = *ihiz; + for (j = *iloz; j <= i__6; ++j) { + refsum = v[m22 * v_dim1 + 1] * (z__[j + (k + 1) * + z_dim1] + v[m22 * v_dim1 + 2] * z__[j + (k + + 2) * z_dim1]); + z__[j + (k + 1) * z_dim1] -= refsum; + z__[j + (k + 2) * z_dim1] -= refsum * v[m22 * v_dim1 + + 2]; +/* L60: */ + } + } + } + +/* ==== Normal case: Chain of 3-by-3 reflections ==== */ + + i__6 = mtop; + for (m = mbot; m >= i__6; --m) { + k = krcol + (m - 1 << 1); + if (k == *ktop - 1) { + slaqr1_(&c__3, &h__[*ktop + *ktop * h_dim1], ldh, &sr[(m + << 1) - 1], &si[(m << 1) - 1], &sr[m * 2], &si[m * + 2], &v[m * v_dim1 + 1]); + alpha = v[m * v_dim1 + 1]; + slarfg_(&c__3, &alpha, &v[m * v_dim1 + 2], &c__1, &v[m * + v_dim1 + 1]); + } else { + +/* ==== Perform delayed transformation of row below */ +/* . Mth bulge. Exploit fact that first two elements */ +/* . of row are actually zero. ==== */ + + refsum = v[m * v_dim1 + 1] * v[m * v_dim1 + 3] * h__[k + + 3 + (k + 2) * h_dim1]; + h__[k + 3 + k * h_dim1] = -refsum; + h__[k + 3 + (k + 1) * h_dim1] = -refsum * v[m * v_dim1 + + 2]; + h__[k + 3 + (k + 2) * h_dim1] -= refsum * v[m * v_dim1 + + 3]; + +/* ==== Calculate reflection to move */ +/* . Mth bulge one step. ==== */ + + beta = h__[k + 1 + k * h_dim1]; + v[m * v_dim1 + 2] = h__[k + 2 + k * h_dim1]; + v[m * v_dim1 + 3] = h__[k + 3 + k * h_dim1]; + slarfg_(&c__3, &beta, &v[m * v_dim1 + 2], &c__1, &v[m * + v_dim1 + 1]); + +/* ==== A Bulge may collapse because of vigilant */ +/* . deflation or destructive underflow. In the */ +/* . underflow case, try the two-small-subdiagonals */ +/* . trick to try to reinflate the bulge. ==== */ + + if (h__[k + 3 + k * h_dim1] != 0.f || h__[k + 3 + (k + 1) + * h_dim1] != 0.f || h__[k + 3 + (k + 2) * h_dim1] + == 0.f) { + +/* ==== Typical case: not collapsed (yet). ==== */ + + h__[k + 1 + k * h_dim1] = beta; + h__[k + 2 + k * h_dim1] = 0.f; + h__[k + 3 + k * h_dim1] = 0.f; + } else { + +/* ==== Atypical case: collapsed. Attempt to */ +/* . reintroduce ignoring H(K+1,K) and H(K+2,K). */ +/* . If the fill resulting from the new */ +/* . reflector is too large, then abandon it. */ +/* . Otherwise, use the new one. ==== */ + + slaqr1_(&c__3, &h__[k + 1 + (k + 1) * h_dim1], ldh, & + sr[(m << 1) - 1], &si[(m << 1) - 1], &sr[m * + 2], &si[m * 2], vt); + alpha = vt[0]; + slarfg_(&c__3, &alpha, &vt[1], &c__1, vt); + refsum = vt[0] * (h__[k + 1 + k * h_dim1] + vt[1] * + h__[k + 2 + k * h_dim1]); + + if ((r__1 = h__[k + 2 + k * h_dim1] - refsum * vt[1], + abs(r__1)) + (r__2 = refsum * vt[2], abs(r__2) + ) > ulp * ((r__3 = h__[k + k * h_dim1], abs( + r__3)) + (r__4 = h__[k + 1 + (k + 1) * h_dim1] + , abs(r__4)) + (r__5 = h__[k + 2 + (k + 2) * + h_dim1], abs(r__5)))) { + +/* ==== Starting a new bulge here would */ +/* . create non-negligible fill. Use */ +/* . the old one with trepidation. ==== */ + + h__[k + 1 + k * h_dim1] = beta; + h__[k + 2 + k * h_dim1] = 0.f; + h__[k + 3 + k * h_dim1] = 0.f; + } else { + +/* ==== Starting a new bulge here would */ +/* . create only negligible fill. */ +/* . Replace the old reflector with */ +/* . the new one. ==== */ + + h__[k + 1 + k * h_dim1] -= refsum; + h__[k + 2 + k * h_dim1] = 0.f; + h__[k + 3 + k * h_dim1] = 0.f; + v[m * v_dim1 + 1] = vt[0]; + v[m * v_dim1 + 2] = vt[1]; + v[m * v_dim1 + 3] = vt[2]; + } + } + } + +/* ==== Apply reflection from the right and */ +/* . the first column of update from the left. */ +/* . These updates are required for the vigilant */ +/* . deflation check. We still delay most of the */ +/* . updates from the left for efficiency. ==== */ + +/* Computing MIN */ + i__5 = *kbot, i__7 = k + 3; + i__4 = f2cmin(i__5,i__7); + for (j = jtop; j <= i__4; ++j) { + refsum = v[m * v_dim1 + 1] * (h__[j + (k + 1) * h_dim1] + + v[m * v_dim1 + 2] * h__[j + (k + 2) * h_dim1] + v[ + m * v_dim1 + 3] * h__[j + (k + 3) * h_dim1]); + h__[j + (k + 1) * h_dim1] -= refsum; + h__[j + (k + 2) * h_dim1] -= refsum * v[m * v_dim1 + 2]; + h__[j + (k + 3) * h_dim1] -= refsum * v[m * v_dim1 + 3]; +/* L70: */ + } + +/* ==== Perform update from left for subsequent */ +/* . column. ==== */ + + refsum = v[m * v_dim1 + 1] * (h__[k + 1 + (k + 1) * h_dim1] + + v[m * v_dim1 + 2] * h__[k + 2 + (k + 1) * h_dim1] + v[ + m * v_dim1 + 3] * h__[k + 3 + (k + 1) * h_dim1]); + h__[k + 1 + (k + 1) * h_dim1] -= refsum; + h__[k + 2 + (k + 1) * h_dim1] -= refsum * v[m * v_dim1 + 2]; + h__[k + 3 + (k + 1) * h_dim1] -= refsum * v[m * v_dim1 + 3]; + +/* ==== The following convergence test requires that */ +/* . the tradition small-compared-to-nearby-diagonals */ +/* . criterion and the Ahues & Tisseur (LAWN 122, 1997) */ +/* . criteria both be satisfied. The latter improves */ +/* . accuracy in some examples. Falling back on an */ +/* . alternate convergence criterion when TST1 or TST2 */ +/* . is zero (as done here) is traditional but probably */ +/* . unnecessary. ==== */ + + if (k < *ktop) { + goto L880; + } +/* $ CALL MYCYCLE */ + if (h__[k + 1 + k * h_dim1] != 0.f) { + tst1 = (r__1 = h__[k + k * h_dim1], abs(r__1)) + (r__2 = + h__[k + 1 + (k + 1) * h_dim1], abs(r__2)); + if (tst1 == 0.f) { + if (k >= *ktop + 1) { + tst1 += (r__1 = h__[k + (k - 1) * h_dim1], abs( + r__1)); + } + if (k >= *ktop + 2) { + tst1 += (r__1 = h__[k + (k - 2) * h_dim1], abs( + r__1)); + } + if (k >= *ktop + 3) { + tst1 += (r__1 = h__[k + (k - 3) * h_dim1], abs( + r__1)); + } + if (k <= *kbot - 2) { + tst1 += (r__1 = h__[k + 2 + (k + 1) * h_dim1], + abs(r__1)); + } + if (k <= *kbot - 3) { + tst1 += (r__1 = h__[k + 3 + (k + 1) * h_dim1], + abs(r__1)); + } + if (k <= *kbot - 4) { + tst1 += (r__1 = h__[k + 4 + (k + 1) * h_dim1], + abs(r__1)); + } + } +/* Computing MAX */ + r__2 = smlnum, r__3 = ulp * tst1; + if ((r__1 = h__[k + 1 + k * h_dim1], abs(r__1)) <= f2cmax( + r__2,r__3)) { +/* Computing MAX */ + r__3 = (r__1 = h__[k + 1 + k * h_dim1], abs(r__1)), + r__4 = (r__2 = h__[k + (k + 1) * h_dim1], abs( + r__2)); + h12 = f2cmax(r__3,r__4); +/* Computing MIN */ + r__3 = (r__1 = h__[k + 1 + k * h_dim1], abs(r__1)), + r__4 = (r__2 = h__[k + (k + 1) * h_dim1], abs( + r__2)); + h21 = f2cmin(r__3,r__4); +/* Computing MAX */ + r__3 = (r__1 = h__[k + 1 + (k + 1) * h_dim1], abs( + r__1)), r__4 = (r__2 = h__[k + k * h_dim1] - + h__[k + 1 + (k + 1) * h_dim1], abs(r__2)); + h11 = f2cmax(r__3,r__4); +/* Computing MIN */ + r__3 = (r__1 = h__[k + 1 + (k + 1) * h_dim1], abs( + r__1)), r__4 = (r__2 = h__[k + k * h_dim1] - + h__[k + 1 + (k + 1) * h_dim1], abs(r__2)); + h22 = f2cmin(r__3,r__4); + scl = h11 + h12; + tst2 = h22 * (h11 / scl); + +/* Computing MAX */ + r__1 = smlnum, r__2 = ulp * tst2; + if (tst2 == 0.f || h21 * (h12 / scl) <= f2cmax(r__1,r__2) + ) { + h__[k + 1 + k * h_dim1] = 0.f; + } + } + } +L880: +/* L80: */ + ; + } + +/* ==== Multiply H by reflections from the left ==== */ + + if (accum) { + jbot = f2cmin(ndcol,*kbot); + } else if (*wantt) { + jbot = *n; + } else { + jbot = *kbot; + } + + i__6 = mtop; + for (m = mbot; m >= i__6; --m) { + k = krcol + (m - 1 << 1); +/* Computing MAX */ + i__4 = *ktop, i__5 = krcol + (m << 1); + i__7 = jbot; + for (j = f2cmax(i__4,i__5); j <= i__7; ++j) { + refsum = v[m * v_dim1 + 1] * (h__[k + 1 + j * h_dim1] + v[ + m * v_dim1 + 2] * h__[k + 2 + j * h_dim1] + v[m * + v_dim1 + 3] * h__[k + 3 + j * h_dim1]); + h__[k + 1 + j * h_dim1] -= refsum; + h__[k + 2 + j * h_dim1] -= refsum * v[m * v_dim1 + 2]; + h__[k + 3 + j * h_dim1] -= refsum * v[m * v_dim1 + 3]; +/* L90: */ + } +/* L100: */ + } + +/* ==== Accumulate orthogonal transformations. ==== */ + + if (accum) { + +/* ==== Accumulate U. (If needed, update Z later */ +/* . with an efficient matrix-matrix */ +/* . multiply.) ==== */ + + i__6 = mtop; + for (m = mbot; m >= i__6; --m) { + k = krcol + (m - 1 << 1); + kms = k - incol; +/* Computing MAX */ + i__7 = 1, i__4 = *ktop - incol; + i2 = f2cmax(i__7,i__4); +/* Computing MAX */ + i__7 = i2, i__4 = kms - (krcol - incol) + 1; + i2 = f2cmax(i__7,i__4); +/* Computing MIN */ + i__7 = kdu, i__4 = krcol + (mbot - 1 << 1) - incol + 5; + i4 = f2cmin(i__7,i__4); + i__7 = i4; + for (j = i2; j <= i__7; ++j) { + refsum = v[m * v_dim1 + 1] * (u[j + (kms + 1) * + u_dim1] + v[m * v_dim1 + 2] * u[j + (kms + 2) + * u_dim1] + v[m * v_dim1 + 3] * u[j + (kms + + 3) * u_dim1]); + u[j + (kms + 1) * u_dim1] -= refsum; + u[j + (kms + 2) * u_dim1] -= refsum * v[m * v_dim1 + + 2]; + u[j + (kms + 3) * u_dim1] -= refsum * v[m * v_dim1 + + 3]; +/* L110: */ + } +/* L120: */ + } + } else if (*wantz) { + +/* ==== U is not accumulated, so update Z */ +/* . now by multiplying by reflections */ +/* . from the right. ==== */ + + i__6 = mtop; + for (m = mbot; m >= i__6; --m) { + k = krcol + (m - 1 << 1); + i__7 = *ihiz; + for (j = *iloz; j <= i__7; ++j) { + refsum = v[m * v_dim1 + 1] * (z__[j + (k + 1) * + z_dim1] + v[m * v_dim1 + 2] * z__[j + (k + 2) + * z_dim1] + v[m * v_dim1 + 3] * z__[j + (k + + 3) * z_dim1]); + z__[j + (k + 1) * z_dim1] -= refsum; + z__[j + (k + 2) * z_dim1] -= refsum * v[m * v_dim1 + + 2]; + z__[j + (k + 3) * z_dim1] -= refsum * v[m * v_dim1 + + 3]; +/* L130: */ + } +/* L140: */ + } + } + +/* ==== End of near-the-diagonal bulge chase. ==== */ + +/* L145: */ + } + +/* ==== Use U (if accumulated) to update far-from-diagonal */ +/* . entries in H. If required, use U to update Z as */ +/* . well. ==== */ + + if (accum) { + if (*wantt) { + jtop = 1; + jbot = *n; + } else { + jtop = *ktop; + jbot = *kbot; + } +/* Computing MAX */ + i__3 = 1, i__6 = *ktop - incol; + k1 = f2cmax(i__3,i__6); +/* Computing MAX */ + i__3 = 0, i__6 = ndcol - *kbot; + nu = kdu - f2cmax(i__3,i__6) - k1 + 1; + +/* ==== Horizontal Multiply ==== */ + + i__3 = jbot; + i__6 = *nh; + for (jcol = f2cmin(ndcol,*kbot) + 1; i__6 < 0 ? jcol >= i__3 : jcol + <= i__3; jcol += i__6) { +/* Computing MIN */ + i__7 = *nh, i__4 = jbot - jcol + 1; + jlen = f2cmin(i__7,i__4); + sgemm_("C", "N", &nu, &jlen, &nu, &c_b8, &u[k1 + k1 * u_dim1], + ldu, &h__[incol + k1 + jcol * h_dim1], ldh, &c_b7, & + wh[wh_offset], ldwh); + slacpy_("ALL", &nu, &jlen, &wh[wh_offset], ldwh, &h__[incol + + k1 + jcol * h_dim1], ldh); +/* L150: */ + } + +/* ==== Vertical multiply ==== */ + + i__6 = f2cmax(*ktop,incol) - 1; + i__3 = *nv; + for (jrow = jtop; i__3 < 0 ? jrow >= i__6 : jrow <= i__6; jrow += + i__3) { +/* Computing MIN */ + i__7 = *nv, i__4 = f2cmax(*ktop,incol) - jrow; + jlen = f2cmin(i__7,i__4); + sgemm_("N", "N", &jlen, &nu, &nu, &c_b8, &h__[jrow + (incol + + k1) * h_dim1], ldh, &u[k1 + k1 * u_dim1], ldu, &c_b7, + &wv[wv_offset], ldwv); + slacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &h__[jrow + ( + incol + k1) * h_dim1], ldh); +/* L160: */ + } + +/* ==== Z multiply (also vertical) ==== */ + + if (*wantz) { + i__3 = *ihiz; + i__6 = *nv; + for (jrow = *iloz; i__6 < 0 ? jrow >= i__3 : jrow <= i__3; + jrow += i__6) { +/* Computing MIN */ + i__7 = *nv, i__4 = *ihiz - jrow + 1; + jlen = f2cmin(i__7,i__4); + sgemm_("N", "N", &jlen, &nu, &nu, &c_b8, &z__[jrow + ( + incol + k1) * z_dim1], ldz, &u[k1 + k1 * u_dim1], + ldu, &c_b7, &wv[wv_offset], ldwv); + slacpy_("ALL", &jlen, &nu, &wv[wv_offset], ldwv, &z__[ + jrow + (incol + k1) * z_dim1], ldz); +/* L170: */ + } + } + } +/* L180: */ + } + +/* ==== End of SLAQR5 ==== */ + + return 0; +} /* slaqr5_ */ + diff --git a/lapack-netlib/SRC/slaqsb.c b/lapack-netlib/SRC/slaqsb.c new file mode 100644 index 000000000..f3c07db65 --- /dev/null +++ b/lapack-netlib/SRC/slaqsb.c @@ -0,0 +1,622 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#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 SLAQSB scales a symmetric/Hermitian band matrix, using scaling factors computed by spbequ. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAQSB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED ) */ + +/* CHARACTER EQUED, UPLO */ +/* INTEGER KD, LDAB, N */ +/* REAL AMAX, SCOND */ +/* REAL AB( LDAB, * ), S( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAQSB equilibrates a symmetric band matrix A using the scaling */ +/* > factors in the vector S. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of super-diagonals of the matrix A if UPLO = 'U', */ +/* > or the number of sub-diagonals if UPLO = 'L'. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is REAL array, dimension (LDAB,N) */ +/* > On entry, the upper or lower triangle of the symmetric band */ +/* > matrix A, stored in the first KD+1 rows of the array. The */ +/* > j-th column of A is stored in the j-th column of the array AB */ +/* > as follows: */ +/* > if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > */ +/* > On exit, if INFO = 0, the triangular factor U or L from the */ +/* > Cholesky factorization A = U**T*U or A = L*L**T of the band */ +/* > matrix A, in the same storage format as A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (N) */ +/* > The scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SCOND */ +/* > \verbatim */ +/* > SCOND is REAL */ +/* > Ratio of the smallest S(i) to the largest S(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AMAX */ +/* > \verbatim */ +/* > AMAX is REAL */ +/* > Absolute value of largest matrix entry. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies whether or not equilibration was done. */ +/* > = 'N': No equilibration. */ +/* > = 'Y': Equilibration was done, i.e., A has been replaced by */ +/* > diag(S) * A * diag(S). */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > THRESH is a threshold value used to decide if scaling should be done */ +/* > based on the ratio of the scaling factors. If SCOND < THRESH, */ +/* > scaling is done. */ +/* > */ +/* > LARGE and SMALL are threshold values used to decide if scaling should */ +/* > be done based on the absolute size of the largest matrix element. */ +/* > If AMAX > LARGE or AMAX < SMALL, scaling is done. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slaqsb_(char *uplo, integer *n, integer *kd, real *ab, + integer *ldab, real *s, real *scond, real *amax, char *equed) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__, j; + real large; + extern logical lsame_(char *, char *); + real small, cj; + extern real slamch_(char *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --s; + + /* Function Body */ + if (*n <= 0) { + *(unsigned char *)equed = 'N'; + return 0; + } + +/* Initialize LARGE and SMALL. */ + + small = slamch_("Safe minimum") / slamch_("Precision"); + large = 1.f / small; + + if (*scond >= .1f && *amax >= small && *amax <= large) { + +/* No equilibration */ + + *(unsigned char *)equed = 'N'; + } else { + +/* Replace A by diag(S) * A * diag(S). */ + + if (lsame_(uplo, "U")) { + +/* Upper triangle of A is stored in band format. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; +/* Computing MAX */ + i__2 = 1, i__3 = j - *kd; + i__4 = j; + for (i__ = f2cmax(i__2,i__3); i__ <= i__4; ++i__) { + ab[*kd + 1 + i__ - j + j * ab_dim1] = cj * s[i__] * ab[* + kd + 1 + i__ - j + j * ab_dim1]; +/* L10: */ + } +/* L20: */ + } + } else { + +/* Lower triangle of A is stored. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; +/* Computing MIN */ + i__2 = *n, i__3 = j + *kd; + i__4 = f2cmin(i__2,i__3); + for (i__ = j; i__ <= i__4; ++i__) { + ab[i__ + 1 - j + j * ab_dim1] = cj * s[i__] * ab[i__ + 1 + - j + j * ab_dim1]; +/* L30: */ + } +/* L40: */ + } + } + *(unsigned char *)equed = 'Y'; + } + + return 0; + +/* End of SLAQSB */ + +} /* slaqsb_ */ + diff --git a/lapack-netlib/SRC/slaqsp.c b/lapack-netlib/SRC/slaqsp.c new file mode 100644 index 000000000..9cb58948c --- /dev/null +++ b/lapack-netlib/SRC/slaqsp.c @@ -0,0 +1,606 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAQSP scales a symmetric/Hermitian matrix in packed storage, using scaling factors computed by + sppequ. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAQSP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED ) */ + +/* CHARACTER EQUED, UPLO */ +/* INTEGER N */ +/* REAL AMAX, SCOND */ +/* REAL AP( * ), S( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAQSP equilibrates a symmetric matrix A using the scaling factors */ +/* > in the vector S. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is REAL array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the symmetric matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > */ +/* > On exit, the equilibrated matrix: diag(S) * A * diag(S), in */ +/* > the same storage format as A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (N) */ +/* > The scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SCOND */ +/* > \verbatim */ +/* > SCOND is REAL */ +/* > Ratio of the smallest S(i) to the largest S(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AMAX */ +/* > \verbatim */ +/* > AMAX is REAL */ +/* > Absolute value of largest matrix entry. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies whether or not equilibration was done. */ +/* > = 'N': No equilibration. */ +/* > = 'Y': Equilibration was done, i.e., A has been replaced by */ +/* > diag(S) * A * diag(S). */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > THRESH is a threshold value used to decide if scaling should be done */ +/* > based on the ratio of the scaling factors. If SCOND < THRESH, */ +/* > scaling is done. */ +/* > */ +/* > LARGE and SMALL are threshold values used to decide if scaling should */ +/* > be done based on the absolute size of the largest matrix element. */ +/* > If AMAX > LARGE or AMAX < SMALL, scaling is done. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slaqsp_(char *uplo, integer *n, real *ap, real *s, real * + scond, real *amax, char *equed) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer i__, j; + real large; + extern logical lsame_(char *, char *); + real small; + integer jc; + real cj; + extern real slamch_(char *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + --s; + --ap; + + /* Function Body */ + if (*n <= 0) { + *(unsigned char *)equed = 'N'; + return 0; + } + +/* Initialize LARGE and SMALL. */ + + small = slamch_("Safe minimum") / slamch_("Precision"); + large = 1.f / small; + + if (*scond >= .1f && *amax >= small && *amax <= large) { + +/* No equilibration */ + + *(unsigned char *)equed = 'N'; + } else { + +/* Replace A by diag(S) * A * diag(S). */ + + if (lsame_(uplo, "U")) { + +/* Upper triangle of A is stored. */ + + jc = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ap[jc + i__ - 1] = cj * s[i__] * ap[jc + i__ - 1]; +/* L10: */ + } + jc += j; +/* L20: */ + } + } else { + +/* Lower triangle of A is stored. */ + + jc = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + ap[jc + i__ - j] = cj * s[i__] * ap[jc + i__ - j]; +/* L30: */ + } + jc = jc + *n - j + 1; +/* L40: */ + } + } + *(unsigned char *)equed = 'Y'; + } + + return 0; + +/* End of SLAQSP */ + +} /* slaqsp_ */ + diff --git a/lapack-netlib/SRC/slaqsy.c b/lapack-netlib/SRC/slaqsy.c new file mode 100644 index 000000000..2cf28e3b8 --- /dev/null +++ b/lapack-netlib/SRC/slaqsy.c @@ -0,0 +1,609 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLAQSY scales a symmetric/Hermitian matrix, using scaling factors computed by spoequ. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAQSY + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED ) */ + +/* CHARACTER EQUED, UPLO */ +/* INTEGER LDA, N */ +/* REAL AMAX, SCOND */ +/* REAL A( LDA, * ), S( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAQSY equilibrates a symmetric matrix A using the scaling factors */ +/* > in the vector S. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > n by n upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading n by n lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, if EQUED = 'Y', the equilibrated matrix: */ +/* > diag(S) * A * diag(S). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(N,1). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (N) */ +/* > The scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SCOND */ +/* > \verbatim */ +/* > SCOND is REAL */ +/* > Ratio of the smallest S(i) to the largest S(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AMAX */ +/* > \verbatim */ +/* > AMAX is REAL */ +/* > Absolute value of largest matrix entry. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies whether or not equilibration was done. */ +/* > = 'N': No equilibration. */ +/* > = 'Y': Equilibration was done, i.e., A has been replaced by */ +/* > diag(S) * A * diag(S). */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > THRESH is a threshold value used to decide if scaling should be done */ +/* > based on the ratio of the scaling factors. If SCOND < THRESH, */ +/* > scaling is done. */ +/* > */ +/* > LARGE and SMALL are threshold values used to decide if scaling should */ +/* > be done based on the absolute size of the largest matrix element. */ +/* > If AMAX > LARGE or AMAX < SMALL, scaling is done. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realSYauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slaqsy_(char *uplo, integer *n, real *a, integer *lda, + real *s, real *scond, real *amax, char *equed) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j; + real large; + extern logical lsame_(char *, char *); + real small, cj; + extern real slamch_(char *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --s; + + /* Function Body */ + if (*n <= 0) { + *(unsigned char *)equed = 'N'; + return 0; + } + +/* Initialize LARGE and SMALL. */ + + small = slamch_("Safe minimum") / slamch_("Precision"); + large = 1.f / small; + + if (*scond >= .1f && *amax >= small && *amax <= large) { + +/* No equilibration */ + + *(unsigned char *)equed = 'N'; + } else { + +/* Replace A by diag(S) * A * diag(S). */ + + if (lsame_(uplo, "U")) { + +/* Upper triangle of A is stored. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = cj * s[i__] * a[i__ + j * a_dim1]; +/* L10: */ + } +/* L20: */ + } + } else { + +/* Lower triangle of A is stored. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + cj = s[j]; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = cj * s[i__] * a[i__ + j * a_dim1]; +/* L30: */ + } +/* L40: */ + } + } + *(unsigned char *)equed = 'Y'; + } + + return 0; + +/* End of SLAQSY */ + +} /* slaqsy_ */ + diff --git a/lapack-netlib/SRC/slaqtr.c b/lapack-netlib/SRC/slaqtr.c new file mode 100644 index 000000000..5bb0d3e60 --- /dev/null +++ b/lapack-netlib/SRC/slaqtr.c @@ -0,0 +1,1269 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLAQTR solves a real quasi-triangular system of equations, or a complex quasi-triangular system + of special form, in real arithmetic. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAQTR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK, */ +/* INFO ) */ + +/* LOGICAL LREAL, LTRAN */ +/* INTEGER INFO, LDT, N */ +/* REAL SCALE, W */ +/* REAL B( * ), T( LDT, * ), WORK( * ), X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAQTR solves the real quasi-triangular system */ +/* > */ +/* > op(T)*p = scale*c, if LREAL = .TRUE. */ +/* > */ +/* > or the complex quasi-triangular systems */ +/* > */ +/* > op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE. */ +/* > */ +/* > in real arithmetic, where T is upper quasi-triangular. */ +/* > If LREAL = .FALSE., then the first diagonal block of T must be */ +/* > 1 by 1, B is the specially structured matrix */ +/* > */ +/* > B = [ b(1) b(2) ... b(n) ] */ +/* > [ w ] */ +/* > [ w ] */ +/* > [ . ] */ +/* > [ w ] */ +/* > */ +/* > op(A) = A or A**T, A**T denotes the transpose of */ +/* > matrix A. */ +/* > */ +/* > On input, X = [ c ]. On output, X = [ p ]. */ +/* > [ d ] [ q ] */ +/* > */ +/* > This subroutine is designed for the condition number estimation */ +/* > in routine STRSNA. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] LTRAN */ +/* > \verbatim */ +/* > LTRAN is LOGICAL */ +/* > On entry, LTRAN specifies the option of conjugate transpose: */ +/* > = .FALSE., op(T+i*B) = T+i*B, */ +/* > = .TRUE., op(T+i*B) = (T+i*B)**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LREAL */ +/* > \verbatim */ +/* > LREAL is LOGICAL */ +/* > On entry, LREAL specifies the input matrix structure: */ +/* > = .FALSE., the input is complex */ +/* > = .TRUE., the input is real */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > On entry, N specifies the order of T+i*B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is REAL array, dimension (LDT,N) */ +/* > On entry, T contains a matrix in Schur canonical form. */ +/* > If LREAL = .FALSE., then the first diagonal block of T must */ +/* > be 1 by 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the matrix T. LDT >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (N) */ +/* > On entry, B contains the elements to form the matrix */ +/* > B as described above. */ +/* > If LREAL = .TRUE., B is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] W */ +/* > \verbatim */ +/* > W is REAL */ +/* > On entry, W is the diagonal element of the matrix B. */ +/* > If LREAL = .TRUE., W is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE */ +/* > \verbatim */ +/* > SCALE is REAL */ +/* > On exit, SCALE is the scale factor. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (2*N) */ +/* > On entry, X contains the right hand side of the system. */ +/* > On exit, X is overwritten by the solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > On exit, INFO is set to */ +/* > 0: successful exit. */ +/* > 1: the some diagonal 1 by 1 block has been perturbed by */ +/* > a small number SMIN to keep nonsingularity. */ +/* > 2: the some diagonal 2 by 2 block has been perturbed by */ +/* > a small number in SLALN2 to keep nonsingularity. */ +/* > NOTE: In the interests of speed, this routine does not */ +/* > check the inputs for errors. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slaqtr_(logical *ltran, logical *lreal, integer *n, real + *t, integer *ldt, real *b, real *w, real *scale, real *x, real *work, + integer *info) +{ + /* System generated locals */ + integer t_dim1, t_offset, i__1, i__2; + real r__1, r__2, r__3, r__4, r__5, r__6; + + /* Local variables */ + integer ierr; + real smin; + extern real sdot_(integer *, real *, integer *, real *, integer *); + real xmax, d__[4] /* was [2][2] */; + integer i__, j, k; + real v[4] /* was [2][2] */, z__; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + integer jnext; + extern real sasum_(integer *, real *, integer *); + integer j1, j2; + real sminw; + integer n1, 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 *); + real si, xj, scaloc, sr; + extern real slamch_(char *), slange_(char *, integer *, integer *, + real *, integer *, real *); + real bignum; + extern integer isamax_(integer *, real *, integer *); + extern /* Subroutine */ int sladiv_(real *, real *, real *, real *, real * + , real *); + logical notran; + real smlnum, rec, eps, tjj, tmp; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Do not test the input parameters for errors */ + + /* Parameter adjustments */ + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + --b; + --x; + --work; + + /* Function Body */ + notran = ! (*ltran); + *info = 0; + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Set constants to control overflow */ + + eps = slamch_("P"); + smlnum = slamch_("S") / eps; + bignum = 1.f / smlnum; + + xnorm = slange_("M", n, n, &t[t_offset], ldt, d__); + if (! (*lreal)) { +/* Computing MAX */ + r__1 = xnorm, r__2 = abs(*w), r__1 = f2cmax(r__1,r__2), r__2 = slange_( + "M", n, &c__1, &b[1], n, d__); + xnorm = f2cmax(r__1,r__2); + } +/* Computing MAX */ + r__1 = smlnum, r__2 = eps * xnorm; + smin = f2cmax(r__1,r__2); + +/* 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) { + i__2 = j - 1; + work[j] = sasum_(&i__2, &t[j * t_dim1 + 1], &c__1); +/* L10: */ + } + + if (! (*lreal)) { + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + work[i__] += (r__1 = b[i__], abs(r__1)); +/* L20: */ + } + } + + n2 = *n << 1; + n1 = *n; + if (! (*lreal)) { + n1 = n2; + } + k = isamax_(&n1, &x[1], &c__1); + xmax = (r__1 = x[k], abs(r__1)); + *scale = 1.f; + + if (xmax > bignum) { + *scale = bignum / xmax; + sscal_(&n1, scale, &x[1], &c__1); + xmax = bignum; + } + + if (*lreal) { + + if (notran) { + +/* Solve T*p = scale*c */ + + jnext = *n; + for (j = *n; j >= 1; --j) { + if (j > jnext) { + goto L30; + } + j1 = j; + j2 = j; + jnext = j - 1; + if (j > 1) { + if (t[j + (j - 1) * t_dim1] != 0.f) { + j1 = j - 1; + jnext = j - 2; + } + } + + if (j1 == j2) { + +/* Meet 1 by 1 diagonal block */ + +/* Scale to avoid overflow when computing */ +/* x(j) = b(j)/T(j,j) */ + + xj = (r__1 = x[j1], abs(r__1)); + tjj = (r__1 = t[j1 + j1 * t_dim1], abs(r__1)); + tmp = t[j1 + j1 * t_dim1]; + if (tjj < smin) { + tmp = smin; + tjj = smin; + *info = 1; + } + + if (xj == 0.f) { + goto L30; + } + + if (tjj < 1.f) { + if (xj > bignum * tjj) { + rec = 1.f / xj; + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + x[j1] /= tmp; + xj = (r__1 = x[j1], abs(r__1)); + +/* Scale x if necessary to avoid overflow when adding a */ +/* multiple of column j1 of T. */ + + if (xj > 1.f) { + rec = 1.f / xj; + if (work[j1] > (bignum - xmax) * rec) { + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + } + } + if (j1 > 1) { + i__1 = j1 - 1; + r__1 = -x[j1]; + saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] + , &c__1); + i__1 = j1 - 1; + k = isamax_(&i__1, &x[1], &c__1); + xmax = (r__1 = x[k], abs(r__1)); + } + + } else { + +/* Meet 2 by 2 diagonal block */ + +/* Call 2 by 2 linear system solve, to take */ +/* care of possible overflow by scaling factor. */ + + d__[0] = x[j1]; + d__[1] = x[j2]; + slaln2_(&c_false, &c__2, &c__1, &smin, &c_b21, &t[j1 + j1 + * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, & + c_b25, &c_b25, v, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 2; + } + + if (scaloc != 1.f) { + sscal_(n, &scaloc, &x[1], &c__1); + *scale *= scaloc; + } + x[j1] = v[0]; + x[j2] = v[1]; + +/* Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2)) */ +/* to avoid overflow in updating right-hand side. */ + +/* Computing MAX */ + r__1 = abs(v[0]), r__2 = abs(v[1]); + xj = f2cmax(r__1,r__2); + if (xj > 1.f) { + rec = 1.f / xj; +/* Computing MAX */ + r__1 = work[j1], r__2 = work[j2]; + if (f2cmax(r__1,r__2) > (bignum - xmax) * rec) { + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + } + } + +/* Update right-hand side */ + + if (j1 > 1) { + i__1 = j1 - 1; + r__1 = -x[j1]; + saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] + , &c__1); + i__1 = j1 - 1; + r__1 = -x[j2]; + saxpy_(&i__1, &r__1, &t[j2 * t_dim1 + 1], &c__1, &x[1] + , &c__1); + i__1 = j1 - 1; + k = isamax_(&i__1, &x[1], &c__1); + xmax = (r__1 = x[k], abs(r__1)); + } + + } + +L30: + ; + } + + } else { + +/* Solve T**T*p = scale*c */ + + jnext = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (j < jnext) { + goto L40; + } + j1 = j; + j2 = j; + jnext = j + 1; + if (j < *n) { + if (t[j + 1 + j * t_dim1] != 0.f) { + j2 = j + 1; + jnext = j + 2; + } + } + + if (j1 == j2) { + +/* 1 by 1 diagonal block */ + +/* Scale if necessary to avoid overflow in forming the */ +/* right-hand side element by inner product. */ + + xj = (r__1 = x[j1], abs(r__1)); + if (xmax > 1.f) { + rec = 1.f / xmax; + if (work[j1] > (bignum - xj) * rec) { + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + + i__2 = j1 - 1; + x[j1] -= sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], & + c__1); + + xj = (r__1 = x[j1], abs(r__1)); + tjj = (r__1 = t[j1 + j1 * t_dim1], abs(r__1)); + tmp = t[j1 + j1 * t_dim1]; + if (tjj < smin) { + tmp = smin; + tjj = smin; + *info = 1; + } + + if (tjj < 1.f) { + if (xj > bignum * tjj) { + rec = 1.f / xj; + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + x[j1] /= tmp; +/* Computing MAX */ + r__2 = xmax, r__3 = (r__1 = x[j1], abs(r__1)); + xmax = f2cmax(r__2,r__3); + + } else { + +/* 2 by 2 diagonal block */ + +/* Scale if necessary to avoid overflow in forming the */ +/* right-hand side elements by inner product. */ + +/* Computing MAX */ + r__3 = (r__1 = x[j1], abs(r__1)), r__4 = (r__2 = x[j2], + abs(r__2)); + xj = f2cmax(r__3,r__4); + if (xmax > 1.f) { + rec = 1.f / xmax; +/* Computing MAX */ + r__1 = work[j2], r__2 = work[j1]; + if (f2cmax(r__1,r__2) > (bignum - xj) * rec) { + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + + i__2 = j1 - 1; + d__[0] = x[j1] - sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, + &x[1], &c__1); + i__2 = j1 - 1; + d__[1] = x[j2] - sdot_(&i__2, &t[j2 * t_dim1 + 1], &c__1, + &x[1], &c__1); + + slaln2_(&c_true, &c__2, &c__1, &smin, &c_b21, &t[j1 + j1 * + t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, &c_b25, + &c_b25, v, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 2; + } + + if (scaloc != 1.f) { + sscal_(n, &scaloc, &x[1], &c__1); + *scale *= scaloc; + } + x[j1] = v[0]; + x[j2] = v[1]; +/* Computing MAX */ + r__3 = (r__1 = x[j1], abs(r__1)), r__4 = (r__2 = x[j2], + abs(r__2)), r__3 = f2cmax(r__3,r__4); + xmax = f2cmax(r__3,xmax); + + } +L40: + ; + } + } + + } else { + +/* Computing MAX */ + r__1 = eps * abs(*w); + sminw = f2cmax(r__1,smin); + if (notran) { + +/* Solve (T + iB)*(p+iq) = c+id */ + + jnext = *n; + for (j = *n; j >= 1; --j) { + if (j > jnext) { + goto L70; + } + j1 = j; + j2 = j; + jnext = j - 1; + if (j > 1) { + if (t[j + (j - 1) * t_dim1] != 0.f) { + j1 = j - 1; + jnext = j - 2; + } + } + + if (j1 == j2) { + +/* 1 by 1 diagonal block */ + +/* Scale if necessary to avoid overflow in division */ + + z__ = *w; + if (j1 == 1) { + z__ = b[1]; + } + xj = (r__1 = x[j1], abs(r__1)) + (r__2 = x[*n + j1], abs( + r__2)); + tjj = (r__1 = t[j1 + j1 * t_dim1], abs(r__1)) + abs(z__); + tmp = t[j1 + j1 * t_dim1]; + if (tjj < sminw) { + tmp = sminw; + tjj = sminw; + *info = 1; + } + + if (xj == 0.f) { + goto L70; + } + + if (tjj < 1.f) { + if (xj > bignum * tjj) { + rec = 1.f / xj; + sscal_(&n2, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + sladiv_(&x[j1], &x[*n + j1], &tmp, &z__, &sr, &si); + x[j1] = sr; + x[*n + j1] = si; + xj = (r__1 = x[j1], abs(r__1)) + (r__2 = x[*n + j1], abs( + r__2)); + +/* Scale x if necessary to avoid overflow when adding a */ +/* multiple of column j1 of T. */ + + if (xj > 1.f) { + rec = 1.f / xj; + if (work[j1] > (bignum - xmax) * rec) { + sscal_(&n2, &rec, &x[1], &c__1); + *scale *= rec; + } + } + + if (j1 > 1) { + i__1 = j1 - 1; + r__1 = -x[j1]; + saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] + , &c__1); + i__1 = j1 - 1; + r__1 = -x[*n + j1]; + saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[* + n + 1], &c__1); + + x[1] += b[j1] * x[*n + j1]; + x[*n + 1] -= b[j1] * x[j1]; + + xmax = 0.f; + i__1 = j1 - 1; + for (k = 1; k <= i__1; ++k) { +/* Computing MAX */ + r__3 = xmax, r__4 = (r__1 = x[k], abs(r__1)) + ( + r__2 = x[k + *n], abs(r__2)); + xmax = f2cmax(r__3,r__4); +/* L50: */ + } + } + + } else { + +/* Meet 2 by 2 diagonal block */ + + d__[0] = x[j1]; + d__[1] = x[j2]; + d__[2] = x[*n + j1]; + d__[3] = x[*n + j2]; + r__1 = -(*w); + slaln2_(&c_false, &c__2, &c__2, &sminw, &c_b21, &t[j1 + + j1 * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, & + c_b25, &r__1, v, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 2; + } + + if (scaloc != 1.f) { + i__1 = *n << 1; + sscal_(&i__1, &scaloc, &x[1], &c__1); + *scale = scaloc * *scale; + } + x[j1] = v[0]; + x[j2] = v[1]; + x[*n + j1] = v[2]; + x[*n + j2] = v[3]; + +/* Scale X(J1), .... to avoid overflow in */ +/* updating right hand side. */ + +/* Computing MAX */ + r__1 = abs(v[0]) + abs(v[2]), r__2 = abs(v[1]) + abs(v[3]) + ; + xj = f2cmax(r__1,r__2); + if (xj > 1.f) { + rec = 1.f / xj; +/* Computing MAX */ + r__1 = work[j1], r__2 = work[j2]; + if (f2cmax(r__1,r__2) > (bignum - xmax) * rec) { + sscal_(&n2, &rec, &x[1], &c__1); + *scale *= rec; + } + } + +/* Update the right-hand side. */ + + if (j1 > 1) { + i__1 = j1 - 1; + r__1 = -x[j1]; + saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[1] + , &c__1); + i__1 = j1 - 1; + r__1 = -x[j2]; + saxpy_(&i__1, &r__1, &t[j2 * t_dim1 + 1], &c__1, &x[1] + , &c__1); + + i__1 = j1 - 1; + r__1 = -x[*n + j1]; + saxpy_(&i__1, &r__1, &t[j1 * t_dim1 + 1], &c__1, &x[* + n + 1], &c__1); + i__1 = j1 - 1; + r__1 = -x[*n + j2]; + saxpy_(&i__1, &r__1, &t[j2 * t_dim1 + 1], &c__1, &x[* + n + 1], &c__1); + + x[1] = x[1] + b[j1] * x[*n + j1] + b[j2] * x[*n + j2]; + x[*n + 1] = x[*n + 1] - b[j1] * x[j1] - b[j2] * x[j2]; + + xmax = 0.f; + i__1 = j1 - 1; + for (k = 1; k <= i__1; ++k) { +/* Computing MAX */ + r__3 = (r__1 = x[k], abs(r__1)) + (r__2 = x[k + * + n], abs(r__2)); + xmax = f2cmax(r__3,xmax); +/* L60: */ + } + } + + } +L70: + ; + } + + } else { + +/* Solve (T + iB)**T*(p+iq) = c+id */ + + jnext = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (j < jnext) { + goto L80; + } + j1 = j; + j2 = j; + jnext = j + 1; + if (j < *n) { + if (t[j + 1 + j * t_dim1] != 0.f) { + j2 = j + 1; + jnext = j + 2; + } + } + + if (j1 == j2) { + +/* 1 by 1 diagonal block */ + +/* Scale if necessary to avoid overflow in forming the */ +/* right-hand side element by inner product. */ + + xj = (r__1 = x[j1], abs(r__1)) + (r__2 = x[j1 + *n], abs( + r__2)); + if (xmax > 1.f) { + rec = 1.f / xmax; + if (work[j1] > (bignum - xj) * rec) { + sscal_(&n2, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + + i__2 = j1 - 1; + x[j1] -= sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[1], & + c__1); + i__2 = j1 - 1; + x[*n + j1] -= sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, &x[ + *n + 1], &c__1); + if (j1 > 1) { + x[j1] -= b[j1] * x[*n + 1]; + x[*n + j1] += b[j1] * x[1]; + } + xj = (r__1 = x[j1], abs(r__1)) + (r__2 = x[j1 + *n], abs( + r__2)); + + z__ = *w; + if (j1 == 1) { + z__ = b[1]; + } + +/* Scale if necessary to avoid overflow in */ +/* complex division */ + + tjj = (r__1 = t[j1 + j1 * t_dim1], abs(r__1)) + abs(z__); + tmp = t[j1 + j1 * t_dim1]; + if (tjj < sminw) { + tmp = sminw; + tjj = sminw; + *info = 1; + } + + if (tjj < 1.f) { + if (xj > bignum * tjj) { + rec = 1.f / xj; + sscal_(&n2, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + r__1 = -z__; + sladiv_(&x[j1], &x[*n + j1], &tmp, &r__1, &sr, &si); + x[j1] = sr; + x[j1 + *n] = si; +/* Computing MAX */ + r__3 = (r__1 = x[j1], abs(r__1)) + (r__2 = x[j1 + *n], + abs(r__2)); + xmax = f2cmax(r__3,xmax); + + } else { + +/* 2 by 2 diagonal block */ + +/* Scale if necessary to avoid overflow in forming the */ +/* right-hand side element by inner product. */ + +/* Computing MAX */ + r__5 = (r__1 = x[j1], abs(r__1)) + (r__2 = x[*n + j1], + abs(r__2)), r__6 = (r__3 = x[j2], abs(r__3)) + ( + r__4 = x[*n + j2], abs(r__4)); + xj = f2cmax(r__5,r__6); + if (xmax > 1.f) { + rec = 1.f / xmax; +/* Computing MAX */ + r__1 = work[j1], r__2 = work[j2]; + if (f2cmax(r__1,r__2) > (bignum - xj) / xmax) { + sscal_(&n2, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + + i__2 = j1 - 1; + d__[0] = x[j1] - sdot_(&i__2, &t[j1 * t_dim1 + 1], &c__1, + &x[1], &c__1); + i__2 = j1 - 1; + d__[1] = x[j2] - sdot_(&i__2, &t[j2 * t_dim1 + 1], &c__1, + &x[1], &c__1); + i__2 = j1 - 1; + d__[2] = x[*n + j1] - sdot_(&i__2, &t[j1 * t_dim1 + 1], & + c__1, &x[*n + 1], &c__1); + i__2 = j1 - 1; + d__[3] = x[*n + j2] - sdot_(&i__2, &t[j2 * t_dim1 + 1], & + c__1, &x[*n + 1], &c__1); + d__[0] -= b[j1] * x[*n + 1]; + d__[1] -= b[j2] * x[*n + 1]; + d__[2] += b[j1] * x[1]; + d__[3] += b[j2] * x[1]; + + slaln2_(&c_true, &c__2, &c__2, &sminw, &c_b21, &t[j1 + j1 + * t_dim1], ldt, &c_b21, &c_b21, d__, &c__2, & + c_b25, w, v, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 2; + } + + if (scaloc != 1.f) { + sscal_(&n2, &scaloc, &x[1], &c__1); + *scale = scaloc * *scale; + } + x[j1] = v[0]; + x[j2] = v[1]; + x[*n + j1] = v[2]; + x[*n + j2] = v[3]; +/* Computing MAX */ + r__5 = (r__1 = x[j1], abs(r__1)) + (r__2 = x[*n + j1], + abs(r__2)), r__6 = (r__3 = x[j2], abs(r__3)) + ( + r__4 = x[*n + j2], abs(r__4)), r__5 = f2cmax(r__5, + r__6); + xmax = f2cmax(r__5,xmax); + + } + +L80: + ; + } + + } + + } + + return 0; + +/* End of SLAQTR */ + +} /* slaqtr_ */ + diff --git a/lapack-netlib/SRC/slar1v.c b/lapack-netlib/SRC/slar1v.c new file mode 100644 index 000000000..e21bc99c0 --- /dev/null +++ b/lapack-netlib/SRC/slar1v.c @@ -0,0 +1,914 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLAR1V computes the (scaled) r-th column of the inverse of the submatrix in rows b1 through bn +of the tridiagonal matrix LDLT - λI. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAR1V + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD, */ +/* PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA, */ +/* R, ISUPPZ, NRMINV, RESID, RQCORR, WORK ) */ + +/* LOGICAL WANTNC */ +/* INTEGER B1, BN, N, NEGCNT, R */ +/* REAL GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID, */ +/* $ RQCORR, ZTZ */ +/* INTEGER ISUPPZ( * ) */ +/* REAL D( * ), L( * ), LD( * ), LLD( * ), */ +/* $ WORK( * ) */ +/* REAL Z( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAR1V computes the (scaled) r-th column of the inverse of */ +/* > the sumbmatrix in rows B1 through BN of the tridiagonal matrix */ +/* > L D L**T - sigma I. When sigma is close to an eigenvalue, the */ +/* > computed vector is an accurate eigenvector. Usually, r corresponds */ +/* > to the index where the eigenvector is largest in magnitude. */ +/* > The following steps accomplish this computation : */ +/* > (a) Stationary qd transform, L D L**T - sigma I = L(+) D(+) L(+)**T, */ +/* > (b) Progressive qd transform, L D L**T - sigma I = U(-) D(-) U(-)**T, */ +/* > (c) Computation of the diagonal elements of the inverse of */ +/* > L D L**T - sigma I by combining the above transforms, and choosing */ +/* > r as the index where the diagonal of the inverse is (one of the) */ +/* > largest in magnitude. */ +/* > (d) Computation of the (scaled) r-th column of the inverse using the */ +/* > twisted factorization obtained by combining the top part of the */ +/* > the stationary and the bottom part of the progressive transform. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix L D L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B1 */ +/* > \verbatim */ +/* > B1 is INTEGER */ +/* > First index of the submatrix of L D L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BN */ +/* > \verbatim */ +/* > BN is INTEGER */ +/* > Last index of the submatrix of L D L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LAMBDA */ +/* > \verbatim */ +/* > LAMBDA is REAL */ +/* > The shift. In order to compute an accurate eigenvector, */ +/* > LAMBDA should be a good approximation to an eigenvalue */ +/* > of L D L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is REAL array, dimension (N-1) */ +/* > The (n-1) subdiagonal elements of the unit bidiagonal matrix */ +/* > L, in elements 1 to N-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The n diagonal elements of the diagonal matrix D. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LD */ +/* > \verbatim */ +/* > LD is REAL array, dimension (N-1) */ +/* > The n-1 elements L(i)*D(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LLD */ +/* > \verbatim */ +/* > LLD is REAL array, dimension (N-1) */ +/* > The n-1 elements L(i)*L(i)*D(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PIVMIN */ +/* > \verbatim */ +/* > PIVMIN is REAL */ +/* > The minimum pivot in the Sturm sequence. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GAPTOL */ +/* > \verbatim */ +/* > GAPTOL is REAL */ +/* > Tolerance that indicates when eigenvector entries are negligible */ +/* > w.r.t. their contribution to the residual. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension (N) */ +/* > On input, all entries of Z must be set to 0. */ +/* > On output, Z contains the (scaled) r-th column of the */ +/* > inverse. The scaling is such that Z(R) equals 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTNC */ +/* > \verbatim */ +/* > WANTNC is LOGICAL */ +/* > Specifies whether NEGCNT has to be computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] NEGCNT */ +/* > \verbatim */ +/* > NEGCNT is INTEGER */ +/* > If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin */ +/* > in the matrix factorization L D L**T, and NEGCNT = -1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ZTZ */ +/* > \verbatim */ +/* > ZTZ is REAL */ +/* > The square of the 2-norm of Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] MINGMA */ +/* > \verbatim */ +/* > MINGMA is REAL */ +/* > The reciprocal of the largest (in magnitude) diagonal */ +/* > element of the inverse of L D L**T - sigma I. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] R */ +/* > \verbatim */ +/* > R is INTEGER */ +/* > The twist index for the twisted factorization used to */ +/* > compute Z. */ +/* > On input, 0 <= R <= N. If R is input as 0, R is set to */ +/* > the index where (L D L**T - sigma I)^{-1} is largest */ +/* > in magnitude. If 1 <= R <= N, R is unchanged. */ +/* > On output, R contains the twist index used to compute Z. */ +/* > Ideally, R designates the position of the maximum entry in the */ +/* > eigenvector. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ISUPPZ */ +/* > \verbatim */ +/* > ISUPPZ is INTEGER array, dimension (2) */ +/* > The support of the vector in Z, i.e., the vector Z is */ +/* > nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] NRMINV */ +/* > \verbatim */ +/* > NRMINV is REAL */ +/* > NRMINV = 1/SQRT( ZTZ ) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RESID */ +/* > \verbatim */ +/* > RESID is REAL */ +/* > The residual of the FP vector. */ +/* > RESID = ABS( MINGMA )/SQRT( ZTZ ) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RQCORR */ +/* > \verbatim */ +/* > RQCORR is REAL */ +/* > The Rayleigh Quotient correction to LAMBDA. */ +/* > RQCORR = MINGMA*TMP */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (4*N) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Beresford Parlett, University of California, Berkeley, USA \n */ +/* > Jim Demmel, University of California, Berkeley, USA \n */ +/* > Inderjit Dhillon, University of Texas, Austin, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ +/* > Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ +/* Subroutine */ int slar1v_(integer *n, integer *b1, integer *bn, real * + lambda, real *d__, real *l, real *ld, real *lld, real *pivmin, real * + gaptol, real *z__, logical *wantnc, integer *negcnt, real *ztz, real * + mingma, integer *r__, integer *isuppz, real *nrminv, real *resid, + real *rqcorr, real *work) +{ + /* System generated locals */ + integer i__1; + real r__1, r__2, r__3; + + /* Local variables */ + integer indp, inds, i__; + real s, dplus; + integer r1, r2; + extern real slamch_(char *); + integer indlpl, indumn; + extern logical sisnan_(real *); + real dminus; + logical sawnan1, sawnan2; + real eps, tmp; + integer neg1, neg2; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --work; + --isuppz; + --z__; + --lld; + --ld; + --l; + --d__; + + /* Function Body */ + eps = slamch_("Precision"); + if (*r__ == 0) { + r1 = *b1; + r2 = *bn; + } else { + r1 = *r__; + r2 = *r__; + } +/* Storage for LPLUS */ + indlpl = 0; +/* Storage for UMINUS */ + indumn = *n; + inds = (*n << 1) + 1; + indp = *n * 3 + 1; + if (*b1 == 1) { + work[inds] = 0.f; + } else { + work[inds + *b1 - 1] = lld[*b1 - 1]; + } + +/* Compute the stationary transform (using the differential form) */ +/* until the index R2. */ + + sawnan1 = FALSE_; + neg1 = 0; + s = work[inds + *b1 - 1] - *lambda; + i__1 = r1 - 1; + for (i__ = *b1; i__ <= i__1; ++i__) { + dplus = d__[i__] + s; + work[indlpl + i__] = ld[i__] / dplus; + if (dplus < 0.f) { + ++neg1; + } + work[inds + i__] = s * work[indlpl + i__] * l[i__]; + s = work[inds + i__] - *lambda; +/* L50: */ + } + sawnan1 = sisnan_(&s); + if (sawnan1) { + goto L60; + } + i__1 = r2 - 1; + for (i__ = r1; i__ <= i__1; ++i__) { + dplus = d__[i__] + s; + work[indlpl + i__] = ld[i__] / dplus; + work[inds + i__] = s * work[indlpl + i__] * l[i__]; + s = work[inds + i__] - *lambda; +/* L51: */ + } + sawnan1 = sisnan_(&s); + +L60: + if (sawnan1) { +/* Runs a slower version of the above loop if a NaN is detected */ + neg1 = 0; + s = work[inds + *b1 - 1] - *lambda; + i__1 = r1 - 1; + for (i__ = *b1; i__ <= i__1; ++i__) { + dplus = d__[i__] + s; + if (abs(dplus) < *pivmin) { + dplus = -(*pivmin); + } + work[indlpl + i__] = ld[i__] / dplus; + if (dplus < 0.f) { + ++neg1; + } + work[inds + i__] = s * work[indlpl + i__] * l[i__]; + if (work[indlpl + i__] == 0.f) { + work[inds + i__] = lld[i__]; + } + s = work[inds + i__] - *lambda; +/* L70: */ + } + i__1 = r2 - 1; + for (i__ = r1; i__ <= i__1; ++i__) { + dplus = d__[i__] + s; + if (abs(dplus) < *pivmin) { + dplus = -(*pivmin); + } + work[indlpl + i__] = ld[i__] / dplus; + work[inds + i__] = s * work[indlpl + i__] * l[i__]; + if (work[indlpl + i__] == 0.f) { + work[inds + i__] = lld[i__]; + } + s = work[inds + i__] - *lambda; +/* L71: */ + } + } + +/* Compute the progressive transform (using the differential form) */ +/* until the index R1 */ + + sawnan2 = FALSE_; + neg2 = 0; + work[indp + *bn - 1] = d__[*bn] - *lambda; + i__1 = r1; + for (i__ = *bn - 1; i__ >= i__1; --i__) { + dminus = lld[i__] + work[indp + i__]; + tmp = d__[i__] / dminus; + if (dminus < 0.f) { + ++neg2; + } + work[indumn + i__] = l[i__] * tmp; + work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda; +/* L80: */ + } + tmp = work[indp + r1 - 1]; + sawnan2 = sisnan_(&tmp); + if (sawnan2) { +/* Runs a slower version of the above loop if a NaN is detected */ + neg2 = 0; + i__1 = r1; + for (i__ = *bn - 1; i__ >= i__1; --i__) { + dminus = lld[i__] + work[indp + i__]; + if (abs(dminus) < *pivmin) { + dminus = -(*pivmin); + } + tmp = d__[i__] / dminus; + if (dminus < 0.f) { + ++neg2; + } + work[indumn + i__] = l[i__] * tmp; + work[indp + i__ - 1] = work[indp + i__] * tmp - *lambda; + if (tmp == 0.f) { + work[indp + i__ - 1] = d__[i__] - *lambda; + } +/* L100: */ + } + } + +/* Find the index (from R1 to R2) of the largest (in magnitude) */ +/* diagonal element of the inverse */ + + *mingma = work[inds + r1 - 1] + work[indp + r1 - 1]; + if (*mingma < 0.f) { + ++neg1; + } + if (*wantnc) { + *negcnt = neg1 + neg2; + } else { + *negcnt = -1; + } + if (abs(*mingma) == 0.f) { + *mingma = eps * work[inds + r1 - 1]; + } + *r__ = r1; + i__1 = r2 - 1; + for (i__ = r1; i__ <= i__1; ++i__) { + tmp = work[inds + i__] + work[indp + i__]; + if (tmp == 0.f) { + tmp = eps * work[inds + i__]; + } + if (abs(tmp) <= abs(*mingma)) { + *mingma = tmp; + *r__ = i__ + 1; + } +/* L110: */ + } + +/* Compute the FP vector: solve N^T v = e_r */ + + isuppz[1] = *b1; + isuppz[2] = *bn; + z__[*r__] = 1.f; + *ztz = 1.f; + +/* Compute the FP vector upwards from R */ + + if (! sawnan1 && ! sawnan2) { + i__1 = *b1; + for (i__ = *r__ - 1; i__ >= i__1; --i__) { + z__[i__] = -(work[indlpl + i__] * z__[i__ + 1]); + if (((r__1 = z__[i__], abs(r__1)) + (r__2 = z__[i__ + 1], abs( + r__2))) * (r__3 = ld[i__], abs(r__3)) < *gaptol) { + z__[i__] = 0.f; + isuppz[1] = i__ + 1; + goto L220; + } + *ztz += z__[i__] * z__[i__]; +/* L210: */ + } +L220: + ; + } else { +/* Run slower loop if NaN occurred. */ + i__1 = *b1; + for (i__ = *r__ - 1; i__ >= i__1; --i__) { + if (z__[i__ + 1] == 0.f) { + z__[i__] = -(ld[i__ + 1] / ld[i__]) * z__[i__ + 2]; + } else { + z__[i__] = -(work[indlpl + i__] * z__[i__ + 1]); + } + if (((r__1 = z__[i__], abs(r__1)) + (r__2 = z__[i__ + 1], abs( + r__2))) * (r__3 = ld[i__], abs(r__3)) < *gaptol) { + z__[i__] = 0.f; + isuppz[1] = i__ + 1; + goto L240; + } + *ztz += z__[i__] * z__[i__]; +/* L230: */ + } +L240: + ; + } +/* Compute the FP vector downwards from R in blocks of size BLKSIZ */ + if (! sawnan1 && ! sawnan2) { + i__1 = *bn - 1; + for (i__ = *r__; i__ <= i__1; ++i__) { + z__[i__ + 1] = -(work[indumn + i__] * z__[i__]); + if (((r__1 = z__[i__], abs(r__1)) + (r__2 = z__[i__ + 1], abs( + r__2))) * (r__3 = ld[i__], abs(r__3)) < *gaptol) { + z__[i__ + 1] = 0.f; + isuppz[2] = i__; + goto L260; + } + *ztz += z__[i__ + 1] * z__[i__ + 1]; +/* L250: */ + } +L260: + ; + } else { +/* Run slower loop if NaN occurred. */ + i__1 = *bn - 1; + for (i__ = *r__; i__ <= i__1; ++i__) { + if (z__[i__] == 0.f) { + z__[i__ + 1] = -(ld[i__ - 1] / ld[i__]) * z__[i__ - 1]; + } else { + z__[i__ + 1] = -(work[indumn + i__] * z__[i__]); + } + if (((r__1 = z__[i__], abs(r__1)) + (r__2 = z__[i__ + 1], abs( + r__2))) * (r__3 = ld[i__], abs(r__3)) < *gaptol) { + z__[i__ + 1] = 0.f; + isuppz[2] = i__; + goto L280; + } + *ztz += z__[i__ + 1] * z__[i__ + 1]; +/* L270: */ + } +L280: + ; + } + +/* Compute quantities for convergence test */ + + tmp = 1.f / *ztz; + *nrminv = sqrt(tmp); + *resid = abs(*mingma) * *nrminv; + *rqcorr = *mingma * tmp; + + + return 0; + +/* End of SLAR1V */ + +} /* slar1v_ */ + diff --git a/lapack-netlib/SRC/slar2v.c b/lapack-netlib/SRC/slar2v.c new file mode 100644 index 000000000..00f9c1853 --- /dev/null +++ b/lapack-netlib/SRC/slar2v.c @@ -0,0 +1,558 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLAR2V applies a vector of plane rotations with real cosines and real sines from both sides to +a sequence of 2-by-2 symmetric/Hermitian matrices. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAR2V + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAR2V( N, X, Y, Z, INCX, C, S, INCC ) */ + +/* INTEGER INCC, INCX, N */ +/* REAL C( * ), S( * ), X( * ), Y( * ), Z( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAR2V applies a vector of real plane rotations from both sides to */ +/* > a sequence of 2-by-2 real symmetric matrices, defined by the elements */ +/* > of the vectors x, y and z. For i = 1,2,...,n */ +/* > */ +/* > ( x(i) z(i) ) := ( c(i) s(i) ) ( x(i) z(i) ) ( c(i) -s(i) ) */ +/* > ( z(i) y(i) ) ( -s(i) c(i) ) ( z(i) y(i) ) ( s(i) c(i) ) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of plane rotations to be applied. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is REAL array, */ +/* > dimension (1+(N-1)*INCX) */ +/* > The vector x. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is REAL array, */ +/* > dimension (1+(N-1)*INCX) */ +/* > The vector y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is REAL array, */ +/* > dimension (1+(N-1)*INCX) */ +/* > The vector z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The increment between elements of X, Y and Z. INCX > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (1+(N-1)*INCC) */ +/* > The cosines of the plane rotations. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (1+(N-1)*INCC) */ +/* > The sines of the plane rotations. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCC */ +/* > \verbatim */ +/* > INCC is INTEGER */ +/* > The increment between elements of C and S. INCC > 0. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slar2v_(integer *n, real *x, real *y, real *z__, integer + *incx, real *c__, real *s, integer *incc) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__; + real t1, t2, t3, t4, t5, t6; + integer ic; + real ci, si; + integer ix; + real xi, yi, zi; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --s; + --c__; + --z__; + --y; + --x; + + /* Function Body */ + ix = 1; + ic = 1; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + xi = x[ix]; + yi = y[ix]; + zi = z__[ix]; + ci = c__[ic]; + si = s[ic]; + t1 = si * zi; + t2 = ci * zi; + t3 = t2 - si * xi; + t4 = t2 + si * yi; + t5 = ci * xi + t1; + t6 = ci * yi - t1; + x[ix] = ci * t5 + si * t4; + y[ix] = ci * t6 - si * t3; + z__[ix] = ci * t4 - si * t5; + ix += *incx; + ic += *incc; +/* L10: */ + } + +/* End of SLAR2V */ + + return 0; +} /* slar2v_ */ + diff --git a/lapack-netlib/SRC/slarf.c b/lapack-netlib/SRC/slarf.c new file mode 100644 index 000000000..e3f87fef4 --- /dev/null +++ b/lapack-netlib/SRC/slarf.c @@ -0,0 +1,627 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLARF applies an elementary reflector to a general rectangular matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK ) */ + +/* CHARACTER SIDE */ +/* INTEGER INCV, LDC, M, N */ +/* REAL TAU */ +/* REAL C( LDC, * ), V( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARF applies a real elementary reflector H to a real m by n matrix */ +/* > C, from either the left or the right. H is represented in the form */ +/* > */ +/* > H = I - tau * v * v**T */ +/* > */ +/* > where tau is a real scalar and v is a real vector. */ +/* > */ +/* > If tau = 0, then H is taken to be the unit matrix. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': form H * C */ +/* > = 'R': form C * H */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is REAL array, dimension */ +/* > (1 + (M-1)*abs(INCV)) if SIDE = 'L' */ +/* > or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */ +/* > The vector v in the representation of H. V is not used if */ +/* > TAU = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCV */ +/* > \verbatim */ +/* > INCV is INTEGER */ +/* > The increment between elements of v. INCV <> 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is REAL */ +/* > The value tau in the representation of H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (LDC,N) */ +/* > On entry, the m by n matrix C. */ +/* > On exit, C is overwritten by the matrix H * C if SIDE = 'L', */ +/* > or C * H if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension */ +/* > (N) if SIDE = 'L' */ +/* > or (M) if SIDE = 'R' */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slarf_(char *side, integer *m, integer *n, real *v, + integer *incv, real *tau, real *c__, integer *ldc, real *work) +{ + /* System generated locals */ + integer c_dim1, c_offset; + real r__1; + + /* Local variables */ + extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, + integer *, real *, integer *, real *, integer *); + integer i__; + extern logical lsame_(char *, char *); + integer lastc; + extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *); + integer lastv; + logical applyleft; + extern integer ilaslc_(integer *, integer *, real *, integer *), ilaslr_( + integer *, integer *, real *, integer *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --v; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + applyleft = lsame_(side, "L"); + lastv = 0; + lastc = 0; + if (*tau != 0.f) { +/* Set up variables for scanning V. LASTV begins pointing to the end */ +/* of V. */ + if (applyleft) { + lastv = *m; + } else { + lastv = *n; + } + if (*incv > 0) { + i__ = (lastv - 1) * *incv + 1; + } else { + i__ = 1; + } +/* Look for the last non-zero row in V. */ + while(lastv > 0 && v[i__] == 0.f) { + --lastv; + i__ -= *incv; + } + if (applyleft) { +/* Scan for the last non-zero column in C(1:lastv,:). */ + lastc = ilaslc_(&lastv, n, &c__[c_offset], ldc); + } else { +/* Scan for the last non-zero row in C(:,1:lastv). */ + lastc = ilaslr_(m, &lastv, &c__[c_offset], ldc); + } + } +/* Note that lastc.eq.0 renders the BLAS operations null; no special */ +/* case is needed at this level. */ + if (applyleft) { + +/* Form H * C */ + + if (lastv > 0) { + +/* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1) */ + + sgemv_("Transpose", &lastv, &lastc, &c_b4, &c__[c_offset], ldc, & + v[1], incv, &c_b5, &work[1], &c__1); + +/* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T */ + + r__1 = -(*tau); + sger_(&lastv, &lastc, &r__1, &v[1], incv, &work[1], &c__1, &c__[ + c_offset], ldc); + } + } else { + +/* Form C * H */ + + if (lastv > 0) { + +/* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) */ + + sgemv_("No transpose", &lastc, &lastv, &c_b4, &c__[c_offset], ldc, + &v[1], incv, &c_b5, &work[1], &c__1); + +/* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T */ + + r__1 = -(*tau); + sger_(&lastc, &lastv, &r__1, &work[1], &c__1, &v[1], incv, &c__[ + c_offset], ldc); + } + } + return 0; + +/* End of SLARF */ + +} /* slarf_ */ + diff --git a/lapack-netlib/SRC/slarfb.c b/lapack-netlib/SRC/slarfb.c new file mode 100644 index 000000000..8c5a4f9f9 --- /dev/null +++ b/lapack-netlib/SRC/slarfb.c @@ -0,0 +1,1213 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLARFB applies a block reflector or its transpose to a general rectangular matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARFB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV, */ +/* T, LDT, C, LDC, WORK, LDWORK ) */ + +/* CHARACTER DIRECT, SIDE, STOREV, TRANS */ +/* INTEGER K, LDC, LDT, LDV, LDWORK, M, N */ +/* REAL C( LDC, * ), T( LDT, * ), V( LDV, * ), */ +/* $ WORK( LDWORK, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARFB applies a real block reflector H or its transpose H**T to a */ +/* > real m by n matrix C, from either the left or the right. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply H or H**T from the Left */ +/* > = 'R': apply H or H**T from the Right */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': apply H (No transpose) */ +/* > = 'T': apply H**T (Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIRECT */ +/* > \verbatim */ +/* > DIRECT is CHARACTER*1 */ +/* > Indicates how H is formed from a product of elementary */ +/* > reflectors */ +/* > = 'F': H = H(1) H(2) . . . H(k) (Forward) */ +/* > = 'B': H = H(k) . . . H(2) H(1) (Backward) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] STOREV */ +/* > \verbatim */ +/* > STOREV is CHARACTER*1 */ +/* > Indicates how the vectors which define the elementary */ +/* > reflectors are stored: */ +/* > = 'C': Columnwise */ +/* > = 'R': Rowwise */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The order of the matrix T (= the number of elementary */ +/* > reflectors whose product defines the block reflector). */ +/* > If SIDE = 'L', M >= K >= 0; */ +/* > if SIDE = 'R', N >= K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is 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 matrix V. 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] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (LDC,N) */ +/* > On entry, the m by n matrix C. */ +/* > On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T. */ +/* > \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 REAL array, dimension (LDWORK,K) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDWORK */ +/* > \verbatim */ +/* > LDWORK is INTEGER */ +/* > The leading dimension of the array WORK. */ +/* > If SIDE = 'L', LDWORK >= f2cmax(1,N); */ +/* > if SIDE = 'R', LDWORK >= f2cmax(1,M). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2013 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The shape of the matrix V and the storage of the vectors which define */ +/* > the H(i) is best illustrated by the following example with n = 5 and */ +/* > k = 3. The elements equal to 1 are not stored; the corresponding */ +/* > array elements are modified but restored on exit. The rest of the */ +/* > array is not used. */ +/* > */ +/* > DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */ +/* > */ +/* > V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */ +/* > ( v1 1 ) ( 1 v2 v2 v2 ) */ +/* > ( v1 v2 1 ) ( 1 v3 v3 ) */ +/* > ( v1 v2 v3 ) */ +/* > ( v1 v2 v3 ) */ +/* > */ +/* > DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */ +/* > */ +/* > V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */ +/* > ( v1 v2 v3 ) ( v2 v2 v2 1 ) */ +/* > ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */ +/* > ( 1 v3 ) */ +/* > ( 1 ) */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slarfb_(char *side, char *trans, char *direct, char * + storev, integer *m, integer *n, integer *k, real *v, integer *ldv, + real *t, integer *ldt, real *c__, integer *ldc, real *work, integer * + ldwork) +{ + /* System generated locals */ + integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, + work_offset, i__1, i__2; + + /* Local variables */ + 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 *), scopy_(integer *, real *, + integer *, real *, integer *), strmm_(char *, char *, char *, + char *, integer *, integer *, real *, real *, integer *, real *, + integer *); + char transt[1]; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2013 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + work_dim1 = *ldwork; + work_offset = 1 + work_dim1 * 1; + work -= work_offset; + + /* Function Body */ + if (*m <= 0 || *n <= 0) { + return 0; + } + + if (lsame_(trans, "N")) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + + if (lsame_(storev, "C")) { + + if (lsame_(direct, "F")) { + +/* Let V = ( V1 ) (first K rows) */ +/* ( V2 ) */ +/* where V1 is unit lower triangular. */ + + if (lsame_(side, "L")) { + +/* Form H * C or H**T * C where C = ( C1 ) */ +/* ( C2 ) */ + +/* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) */ + +/* W := C1**T */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + scopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], + &c__1); +/* L10: */ + } + +/* W := W * V1 */ + + strmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b14, + &v[v_offset], ldv, &work[work_offset], ldwork); + if (*m > *k) { + +/* W := W + C2**T * V2 */ + + i__1 = *m - *k; + sgemm_("Transpose", "No transpose", n, k, &i__1, &c_b14, & + c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + v_dim1], + ldv, &c_b14, &work[work_offset], ldwork); + } + +/* W := W * T**T or W * T */ + + strmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - V * W**T */ + + if (*m > *k) { + +/* C2 := C2 - V2 * W**T */ + + i__1 = *m - *k; + sgemm_("No transpose", "Transpose", &i__1, n, k, &c_b25, & + v[*k + 1 + v_dim1], ldv, &work[work_offset], + ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc); + } + +/* W := W * V1**T */ + + strmm_("Right", "Lower", "Transpose", "Unit", n, k, &c_b14, & + v[v_offset], ldv, &work[work_offset], ldwork); + +/* C1 := C1 - W**T */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; +/* L20: */ + } +/* L30: */ + } + + } else if (lsame_(side, "R")) { + +/* Form C * H or C * H**T where C = ( C1 C2 ) */ + +/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ + +/* W := C1 */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + scopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * + work_dim1 + 1], &c__1); +/* L40: */ + } + +/* W := W * V1 */ + + strmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b14, + &v[v_offset], ldv, &work[work_offset], ldwork); + if (*n > *k) { + +/* W := W + C2 * V2 */ + + i__1 = *n - *k; + sgemm_("No transpose", "No transpose", m, k, &i__1, & + c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + + 1 + v_dim1], ldv, &c_b14, &work[work_offset], + ldwork); + } + +/* W := W * T or W * T**T */ + + strmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - W * V**T */ + + if (*n > *k) { + +/* C2 := C2 - W * V2**T */ + + i__1 = *n - *k; + sgemm_("No transpose", "Transpose", m, &i__1, k, &c_b25, & + work[work_offset], ldwork, &v[*k + 1 + v_dim1], + ldv, &c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc); + } + +/* W := W * V1**T */ + + strmm_("Right", "Lower", "Transpose", "Unit", m, k, &c_b14, & + v[v_offset], ldv, &work[work_offset], ldwork); + +/* C1 := C1 - W */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; +/* L50: */ + } +/* L60: */ + } + } + + } else { + +/* Let V = ( V1 ) */ +/* ( V2 ) (last K rows) */ +/* where V2 is unit upper triangular. */ + + if (lsame_(side, "L")) { + +/* Form H * C or H**T * C where C = ( C1 ) */ +/* ( C2 ) */ + +/* W := C**T * V = (C1**T * V1 + C2**T * V2) (stored in WORK) */ + +/* W := C2**T */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + scopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * + work_dim1 + 1], &c__1); +/* L70: */ + } + +/* W := W * V2 */ + + strmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b14, + &v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], + ldwork); + if (*m > *k) { + +/* W := W + C1**T * V1 */ + + i__1 = *m - *k; + sgemm_("Transpose", "No transpose", n, k, &i__1, &c_b14, & + c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & + work[work_offset], ldwork); + } + +/* W := W * T**T or W * T */ + + strmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - V * W**T */ + + if (*m > *k) { + +/* C1 := C1 - V1 * W**T */ + + i__1 = *m - *k; + sgemm_("No transpose", "Transpose", &i__1, n, k, &c_b25, & + v[v_offset], ldv, &work[work_offset], ldwork, & + c_b14, &c__[c_offset], ldc) + ; + } + +/* W := W * V2**T */ + + strmm_("Right", "Upper", "Transpose", "Unit", n, k, &c_b14, & + v[*m - *k + 1 + v_dim1], ldv, &work[work_offset], + ldwork); + +/* C2 := C2 - W**T */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j * + work_dim1]; +/* L80: */ + } +/* L90: */ + } + + } else if (lsame_(side, "R")) { + +/* Form C * H or C * H' where C = ( C1 C2 ) */ + +/* W := C * V = (C1*V1 + C2*V2) (stored in WORK) */ + +/* W := C2 */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + scopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[ + j * work_dim1 + 1], &c__1); +/* L100: */ + } + +/* W := W * V2 */ + + strmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b14, + &v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], + ldwork); + if (*n > *k) { + +/* W := W + C1 * V1 */ + + i__1 = *n - *k; + sgemm_("No transpose", "No transpose", m, k, &i__1, & + c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, & + c_b14, &work[work_offset], ldwork); + } + +/* W := W * T or W * T**T */ + + strmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - W * V**T */ + + if (*n > *k) { + +/* C1 := C1 - W * V1**T */ + + i__1 = *n - *k; + sgemm_("No transpose", "Transpose", m, &i__1, k, &c_b25, & + work[work_offset], ldwork, &v[v_offset], ldv, & + c_b14, &c__[c_offset], ldc) + ; + } + +/* W := W * V2**T */ + + strmm_("Right", "Upper", "Transpose", "Unit", m, k, &c_b14, & + v[*n - *k + 1 + v_dim1], ldv, &work[work_offset], + ldwork); + +/* C2 := C2 - W */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j * + work_dim1]; +/* L110: */ + } +/* L120: */ + } + } + } + + } else if (lsame_(storev, "R")) { + + if (lsame_(direct, "F")) { + +/* Let V = ( V1 V2 ) (V1: first K columns) */ +/* where V1 is unit upper triangular. */ + + if (lsame_(side, "L")) { + +/* Form H * C or H**T * C where C = ( C1 ) */ +/* ( C2 ) */ + +/* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) */ + +/* W := C1**T */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + scopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], + &c__1); +/* L130: */ + } + +/* W := W * V1**T */ + + strmm_("Right", "Upper", "Transpose", "Unit", n, k, &c_b14, & + v[v_offset], ldv, &work[work_offset], ldwork); + if (*m > *k) { + +/* W := W + C2**T * V2**T */ + + i__1 = *m - *k; + sgemm_("Transpose", "Transpose", n, k, &i__1, &c_b14, & + c__[*k + 1 + c_dim1], ldc, &v[(*k + 1) * v_dim1 + + 1], ldv, &c_b14, &work[work_offset], ldwork); + } + +/* W := W * T**T or W * T */ + + strmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - V**T * W**T */ + + if (*m > *k) { + +/* C2 := C2 - V2**T * W**T */ + + i__1 = *m - *k; + sgemm_("Transpose", "Transpose", &i__1, n, k, &c_b25, &v[( + *k + 1) * v_dim1 + 1], ldv, &work[work_offset], + ldwork, &c_b14, &c__[*k + 1 + c_dim1], ldc); + } + +/* W := W * V1 */ + + strmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b14, + &v[v_offset], ldv, &work[work_offset], ldwork); + +/* C1 := C1 - W**T */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1]; +/* L140: */ + } +/* L150: */ + } + + } else if (lsame_(side, "R")) { + +/* Form C * H or C * H**T where C = ( C1 C2 ) */ + +/* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) */ + +/* W := C1 */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + scopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * + work_dim1 + 1], &c__1); +/* L160: */ + } + +/* W := W * V1**T */ + + strmm_("Right", "Upper", "Transpose", "Unit", m, k, &c_b14, & + v[v_offset], ldv, &work[work_offset], ldwork); + if (*n > *k) { + +/* W := W + C2 * V2**T */ + + i__1 = *n - *k; + sgemm_("No transpose", "Transpose", m, k, &i__1, &c_b14, & + c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k + 1) * + v_dim1 + 1], ldv, &c_b14, &work[work_offset], + ldwork); + } + +/* W := W * T or W * T**T */ + + strmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - W * V */ + + if (*n > *k) { + +/* C2 := C2 - W * V2 */ + + i__1 = *n - *k; + sgemm_("No transpose", "No transpose", m, &i__1, k, & + c_b25, &work[work_offset], ldwork, &v[(*k + 1) * + v_dim1 + 1], ldv, &c_b14, &c__[(*k + 1) * c_dim1 + + 1], ldc); + } + +/* W := W * V1 */ + + strmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b14, + &v[v_offset], ldv, &work[work_offset], ldwork); + +/* C1 := C1 - W */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; +/* L170: */ + } +/* L180: */ + } + + } + + } else { + +/* Let V = ( V1 V2 ) (V2: last K columns) */ +/* where V2 is unit lower triangular. */ + + if (lsame_(side, "L")) { + +/* Form H * C or H**T * C where C = ( C1 ) */ +/* ( C2 ) */ + +/* W := C**T * V**T = (C1**T * V1**T + C2**T * V2**T) (stored in WORK) */ + +/* W := C2**T */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + scopy_(n, &c__[*m - *k + j + c_dim1], ldc, &work[j * + work_dim1 + 1], &c__1); +/* L190: */ + } + +/* W := W * V2**T */ + + strmm_("Right", "Lower", "Transpose", "Unit", n, k, &c_b14, & + v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[work_offset] + , ldwork); + if (*m > *k) { + +/* W := W + C1**T * V1**T */ + + i__1 = *m - *k; + sgemm_("Transpose", "Transpose", n, k, &i__1, &c_b14, & + c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & + work[work_offset], ldwork); + } + +/* W := W * T**T or W * T */ + + strmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - V**T * W**T */ + + if (*m > *k) { + +/* C1 := C1 - V1**T * W**T */ + + i__1 = *m - *k; + sgemm_("Transpose", "Transpose", &i__1, n, k, &c_b25, &v[ + v_offset], ldv, &work[work_offset], ldwork, & + c_b14, &c__[c_offset], ldc); + } + +/* W := W * V2 */ + + strmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b14, + &v[(*m - *k + 1) * v_dim1 + 1], ldv, &work[ + work_offset], ldwork); + +/* C2 := C2 - W**T */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[*m - *k + j + i__ * c_dim1] -= work[i__ + j * + work_dim1]; +/* L200: */ + } +/* L210: */ + } + + } else if (lsame_(side, "R")) { + +/* Form C * H or C * H**T where C = ( C1 C2 ) */ + +/* W := C * V**T = (C1*V1**T + C2*V2**T) (stored in WORK) */ + +/* W := C2 */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + scopy_(m, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &work[ + j * work_dim1 + 1], &c__1); +/* L220: */ + } + +/* W := W * V2**T */ + + strmm_("Right", "Lower", "Transpose", "Unit", m, k, &c_b14, & + v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[work_offset] + , ldwork); + if (*n > *k) { + +/* W := W + C1 * V1**T */ + + i__1 = *n - *k; + sgemm_("No transpose", "Transpose", m, k, &i__1, &c_b14, & + c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, & + work[work_offset], ldwork); + } + +/* W := W * T or W * T**T */ + + strmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b14, &t[ + t_offset], ldt, &work[work_offset], ldwork); + +/* C := C - W * V */ + + if (*n > *k) { + +/* C1 := C1 - W * V1 */ + + i__1 = *n - *k; + sgemm_("No transpose", "No transpose", m, &i__1, k, & + c_b25, &work[work_offset], ldwork, &v[v_offset], + ldv, &c_b14, &c__[c_offset], ldc); + } + +/* W := W * V2 */ + + strmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b14, + &v[(*n - *k + 1) * v_dim1 + 1], ldv, &work[ + work_offset], ldwork); + +/* C1 := C1 - W */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + (*n - *k + j) * c_dim1] -= work[i__ + j * + work_dim1]; +/* L230: */ + } +/* L240: */ + } + + } + + } + } + + return 0; + +/* End of SLARFB */ + +} /* slarfb_ */ + diff --git a/lapack-netlib/SRC/slarfb_gett.c b/lapack-netlib/SRC/slarfb_gett.c new file mode 100644 index 000000000..dde1636f8 --- /dev/null +++ b/lapack-netlib/SRC/slarfb_gett.c @@ -0,0 +1,1015 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLARFB_GETT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARFB_GETT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARFB_GETT( IDENT, M, N, K, T, LDT, A, LDA, B, LDB, */ +/* $ WORK, LDWORK ) */ +/* IMPLICIT NONE */ + +/* CHARACTER IDENT */ +/* INTEGER K, LDA, LDB, LDT, LDWORK, M, N */ +/* REAL A( LDA, * ), B( LDB, * ), T( LDT, * ), */ +/* $ WORK( LDWORK, * ) */ + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARFB_GETT applies a real Householder block reflector H from the */ +/* > left to a real (K+M)-by-N "triangular-pentagonal" matrix */ +/* > composed of two block matrices: an upper trapezoidal K-by-N matrix A */ +/* > stored in the array A, and a rectangular M-by-(N-K) matrix B, stored */ +/* > in the array B. The block reflector H is stored in a compact */ +/* > WY-representation, where the elementary reflectors are in the */ +/* > arrays A, B and T. See Further Details section. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] IDENT */ +/* > \verbatim */ +/* > IDENT is CHARACTER*1 */ +/* > If IDENT = not 'I', or not 'i', then V1 is unit */ +/* > lower-triangular and stored in the left K-by-K block of */ +/* > the input matrix A, */ +/* > If IDENT = 'I' or 'i', then V1 is an identity matrix and */ +/* > not stored. */ +/* > See Further Details section. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix B. */ +/* > M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrices A and B. */ +/* > N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number or rows of the matrix A. */ +/* > K is also order of the matrix T, i.e. the number of */ +/* > elementary reflectors whose product defines the block */ +/* > reflector. 0 <= K <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is REAL array, dimension (LDT,K) */ +/* > The upper-triangular K-by-K matrix T in the representation */ +/* > of the block reflector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= K. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > */ +/* > On entry: */ +/* > a) In the K-by-N upper-trapezoidal part A: input matrix A. */ +/* > b) In the columns below the diagonal: columns of V1 */ +/* > (ones are not stored on the diagonal). */ +/* > */ +/* > On exit: */ +/* > A is overwritten by rectangular K-by-N product H*A. */ +/* > */ +/* > See Further Details section. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,K). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,N) */ +/* > */ +/* > On entry: */ +/* > a) In the M-by-(N-K) right block: input matrix B. */ +/* > b) In the M-by-N left block: columns of V2. */ +/* > */ +/* > On exit: */ +/* > B is overwritten by rectangular M-by-N product H*B. */ +/* > */ +/* > See Further Details section. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, */ +/* > dimension (LDWORK,f2cmax(K,N-K)) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDWORK */ +/* > \verbatim */ +/* > LDWORK is INTEGER */ +/* > The leading dimension of the array WORK. LDWORK>=f2cmax(1,K). */ +/* > */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup singleOTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2020, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > \endverbatim */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > (1) Description of the Algebraic Operation. */ +/* > */ +/* > The matrix A is a K-by-N matrix composed of two column block */ +/* > matrices, A1, which is K-by-K, and A2, which is K-by-(N-K): */ +/* > A = ( A1, A2 ). */ +/* > The matrix B is an M-by-N matrix composed of two column block */ +/* > matrices, B1, which is M-by-K, and B2, which is M-by-(N-K): */ +/* > B = ( B1, B2 ). */ +/* > */ +/* > Perform the operation: */ +/* > */ +/* > ( A_out ) := H * ( A_in ) = ( I - V * T * V**T ) * ( A_in ) = */ +/* > ( B_out ) ( B_in ) ( B_in ) */ +/* > = ( I - ( V1 ) * T * ( V1**T, V2**T ) ) * ( A_in ) */ +/* > ( V2 ) ( B_in ) */ +/* > On input: */ +/* > */ +/* > a) ( A_in ) consists of two block columns: */ +/* > ( B_in ) */ +/* > */ +/* > ( A_in ) = (( A1_in ) ( A2_in )) = (( A1_in ) ( A2_in )) */ +/* > ( B_in ) (( B1_in ) ( B2_in )) (( 0 ) ( B2_in )), */ +/* > */ +/* > where the column blocks are: */ +/* > */ +/* > ( A1_in ) is a K-by-K upper-triangular matrix stored in the */ +/* > upper triangular part of the array A(1:K,1:K). */ +/* > ( B1_in ) is an M-by-K rectangular ZERO matrix and not stored. */ +/* > */ +/* > ( A2_in ) is a K-by-(N-K) rectangular matrix stored */ +/* > in the array A(1:K,K+1:N). */ +/* > ( B2_in ) is an M-by-(N-K) rectangular matrix stored */ +/* > in the array B(1:M,K+1:N). */ +/* > */ +/* > b) V = ( V1 ) */ +/* > ( V2 ) */ +/* > */ +/* > where: */ +/* > 1) if IDENT == 'I',V1 is a K-by-K identity matrix, not stored; */ +/* > 2) if IDENT != 'I',V1 is a K-by-K unit lower-triangular matrix, */ +/* > stored in the lower-triangular part of the array */ +/* > A(1:K,1:K) (ones are not stored), */ +/* > and V2 is an M-by-K rectangular stored the array B(1:M,1:K), */ +/* > (because on input B1_in is a rectangular zero */ +/* > matrix that is not stored and the space is */ +/* > used to store V2). */ +/* > */ +/* > c) T is a K-by-K upper-triangular matrix stored */ +/* > in the array T(1:K,1:K). */ +/* > */ +/* > On output: */ +/* > */ +/* > a) ( A_out ) consists of two block columns: */ +/* > ( B_out ) */ +/* > */ +/* > ( A_out ) = (( A1_out ) ( A2_out )) */ +/* > ( B_out ) (( B1_out ) ( B2_out )), */ +/* > */ +/* > where the column blocks are: */ +/* > */ +/* > ( A1_out ) is a K-by-K square matrix, or a K-by-K */ +/* > upper-triangular matrix, if V1 is an */ +/* > identity matrix. AiOut is stored in */ +/* > the array A(1:K,1:K). */ +/* > ( B1_out ) is an M-by-K rectangular matrix stored */ +/* > in the array B(1:M,K:N). */ +/* > */ +/* > ( A2_out ) is a K-by-(N-K) rectangular matrix stored */ +/* > in the array A(1:K,K+1:N). */ +/* > ( B2_out ) is an M-by-(N-K) rectangular matrix stored */ +/* > in the array B(1:M,K+1:N). */ +/* > */ +/* > */ +/* > The operation above can be represented as the same operation */ +/* > on each block column: */ +/* > */ +/* > ( A1_out ) := H * ( A1_in ) = ( I - V * T * V**T ) * ( A1_in ) */ +/* > ( B1_out ) ( 0 ) ( 0 ) */ +/* > */ +/* > ( A2_out ) := H * ( A2_in ) = ( I - V * T * V**T ) * ( A2_in ) */ +/* > ( B2_out ) ( B2_in ) ( B2_in ) */ +/* > */ +/* > If IDENT != 'I': */ +/* > */ +/* > The computation for column block 1: */ +/* > */ +/* > A1_out: = A1_in - V1*T*(V1**T)*A1_in */ +/* > */ +/* > B1_out: = - V2*T*(V1**T)*A1_in */ +/* > */ +/* > The computation for column block 2, which exists if N > K: */ +/* > */ +/* > A2_out: = A2_in - V1*T*( (V1**T)*A2_in + (V2**T)*B2_in ) */ +/* > */ +/* > B2_out: = B2_in - V2*T*( (V1**T)*A2_in + (V2**T)*B2_in ) */ +/* > */ +/* > If IDENT == 'I': */ +/* > */ +/* > The operation for column block 1: */ +/* > */ +/* > A1_out: = A1_in - V1*T**A1_in */ +/* > */ +/* > B1_out: = - V2*T**A1_in */ +/* > */ +/* > The computation for column block 2, which exists if N > K: */ +/* > */ +/* > A2_out: = A2_in - T*( A2_in + (V2**T)*B2_in ) */ +/* > */ +/* > B2_out: = B2_in - V2*T*( A2_in + (V2**T)*B2_in ) */ +/* > */ +/* > (2) Description of the Algorithmic Computation. */ +/* > */ +/* > In the first step, we compute column block 2, i.e. A2 and B2. */ +/* > Here, we need to use the K-by-(N-K) rectangular workspace */ +/* > matrix W2 that is of the same size as the matrix A2. */ +/* > W2 is stored in the array WORK(1:K,1:(N-K)). */ +/* > */ +/* > In the second step, we compute column block 1, i.e. A1 and B1. */ +/* > Here, we need to use the K-by-K square workspace matrix W1 */ +/* > that is of the same size as the as the matrix A1. */ +/* > W1 is stored in the array WORK(1:K,1:K). */ +/* > */ +/* > NOTE: Hence, in this routine, we need the workspace array WORK */ +/* > only of size WORK(1:K,1:f2cmax(K,N-K)) so it can hold both W2 from */ +/* > the first step and W1 from the second step. */ +/* > */ +/* > Case (A), when V1 is unit lower-triangular, i.e. IDENT != 'I', */ +/* > more computations than in the Case (B). */ +/* > */ +/* > if( IDENT != 'I' ) then */ +/* > if ( N > K ) then */ +/* > (First Step - column block 2) */ +/* > col2_(1) W2: = A2 */ +/* > col2_(2) W2: = (V1**T) * W2 = (unit_lower_tr_of_(A1)**T) * W2 */ +/* > col2_(3) W2: = W2 + (V2**T) * B2 = W2 + (B1**T) * B2 */ +/* > col2_(4) W2: = T * W2 */ +/* > col2_(5) B2: = B2 - V2 * W2 = B2 - B1 * W2 */ +/* > col2_(6) W2: = V1 * W2 = unit_lower_tr_of_(A1) * W2 */ +/* > col2_(7) A2: = A2 - W2 */ +/* > else */ +/* > (Second Step - column block 1) */ +/* > col1_(1) W1: = A1 */ +/* > col1_(2) W1: = (V1**T) * W1 = (unit_lower_tr_of_(A1)**T) * W1 */ +/* > col1_(3) W1: = T * W1 */ +/* > col1_(4) B1: = - V2 * W1 = - B1 * W1 */ +/* > col1_(5) square W1: = V1 * W1 = unit_lower_tr_of_(A1) * W1 */ +/* > col1_(6) square A1: = A1 - W1 */ +/* > end if */ +/* > end if */ +/* > */ +/* > Case (B), when V1 is an identity matrix, i.e. IDENT == 'I', */ +/* > less computations than in the Case (A) */ +/* > */ +/* > if( IDENT == 'I' ) then */ +/* > if ( N > K ) then */ +/* > (First Step - column block 2) */ +/* > col2_(1) W2: = A2 */ +/* > col2_(3) W2: = W2 + (V2**T) * B2 = W2 + (B1**T) * B2 */ +/* > col2_(4) W2: = T * W2 */ +/* > col2_(5) B2: = B2 - V2 * W2 = B2 - B1 * W2 */ +/* > col2_(7) A2: = A2 - W2 */ +/* > else */ +/* > (Second Step - column block 1) */ +/* > col1_(1) W1: = A1 */ +/* > col1_(3) W1: = T * W1 */ +/* > col1_(4) B1: = - V2 * W1 = - B1 * W1 */ +/* > col1_(6) upper-triangular_of_(A1): = A1 - W1 */ +/* > end if */ +/* > end if */ +/* > */ +/* > Combine these cases (A) and (B) together, this is the resulting */ +/* > algorithm: */ +/* > */ +/* > if ( N > K ) then */ +/* > */ +/* > (First Step - column block 2) */ +/* > */ +/* > col2_(1) W2: = A2 */ +/* > if( IDENT != 'I' ) then */ +/* > col2_(2) W2: = (V1**T) * W2 */ +/* > = (unit_lower_tr_of_(A1)**T) * W2 */ +/* > end if */ +/* > col2_(3) W2: = W2 + (V2**T) * B2 = W2 + (B1**T) * B2] */ +/* > col2_(4) W2: = T * W2 */ +/* > col2_(5) B2: = B2 - V2 * W2 = B2 - B1 * W2 */ +/* > if( IDENT != 'I' ) then */ +/* > col2_(6) W2: = V1 * W2 = unit_lower_tr_of_(A1) * W2 */ +/* > end if */ +/* > col2_(7) A2: = A2 - W2 */ +/* > */ +/* > else */ +/* > */ +/* > (Second Step - column block 1) */ +/* > */ +/* > col1_(1) W1: = A1 */ +/* > if( IDENT != 'I' ) then */ +/* > col1_(2) W1: = (V1**T) * W1 */ +/* > = (unit_lower_tr_of_(A1)**T) * W1 */ +/* > end if */ +/* > col1_(3) W1: = T * W1 */ +/* > col1_(4) B1: = - V2 * W1 = - B1 * W1 */ +/* > if( IDENT != 'I' ) then */ +/* > col1_(5) square W1: = V1 * W1 = unit_lower_tr_of_(A1) * W1 */ +/* > col1_(6_a) below_diag_of_(A1): = - below_diag_of_(W1) */ +/* > end if */ +/* > col1_(6_b) up_tr_of_(A1): = up_tr_of_(A1) - up_tr_of_(W1) */ +/* > */ +/* > end if */ +/* > */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slarfb_gett_(char *ident, integer *m, integer *n, + integer *k, 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, work_dim1, + work_offset, i__1, i__2; + + /* Local variables */ + 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 *), scopy_(integer *, real *, + integer *, real *, integer *), strmm_(char *, char *, char *, + char *, integer *, integer *, real *, real *, integer *, real *, + integer *); + logical lnotident; + + +/* -- LAPACK auxiliary routine -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + work_dim1 = *ldwork; + work_offset = 1 + work_dim1 * 1; + work -= work_offset; + + /* Function Body */ + if (*m < 0 || *n <= 0 || *k == 0 || *k > *n) { + return 0; + } + + lnotident = ! lsame_(ident, "I"); + +/* ------------------------------------------------------------------ */ + +/* First Step. Computation of the Column Block 2: */ + +/* ( A2 ) := H * ( A2 ) */ +/* ( B2 ) ( B2 ) */ + +/* ------------------------------------------------------------------ */ + + if (*n > *k) { + +/* col2_(1) Compute W2: = A2. Therefore, copy A2 = A(1:K, K+1:N) */ +/* into W2=WORK(1:K, 1:N-K) column-by-column. */ + + i__1 = *n - *k; + for (j = 1; j <= i__1; ++j) { + scopy_(k, &a[(*k + j) * a_dim1 + 1], &c__1, &work[j * work_dim1 + + 1], &c__1); + } + if (lnotident) { + +/* col2_(2) Compute W2: = (V1**T) * W2 = (A1**T) * W2, */ +/* V1 is not an identy matrix, but unit lower-triangular */ +/* V1 stored in A1 (diagonal ones are not stored). */ + + + i__1 = *n - *k; + strmm_("L", "L", "T", "U", k, &i__1, &c_b9, &a[a_offset], lda, & + work[work_offset], ldwork); + } + +/* col2_(3) Compute W2: = W2 + (V2**T) * B2 = W2 + (B1**T) * B2 */ +/* V2 stored in B1. */ + + if (*m > 0) { + i__1 = *n - *k; + sgemm_("T", "N", k, &i__1, m, &c_b9, &b[b_offset], ldb, &b[(*k + + 1) * b_dim1 + 1], ldb, &c_b9, &work[work_offset], ldwork); + } + +/* col2_(4) Compute W2: = T * W2, */ +/* T is upper-triangular. */ + + i__1 = *n - *k; + strmm_("L", "U", "N", "N", k, &i__1, &c_b9, &t[t_offset], ldt, &work[ + work_offset], ldwork); + +/* col2_(5) Compute B2: = B2 - V2 * W2 = B2 - B1 * W2, */ +/* V2 stored in B1. */ + + if (*m > 0) { + i__1 = *n - *k; + sgemm_("N", "N", m, &i__1, k, &c_b21, &b[b_offset], ldb, &work[ + work_offset], ldwork, &c_b9, &b[(*k + 1) * b_dim1 + 1], + ldb); + } + + if (lnotident) { + +/* col2_(6) Compute W2: = V1 * W2 = A1 * W2, */ +/* V1 is not an identity matrix, but unit lower-triangular, */ +/* V1 stored in A1 (diagonal ones are not stored). */ + + i__1 = *n - *k; + strmm_("L", "L", "N", "U", k, &i__1, &c_b9, &a[a_offset], lda, & + work[work_offset], ldwork); + } + +/* col2_(7) Compute A2: = A2 - W2 = */ +/* = A(1:K, K+1:N-K) - WORK(1:K, 1:N-K), */ +/* column-by-column. */ + + i__1 = *n - *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + (*k + j) * a_dim1] -= work[i__ + j * work_dim1]; + } + } + + } + +/* ------------------------------------------------------------------ */ + +/* Second Step. Computation of the Column Block 1: */ + +/* ( A1 ) := H * ( A1 ) */ +/* ( B1 ) ( 0 ) */ + +/* ------------------------------------------------------------------ */ + +/* col1_(1) Compute W1: = A1. Copy the upper-triangular */ +/* A1 = A(1:K, 1:K) into the upper-triangular */ +/* W1 = WORK(1:K, 1:K) column-by-column. */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + scopy_(&j, &a[j * a_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &c__1) + ; + } + +/* Set the subdiagonal elements of W1 to zero column-by-column. */ + + i__1 = *k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] = 0.f; + } + } + + if (lnotident) { + +/* col1_(2) Compute W1: = (V1**T) * W1 = (A1**T) * W1, */ +/* V1 is not an identity matrix, but unit lower-triangular */ +/* V1 stored in A1 (diagonal ones are not stored), */ +/* W1 is upper-triangular with zeroes below the diagonal. */ + + strmm_("L", "L", "T", "U", k, k, &c_b9, &a[a_offset], lda, &work[ + work_offset], ldwork); + } + +/* col1_(3) Compute W1: = T * W1, */ +/* T is upper-triangular, */ +/* W1 is upper-triangular with zeroes below the diagonal. */ + + strmm_("L", "U", "N", "N", k, k, &c_b9, &t[t_offset], ldt, &work[ + work_offset], ldwork); + +/* col1_(4) Compute B1: = - V2 * W1 = - B1 * W1, */ +/* V2 = B1, W1 is upper-triangular with zeroes below the diagonal. */ + + if (*m > 0) { + strmm_("R", "U", "N", "N", m, k, &c_b21, &work[work_offset], ldwork, & + b[b_offset], ldb); + } + + if (lnotident) { + +/* col1_(5) Compute W1: = V1 * W1 = A1 * W1, */ +/* V1 is not an identity matrix, but unit lower-triangular */ +/* V1 stored in A1 (diagonal ones are not stored), */ +/* W1 is upper-triangular on input with zeroes below the diagonal, */ +/* and square on output. */ + + strmm_("L", "L", "N", "U", k, k, &c_b9, &a[a_offset], lda, &work[ + work_offset], ldwork); + +/* col1_(6) Compute A1: = A1 - W1 = A(1:K, 1:K) - WORK(1:K, 1:K) */ +/* column-by-column. A1 is upper-triangular on input. */ +/* If IDENT, A1 is square on output, and W1 is square, */ +/* if NOT IDENT, A1 is upper-triangular on output, */ +/* W1 is upper-triangular. */ + +/* col1_(6)_a Compute elements of A1 below the diagonal. */ + + i__1 = *k - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = -work[i__ + j * work_dim1]; + } + } + + } + +/* col1_(6)_b Compute elements of A1 on and above the diagonal. */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] -= work[i__ + j * work_dim1]; + } + } + + return 0; + +/* End of SLARFB_GETT */ + +} /* slarfb_gett__ */ + diff --git a/lapack-netlib/SRC/slarfg.c b/lapack-netlib/SRC/slarfg.c new file mode 100644 index 000000000..66d02f8a9 --- /dev/null +++ b/lapack-netlib/SRC/slarfg.c @@ -0,0 +1,588 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLARFG generates an elementary reflector (Householder matrix). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARFG + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARFG( N, ALPHA, X, INCX, TAU ) */ + +/* INTEGER INCX, N */ +/* REAL ALPHA, TAU */ +/* REAL X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARFG generates a real elementary reflector H of order n, such */ +/* > that */ +/* > */ +/* > H * ( alpha ) = ( beta ), H**T * H = I. */ +/* > ( x ) ( 0 ) */ +/* > */ +/* > where alpha and beta are scalars, and x is an (n-1)-element real */ +/* > vector. H is represented in the form */ +/* > */ +/* > H = I - tau * ( 1 ) * ( 1 v**T ) , */ +/* > ( v ) */ +/* > */ +/* > where tau is a real scalar and v is a real (n-1)-element */ +/* > vector. */ +/* > */ +/* > If the elements of x are all zero, then tau = 0 and H is taken to be */ +/* > the unit matrix. */ +/* > */ +/* > Otherwise 1 <= tau <= 2. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the elementary reflector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ALPHA */ +/* > \verbatim */ +/* > ALPHA is REAL */ +/* > On entry, the value alpha. */ +/* > On exit, it is overwritten with the value beta. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension */ +/* > (1+(N-2)*abs(INCX)) */ +/* > On entry, the vector x. */ +/* > On exit, it is overwritten with the vector v. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The increment between elements of X. INCX > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is REAL */ +/* > The value tau. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slarfg_(integer *n, real *alpha, real *x, integer *incx, + real *tau) +{ + /* System generated locals */ + integer i__1; + real r__1; + + /* Local variables */ + real beta; + extern real snrm2_(integer *, real *, integer *); + integer j; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + real xnorm; + extern real slapy2_(real *, real *), slamch_(char *); + real safmin, rsafmn; + integer knt; + + +/* -- LAPACK auxiliary routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --x; + + /* Function Body */ + if (*n <= 1) { + *tau = 0.f; + return 0; + } + + i__1 = *n - 1; + xnorm = snrm2_(&i__1, &x[1], incx); + + if (xnorm == 0.f) { + +/* H = I */ + + *tau = 0.f; + } else { + +/* general case */ + + r__1 = slapy2_(alpha, &xnorm); + beta = -r_sign(&r__1, alpha); + safmin = slamch_("S") / slamch_("E"); + knt = 0; + if (abs(beta) < safmin) { + +/* XNORM, BETA may be inaccurate; scale X and recompute them */ + + rsafmn = 1.f / safmin; +L10: + ++knt; + i__1 = *n - 1; + sscal_(&i__1, &rsafmn, &x[1], incx); + beta *= rsafmn; + *alpha *= rsafmn; + if (abs(beta) < safmin && knt < 20) { + goto L10; + } + +/* New BETA is at most 1, at least SAFMIN */ + + i__1 = *n - 1; + xnorm = snrm2_(&i__1, &x[1], incx); + r__1 = slapy2_(alpha, &xnorm); + beta = -r_sign(&r__1, alpha); + } + *tau = (beta - *alpha) / beta; + i__1 = *n - 1; + r__1 = 1.f / (*alpha - beta); + sscal_(&i__1, &r__1, &x[1], incx); + +/* If ALPHA is subnormal, it may lose relative accuracy */ + + i__1 = knt; + for (j = 1; j <= i__1; ++j) { + beta *= safmin; +/* L20: */ + } + *alpha = beta; + } + + return 0; + +/* End of SLARFG */ + +} /* slarfg_ */ + diff --git a/lapack-netlib/SRC/slarfgp.c b/lapack-netlib/SRC/slarfgp.c new file mode 100644 index 000000000..26a8a9ea9 --- /dev/null +++ b/lapack-netlib/SRC/slarfgp.c @@ -0,0 +1,636 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLARFGP generates an elementary reflector (Householder matrix) with non-negative beta. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARFGP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARFGP( N, ALPHA, X, INCX, TAU ) */ + +/* INTEGER INCX, N */ +/* REAL ALPHA, TAU */ +/* REAL X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARFGP generates a real elementary reflector H of order n, such */ +/* > that */ +/* > */ +/* > H * ( alpha ) = ( beta ), H**T * H = I. */ +/* > ( x ) ( 0 ) */ +/* > */ +/* > where alpha and beta are scalars, beta is non-negative, and x is */ +/* > an (n-1)-element real vector. H is represented in the form */ +/* > */ +/* > H = I - tau * ( 1 ) * ( 1 v**T ) , */ +/* > ( v ) */ +/* > */ +/* > where tau is a real scalar and v is a real (n-1)-element */ +/* > vector. */ +/* > */ +/* > If the elements of x are all zero, then tau = 0 and H is taken to be */ +/* > the unit matrix. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the elementary reflector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ALPHA */ +/* > \verbatim */ +/* > ALPHA is REAL */ +/* > On entry, the value alpha. */ +/* > On exit, it is overwritten with the value beta. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension */ +/* > (1+(N-2)*abs(INCX)) */ +/* > On entry, the vector x. */ +/* > On exit, it is overwritten with the vector v. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The increment between elements of X. INCX > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is REAL */ +/* > The value tau. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slarfgp_(integer *n, real *alpha, real *x, integer *incx, + real *tau) +{ + /* System generated locals */ + integer i__1; + real r__1; + + /* Local variables */ + real beta; + extern real snrm2_(integer *, real *, integer *); + integer j; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + real savealpha, xnorm; + extern real slapy2_(real *, real *), slamch_(char *); + real bignum, smlnum; + integer knt; + + +/* -- LAPACK auxiliary routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --x; + + /* Function Body */ + if (*n <= 0) { + *tau = 0.f; + return 0; + } + + i__1 = *n - 1; + xnorm = snrm2_(&i__1, &x[1], incx); + + if (xnorm == 0.f) { + +/* H = [+/-1, 0; I], sign chosen so ALPHA >= 0. */ + + if (*alpha >= 0.f) { +/* When TAU.eq.ZERO, the vector is special-cased to be */ +/* all zeros in the application routines. We do not need */ +/* to clear it. */ + *tau = 0.f; + } else { +/* However, the application routines rely on explicit */ +/* zero checks when TAU.ne.ZERO, and we must clear X. */ + *tau = 2.f; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + x[(j - 1) * *incx + 1] = 0.f; + } + *alpha = -(*alpha); + } + } else { + +/* general case */ + + r__1 = slapy2_(alpha, &xnorm); + beta = r_sign(&r__1, alpha); + smlnum = slamch_("S") / slamch_("E"); + knt = 0; + if (abs(beta) < smlnum) { + +/* XNORM, BETA may be inaccurate; scale X and recompute them */ + + bignum = 1.f / smlnum; +L10: + ++knt; + i__1 = *n - 1; + sscal_(&i__1, &bignum, &x[1], incx); + beta *= bignum; + *alpha *= bignum; + if (abs(beta) < smlnum && knt < 20) { + goto L10; + } + +/* New BETA is at most 1, at least SMLNUM */ + + i__1 = *n - 1; + xnorm = snrm2_(&i__1, &x[1], incx); + r__1 = slapy2_(alpha, &xnorm); + beta = r_sign(&r__1, alpha); + } + savealpha = *alpha; + *alpha += beta; + if (beta < 0.f) { + beta = -beta; + *tau = -(*alpha) / beta; + } else { + *alpha = xnorm * (xnorm / *alpha); + *tau = *alpha / beta; + *alpha = -(*alpha); + } + + if (abs(*tau) <= smlnum) { + +/* In the case where the computed TAU ends up being a denormalized number, */ +/* it loses relative accuracy. This is a BIG problem. Solution: flush TAU */ +/* to ZERO. This explains the next IF statement. */ + +/* (Bug report provided by Pat Quillen from MathWorks on Jul 29, 2009.) */ +/* (Thanks Pat. Thanks MathWorks.) */ + + if (savealpha >= 0.f) { + *tau = 0.f; + } else { + *tau = 2.f; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + x[(j - 1) * *incx + 1] = 0.f; + } + beta = -savealpha; + } + + } else { + +/* This is the general case. */ + + i__1 = *n - 1; + r__1 = 1.f / *alpha; + sscal_(&i__1, &r__1, &x[1], incx); + + } + +/* If BETA is subnormal, it may lose relative accuracy */ + + i__1 = knt; + for (j = 1; j <= i__1; ++j) { + beta *= smlnum; +/* L20: */ + } + *alpha = beta; + } + + return 0; + +/* End of SLARFGP */ + +} /* slarfgp_ */ + diff --git a/lapack-netlib/SRC/slarft.c b/lapack-netlib/SRC/slarft.c new file mode 100644 index 000000000..241fe57b5 --- /dev/null +++ b/lapack-netlib/SRC/slarft.c @@ -0,0 +1,763 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLARFT forms the triangular factor T of a block reflector H = I - vtvH */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARFT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) */ + +/* CHARACTER DIRECT, STOREV */ +/* INTEGER K, LDT, LDV, N */ +/* REAL T( LDT, * ), TAU( * ), V( LDV, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARFT forms the triangular factor T of a real block reflector H */ +/* > of order n, which is defined as a product of k elementary reflectors. */ +/* > */ +/* > If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */ +/* > */ +/* > If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */ +/* > */ +/* > If STOREV = 'C', the vector which defines the elementary reflector */ +/* > H(i) is stored in the i-th column of the array V, and */ +/* > */ +/* > H = I - V * T * V**T */ +/* > */ +/* > If STOREV = 'R', the vector which defines the elementary reflector */ +/* > H(i) is stored in the i-th row of the array V, and */ +/* > */ +/* > H = I - V**T * T * V */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] DIRECT */ +/* > \verbatim */ +/* > DIRECT is CHARACTER*1 */ +/* > Specifies the order in which the elementary reflectors are */ +/* > multiplied to form the block reflector: */ +/* > = 'F': H = H(1) H(2) . . . H(k) (Forward) */ +/* > = 'B': H = H(k) . . . H(2) H(1) (Backward) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] STOREV */ +/* > \verbatim */ +/* > STOREV is CHARACTER*1 */ +/* > Specifies how the vectors which define the elementary */ +/* > reflectors are stored (see also Further Details): */ +/* > = 'C': columnwise */ +/* > = 'R': rowwise */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the block reflector H. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The order of the triangular factor T (= the number of */ +/* > elementary reflectors). K >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is REAL array, dimension */ +/* > (LDV,K) if STOREV = 'C' */ +/* > (LDV,N) if STOREV = 'R' */ +/* > The matrix V. See further details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. */ +/* > If STOREV = 'C', LDV >= f2cmax(1,N); if STOREV = 'R', LDV >= K. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is REAL array, dimension (K) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is REAL array, dimension (LDT,K) */ +/* > The k by k triangular factor T of the block reflector. */ +/* > If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */ +/* > lower triangular. The rest of the array is not used. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= K. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The shape of the matrix V and the storage of the vectors which define */ +/* > the H(i) is best illustrated by the following example with n = 5 and */ +/* > k = 3. The elements equal to 1 are not stored. */ +/* > */ +/* > DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */ +/* > */ +/* > V = ( 1 ) V = ( 1 v1 v1 v1 v1 ) */ +/* > ( v1 1 ) ( 1 v2 v2 v2 ) */ +/* > ( v1 v2 1 ) ( 1 v3 v3 ) */ +/* > ( v1 v2 v3 ) */ +/* > ( v1 v2 v3 ) */ +/* > */ +/* > DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */ +/* > */ +/* > V = ( v1 v2 v3 ) V = ( v1 v1 1 ) */ +/* > ( v1 v2 v3 ) ( v2 v2 v2 1 ) */ +/* > ( 1 v2 v3 ) ( v3 v3 v3 v3 1 ) */ +/* > ( 1 v3 ) */ +/* > ( 1 ) */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slarft_(char *direct, char *storev, integer *n, integer * + k, real *v, integer *ldv, real *tau, real *t, integer *ldt) +{ + /* System generated locals */ + integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3; + real r__1; + + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *); + integer lastv; + extern /* Subroutine */ int strmv_(char *, char *, char *, integer *, + real *, integer *, real *, integer *); + integer prevlastv; + extern /* Subroutine */ int mecago_(); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + --tau; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + + /* Function Body */ + if (*n == 0) { + return 0; + } + + if (lsame_(direct, "F")) { + prevlastv = *n; + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + prevlastv = f2cmax(i__,prevlastv); + if (tau[i__] == 0.f) { + +/* H(i) = I */ + + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + t[j + i__ * t_dim1] = 0.f; + } + } else { + +/* general case */ + + if (lsame_(storev, "C")) { +/* Skip any trailing zeros. */ + i__2 = i__ + 1; + for (lastv = *n; lastv >= i__2; --lastv) { + if (v[lastv + i__ * v_dim1] != 0.f) { + myexit_(); + } + } + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[j + i__ * t_dim1] = -tau[i__] * v[i__ + j * v_dim1]; + } + j = f2cmin(lastv,prevlastv); + +/* T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) */ + + i__2 = j - i__; + i__3 = i__ - 1; + r__1 = -tau[i__]; + sgemv_("Transpose", &i__2, &i__3, &r__1, &v[i__ + 1 + + v_dim1], ldv, &v[i__ + 1 + i__ * v_dim1], &c__1, & + c_b6, &t[i__ * t_dim1 + 1], &c__1); + } else { +/* Skip any trailing zeros. */ + i__2 = i__ + 1; + for (lastv = *n; lastv >= i__2; --lastv) { + if (v[i__ + lastv * v_dim1] != 0.f) { + myexit_(); + } + } + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[j + i__ * t_dim1] = -tau[i__] * v[j + i__ * v_dim1]; + } + j = f2cmin(lastv,prevlastv); + +/* T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T */ + + i__2 = i__ - 1; + i__3 = j - i__; + r__1 = -tau[i__]; + sgemv_("No transpose", &i__2, &i__3, &r__1, &v[(i__ + 1) * + v_dim1 + 1], ldv, &v[i__ + (i__ + 1) * v_dim1], + ldv, &c_b6, &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_("Upper", "No transpose", "Non-unit", &i__2, &t[ + t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1); + t[i__ + i__ * t_dim1] = tau[i__]; + if (i__ > 1) { + prevlastv = f2cmax(prevlastv,lastv); + } else { + prevlastv = lastv; + } + } + } + } else { + prevlastv = 1; + for (i__ = *k; i__ >= 1; --i__) { + if (tau[i__] == 0.f) { + +/* H(i) = I */ + + i__1 = *k; + for (j = i__; j <= i__1; ++j) { + t[j + i__ * t_dim1] = 0.f; + } + } else { + +/* general case */ + + if (i__ < *k) { + if (lsame_(storev, "C")) { +/* Skip any leading zeros. */ + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + if (v[lastv + i__ * v_dim1] != 0.f) { + myexit_(); + } + } + i__1 = *k; + for (j = i__ + 1; j <= i__1; ++j) { + t[j + i__ * t_dim1] = -tau[i__] * v[*n - *k + i__ + + j * v_dim1]; + } + j = f2cmax(lastv,prevlastv); + +/* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) */ + + i__1 = *n - *k + i__ - j; + i__2 = *k - i__; + r__1 = -tau[i__]; + sgemv_("Transpose", &i__1, &i__2, &r__1, &v[j + (i__ + + 1) * v_dim1], ldv, &v[j + i__ * v_dim1], & + c__1, &c_b6, &t[i__ + 1 + i__ * t_dim1], & + c__1); + } else { +/* Skip any leading zeros. */ + i__1 = i__ - 1; + for (lastv = 1; lastv <= i__1; ++lastv) { + if (v[i__ + lastv * v_dim1] != 0.f) { + myexit_(); + } + } + i__1 = *k; + for (j = i__ + 1; j <= i__1; ++j) { + t[j + i__ * t_dim1] = -tau[i__] * v[j + (*n - *k + + i__) * v_dim1]; + } + j = f2cmax(lastv,prevlastv); + +/* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T */ + + i__1 = *k - i__; + i__2 = *n - *k + i__ - j; + r__1 = -tau[i__]; + sgemv_("No transpose", &i__1, &i__2, &r__1, &v[i__ + + 1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], + ldv, &c_b6, &t[i__ + 1 + i__ * t_dim1], &c__1); + } + +/* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */ + + i__1 = *k - i__; + strmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ + + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * + t_dim1], &c__1) + ; + if (i__ > 1) { + prevlastv = f2cmin(prevlastv,lastv); + } else { + prevlastv = lastv; + } + } + t[i__ + i__ * t_dim1] = tau[i__]; + } + } + } + return 0; + +/* End of SLARFT */ + +} /* slarft_ */ + diff --git a/lapack-netlib/SRC/slarfx.c b/lapack-netlib/SRC/slarfx.c new file mode 100644 index 000000000..d414f0b89 --- /dev/null +++ b/lapack-netlib/SRC/slarfx.c @@ -0,0 +1,1163 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLARFX applies an elementary reflector to a general rectangular matrix, with loop unrolling whe +n the reflector has order ≤ 10. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARFX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARFX( SIDE, M, N, V, TAU, C, LDC, WORK ) */ + +/* CHARACTER SIDE */ +/* INTEGER LDC, M, N */ +/* REAL TAU */ +/* REAL C( LDC, * ), V( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARFX applies a real elementary reflector H to a real m by n */ +/* > matrix C, from either the left or the right. H is represented in the */ +/* > form */ +/* > */ +/* > H = I - tau * v * v**T */ +/* > */ +/* > where tau is a real scalar and v is a real vector. */ +/* > */ +/* > If tau = 0, then H is taken to be the unit matrix */ +/* > */ +/* > This version uses inline code if H has order < 11. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': form H * C */ +/* > = 'R': form C * H */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is REAL array, dimension (M) if SIDE = 'L' */ +/* > or (N) if SIDE = 'R' */ +/* > The vector v in the representation of H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is REAL */ +/* > The value tau in the representation of H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (LDC,N) */ +/* > On entry, the m by n matrix C. */ +/* > On exit, C is overwritten by the matrix H * C if SIDE = 'L', */ +/* > or C * H if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= (1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension */ +/* > (N) if SIDE = 'L' */ +/* > or (M) if SIDE = 'R' */ +/* > WORK is not referenced if H has order < 11. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slarfx_(char *side, integer *m, integer *n, real *v, + real *tau, real *c__, integer *ldc, real *work) +{ + /* System generated locals */ + integer c_dim1, c_offset, i__1; + + /* Local variables */ + integer j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *, + integer *, real *, real *, integer *, real *); + real t1, t2, t3, t4, t5, t6, t7, t8, t9, v1, v2, v3, v4, v5, v6, v7, v8, + v9, t10, v10, sum; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --v; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + if (*tau == 0.f) { + return 0; + } + if (lsame_(side, "L")) { + +/* Form H * C, where H has order m. */ + + switch (*m) { + case 1: goto L10; + case 2: goto L30; + case 3: goto L50; + case 4: goto L70; + case 5: goto L90; + case 6: goto L110; + case 7: goto L130; + case 8: goto L150; + case 9: goto L170; + case 10: goto L190; + } + +/* Code for general M */ + + slarf_(side, m, n, &v[1], &c__1, tau, &c__[c_offset], ldc, &work[1]); + goto L410; +L10: + +/* Special code for 1 x 1 Householder */ + + t1 = 1.f - *tau * v[1] * v[1]; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + c__[j * c_dim1 + 1] = t1 * c__[j * c_dim1 + 1]; +/* L20: */ + } + goto L410; +L30: + +/* Special code for 2 x 2 Householder */ + + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; +/* L40: */ + } + goto L410; +L50: + +/* Special code for 3 x 3 Householder */ + + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; +/* L60: */ + } + goto L410; +L70: + +/* Special code for 4 x 4 Householder */ + + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; + c__[j * c_dim1 + 4] -= sum * t4; +/* L80: */ + } + goto L410; +L90: + +/* Special code for 5 x 5 Householder */ + + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ + j * c_dim1 + 5]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; + c__[j * c_dim1 + 4] -= sum * t4; + c__[j * c_dim1 + 5] -= sum * t5; +/* L100: */ + } + goto L410; +L110: + +/* Special code for 6 x 6 Householder */ + + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + v6 = v[6]; + t6 = *tau * v6; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ + j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; + c__[j * c_dim1 + 4] -= sum * t4; + c__[j * c_dim1 + 5] -= sum * t5; + c__[j * c_dim1 + 6] -= sum * t6; +/* L120: */ + } + goto L410; +L130: + +/* Special code for 7 x 7 Householder */ + + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + v6 = v[6]; + t6 = *tau * v6; + v7 = v[7]; + t7 = *tau * v7; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ + j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j * + c_dim1 + 7]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; + c__[j * c_dim1 + 4] -= sum * t4; + c__[j * c_dim1 + 5] -= sum * t5; + c__[j * c_dim1 + 6] -= sum * t6; + c__[j * c_dim1 + 7] -= sum * t7; +/* L140: */ + } + goto L410; +L150: + +/* Special code for 8 x 8 Householder */ + + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + v6 = v[6]; + t6 = *tau * v6; + v7 = v[7]; + t7 = *tau * v7; + v8 = v[8]; + t8 = *tau * v8; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ + j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j * + c_dim1 + 7] + v8 * c__[j * c_dim1 + 8]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; + c__[j * c_dim1 + 4] -= sum * t4; + c__[j * c_dim1 + 5] -= sum * t5; + c__[j * c_dim1 + 6] -= sum * t6; + c__[j * c_dim1 + 7] -= sum * t7; + c__[j * c_dim1 + 8] -= sum * t8; +/* L160: */ + } + goto L410; +L170: + +/* Special code for 9 x 9 Householder */ + + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + v6 = v[6]; + t6 = *tau * v6; + v7 = v[7]; + t7 = *tau * v7; + v8 = v[8]; + t8 = *tau * v8; + v9 = v[9]; + t9 = *tau * v9; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ + j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j * + c_dim1 + 7] + v8 * c__[j * c_dim1 + 8] + v9 * c__[j * + c_dim1 + 9]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; + c__[j * c_dim1 + 4] -= sum * t4; + c__[j * c_dim1 + 5] -= sum * t5; + c__[j * c_dim1 + 6] -= sum * t6; + c__[j * c_dim1 + 7] -= sum * t7; + c__[j * c_dim1 + 8] -= sum * t8; + c__[j * c_dim1 + 9] -= sum * t9; +/* L180: */ + } + goto L410; +L190: + +/* Special code for 10 x 10 Householder */ + + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + v6 = v[6]; + t6 = *tau * v6; + v7 = v[7]; + t7 = *tau * v7; + v8 = v[8]; + t8 = *tau * v8; + v9 = v[9]; + t9 = *tau * v9; + v10 = v[10]; + t10 = *tau * v10; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j * c_dim1 + 1] + v2 * c__[j * c_dim1 + 2] + v3 * + c__[j * c_dim1 + 3] + v4 * c__[j * c_dim1 + 4] + v5 * c__[ + j * c_dim1 + 5] + v6 * c__[j * c_dim1 + 6] + v7 * c__[j * + c_dim1 + 7] + v8 * c__[j * c_dim1 + 8] + v9 * c__[j * + c_dim1 + 9] + v10 * c__[j * c_dim1 + 10]; + c__[j * c_dim1 + 1] -= sum * t1; + c__[j * c_dim1 + 2] -= sum * t2; + c__[j * c_dim1 + 3] -= sum * t3; + c__[j * c_dim1 + 4] -= sum * t4; + c__[j * c_dim1 + 5] -= sum * t5; + c__[j * c_dim1 + 6] -= sum * t6; + c__[j * c_dim1 + 7] -= sum * t7; + c__[j * c_dim1 + 8] -= sum * t8; + c__[j * c_dim1 + 9] -= sum * t9; + c__[j * c_dim1 + 10] -= sum * t10; +/* L200: */ + } + goto L410; + } else { + +/* Form C * H, where H has order n. */ + + switch (*n) { + case 1: goto L210; + case 2: goto L230; + case 3: goto L250; + case 4: goto L270; + case 5: goto L290; + case 6: goto L310; + case 7: goto L330; + case 8: goto L350; + case 9: goto L370; + case 10: goto L390; + } + +/* Code for general N */ + + slarf_(side, m, n, &v[1], &c__1, tau, &c__[c_offset], ldc, &work[1]); + goto L410; +L210: + +/* Special code for 1 x 1 Householder */ + + t1 = 1.f - *tau * v[1] * v[1]; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + c__[j + c_dim1] = t1 * c__[j + c_dim1]; +/* L220: */ + } + goto L410; +L230: + +/* Special code for 2 x 2 Householder */ + + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; +/* L240: */ + } + goto L410; +L250: + +/* Special code for 3 x 3 Householder */ + + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; +/* L260: */ + } + goto L410; +L270: + +/* Special code for 4 x 4 Householder */ + + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; + c__[j + (c_dim1 << 2)] -= sum * t4; +/* L280: */ + } + goto L410; +L290: + +/* Special code for 5 x 5 Householder */ + + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * + c__[j + c_dim1 * 5]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; + c__[j + (c_dim1 << 2)] -= sum * t4; + c__[j + c_dim1 * 5] -= sum * t5; +/* L300: */ + } + goto L410; +L310: + +/* Special code for 6 x 6 Householder */ + + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + v6 = v[6]; + t6 = *tau * v6; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * + c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; + c__[j + (c_dim1 << 2)] -= sum * t4; + c__[j + c_dim1 * 5] -= sum * t5; + c__[j + c_dim1 * 6] -= sum * t6; +/* L320: */ + } + goto L410; +L330: + +/* Special code for 7 x 7 Householder */ + + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + v6 = v[6]; + t6 = *tau * v6; + v7 = v[7]; + t7 = *tau * v7; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * + c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[ + j + c_dim1 * 7]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; + c__[j + (c_dim1 << 2)] -= sum * t4; + c__[j + c_dim1 * 5] -= sum * t5; + c__[j + c_dim1 * 6] -= sum * t6; + c__[j + c_dim1 * 7] -= sum * t7; +/* L340: */ + } + goto L410; +L350: + +/* Special code for 8 x 8 Householder */ + + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + v6 = v[6]; + t6 = *tau * v6; + v7 = v[7]; + t7 = *tau * v7; + v8 = v[8]; + t8 = *tau * v8; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * + c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[ + j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; + c__[j + (c_dim1 << 2)] -= sum * t4; + c__[j + c_dim1 * 5] -= sum * t5; + c__[j + c_dim1 * 6] -= sum * t6; + c__[j + c_dim1 * 7] -= sum * t7; + c__[j + (c_dim1 << 3)] -= sum * t8; +/* L360: */ + } + goto L410; +L370: + +/* Special code for 9 x 9 Householder */ + + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + v6 = v[6]; + t6 = *tau * v6; + v7 = v[7]; + t7 = *tau * v7; + v8 = v[8]; + t8 = *tau * v8; + v9 = v[9]; + t9 = *tau * v9; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * + c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[ + j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)] + v9 * c__[ + j + c_dim1 * 9]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; + c__[j + (c_dim1 << 2)] -= sum * t4; + c__[j + c_dim1 * 5] -= sum * t5; + c__[j + c_dim1 * 6] -= sum * t6; + c__[j + c_dim1 * 7] -= sum * t7; + c__[j + (c_dim1 << 3)] -= sum * t8; + c__[j + c_dim1 * 9] -= sum * t9; +/* L380: */ + } + goto L410; +L390: + +/* Special code for 10 x 10 Householder */ + + v1 = v[1]; + t1 = *tau * v1; + v2 = v[2]; + t2 = *tau * v2; + v3 = v[3]; + t3 = *tau * v3; + v4 = v[4]; + t4 = *tau * v4; + v5 = v[5]; + t5 = *tau * v5; + v6 = v[6]; + t6 = *tau * v6; + v7 = v[7]; + t7 = *tau * v7; + v8 = v[8]; + t8 = *tau * v8; + v9 = v[9]; + t9 = *tau * v9; + v10 = v[10]; + t10 = *tau * v10; + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + sum = v1 * c__[j + c_dim1] + v2 * c__[j + (c_dim1 << 1)] + v3 * + c__[j + c_dim1 * 3] + v4 * c__[j + (c_dim1 << 2)] + v5 * + c__[j + c_dim1 * 5] + v6 * c__[j + c_dim1 * 6] + v7 * c__[ + j + c_dim1 * 7] + v8 * c__[j + (c_dim1 << 3)] + v9 * c__[ + j + c_dim1 * 9] + v10 * c__[j + c_dim1 * 10]; + c__[j + c_dim1] -= sum * t1; + c__[j + (c_dim1 << 1)] -= sum * t2; + c__[j + c_dim1 * 3] -= sum * t3; + c__[j + (c_dim1 << 2)] -= sum * t4; + c__[j + c_dim1 * 5] -= sum * t5; + c__[j + c_dim1 * 6] -= sum * t6; + c__[j + c_dim1 * 7] -= sum * t7; + c__[j + (c_dim1 << 3)] -= sum * t8; + c__[j + c_dim1 * 9] -= sum * t9; + c__[j + c_dim1 * 10] -= sum * t10; +/* L400: */ + } + goto L410; + } +L410: + return 0; + +/* End of SLARFX */ + +} /* slarfx_ */ + diff --git a/lapack-netlib/SRC/slarfy.c b/lapack-netlib/SRC/slarfy.c new file mode 100644 index 000000000..170f89218 --- /dev/null +++ b/lapack-netlib/SRC/slarfy.c @@ -0,0 +1,555 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLARFY */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK ) */ + +/* CHARACTER UPLO */ +/* INTEGER INCV, LDC, N */ +/* REAL TAU */ +/* REAL C( LDC, * ), V( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARFY applies an elementary reflector, or Householder matrix, H, */ +/* > to an n x n symmetric matrix C, from both the left and the right. */ +/* > */ +/* > H is represented in the form */ +/* > */ +/* > H = I - tau * v * v' */ +/* > */ +/* > where tau is a scalar and v is a vector. */ +/* > */ +/* > If tau is zero, then H is taken to be the unit matrix. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix C is stored. */ +/* > = 'U': Upper triangle */ +/* > = 'L': Lower triangle */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of rows and columns of the matrix C. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is REAL array, dimension */ +/* > (1 + (N-1)*abs(INCV)) */ +/* > The vector v as described above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCV */ +/* > \verbatim */ +/* > INCV is INTEGER */ +/* > The increment between successive elements of v. INCV must */ +/* > not be zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is REAL */ +/* > The value tau as described above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (LDC, N) */ +/* > On entry, the matrix C. */ +/* > On exit, C is overwritten by H * C * H'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax( 1, N ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (N) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slarfy_(char *uplo, integer *n, real *v, integer *incv, + real *tau, real *c__, integer *ldc, real *work) +{ + /* System generated locals */ + integer c_dim1, c_offset; + real r__1; + + /* Local variables */ + extern real sdot_(integer *, real *, integer *, real *, integer *); + extern /* Subroutine */ int ssyr2_(char *, integer *, real *, real *, + integer *, real *, integer *, real *, integer *); + real alpha; + extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, + real *, integer *), ssymv_(char *, integer *, real *, real *, + integer *, real *, integer *, real *, real *, integer *); + + +/* -- LAPACK test routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --v; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + if (*tau == 0.f) { + return 0; + } + +/* Form w:= C * v */ + + ssymv_(uplo, n, &c_b2, &c__[c_offset], ldc, &v[1], incv, &c_b3, &work[1], + &c__1); + + alpha = *tau * -.5f * sdot_(n, &work[1], &c__1, &v[1], incv); + saxpy_(n, &alpha, &v[1], incv, &work[1], &c__1); + +/* C := C - v * w' - w * v' */ + + r__1 = -(*tau); + ssyr2_(uplo, n, &r__1, &v[1], incv, &work[1], &c__1, &c__[c_offset], ldc); + + return 0; + +/* End of SLARFY */ + +} /* slarfy_ */ + diff --git a/lapack-netlib/SRC/slargv.c b/lapack-netlib/SRC/slargv.c new file mode 100644 index 000000000..dd91fcb4b --- /dev/null +++ b/lapack-netlib/SRC/slargv.c @@ -0,0 +1,557 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLARGV generates a vector of plane rotations with real cosines and real sines. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARGV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARGV( N, X, INCX, Y, INCY, C, INCC ) */ + +/* INTEGER INCC, INCX, INCY, N */ +/* REAL C( * ), X( * ), Y( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARGV generates a vector of real plane rotations, determined by */ +/* > elements of the real vectors x and y. For i = 1,2,...,n */ +/* > */ +/* > ( c(i) s(i) ) ( x(i) ) = ( a(i) ) */ +/* > ( -s(i) c(i) ) ( y(i) ) = ( 0 ) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of plane rotations to be generated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is REAL array, */ +/* > dimension (1+(N-1)*INCX) */ +/* > On entry, the vector x. */ +/* > On exit, x(i) is overwritten by a(i), for i = 1,...,n. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The increment between elements of X. INCX > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is REAL array, */ +/* > dimension (1+(N-1)*INCY) */ +/* > On entry, the vector y. */ +/* > On exit, the sines of the plane rotations. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCY */ +/* > \verbatim */ +/* > INCY is INTEGER */ +/* > The increment between elements of Y. INCY > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (1+(N-1)*INCC) */ +/* > The cosines of the plane rotations. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCC */ +/* > \verbatim */ +/* > INCC is INTEGER */ +/* > The increment between elements of C. INCC > 0. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slargv_(integer *n, real *x, integer *incx, real *y, + integer *incy, real *c__, integer *incc) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + real f, g; + integer i__; + real t; + integer ic, ix, iy; + real tt; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --c__; + --y; + --x; + + /* Function Body */ + ix = 1; + iy = 1; + ic = 1; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + f = x[ix]; + g = y[iy]; + if (g == 0.f) { + c__[ic] = 1.f; + } else if (f == 0.f) { + c__[ic] = 0.f; + y[iy] = 1.f; + x[ix] = g; + } else if (abs(f) > abs(g)) { + t = g / f; + tt = sqrt(t * t + 1.f); + c__[ic] = 1.f / tt; + y[iy] = t * c__[ic]; + x[ix] = f * tt; + } else { + t = f / g; + tt = sqrt(t * t + 1.f); + y[iy] = 1.f / tt; + c__[ic] = t * y[iy]; + x[ix] = g * tt; + } + ic += *incc; + iy += *incy; + ix += *incx; +/* L10: */ + } + return 0; + +/* End of SLARGV */ + +} /* slargv_ */ + diff --git a/lapack-netlib/SRC/slarnv.c b/lapack-netlib/SRC/slarnv.c new file mode 100644 index 000000000..6dc8845e6 --- /dev/null +++ b/lapack-netlib/SRC/slarnv.c @@ -0,0 +1,564 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLARNV returns a vector of random numbers from a uniform or normal distribution. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARNV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARNV( IDIST, ISEED, N, X ) */ + +/* INTEGER IDIST, N */ +/* INTEGER ISEED( 4 ) */ +/* REAL X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARNV returns a vector of n random real numbers from a uniform or */ +/* > normal distribution. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] IDIST */ +/* > \verbatim */ +/* > IDIST is INTEGER */ +/* > Specifies the distribution of the random numbers: */ +/* > = 1: uniform (0,1) */ +/* > = 2: uniform (-1,1) */ +/* > = 3: normal (0,1) */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of random numbers to be generated. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (N) */ +/* > The generated random numbers. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine calls the auxiliary routine SLARUV to generate random */ +/* > real numbers from a uniform (0,1) distribution, in batches of up to */ +/* > 128 using vectorisable code. The Box-Muller method is used to */ +/* > transform numbers from a uniform to a normal distribution. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slarnv_(integer *idist, integer *iseed, integer *n, real + *x) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + + /* Local variables */ + integer i__; + real u[128]; + integer il, iv, il2; + extern /* Subroutine */ int slaruv_(integer *, integer *, real *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --x; + --iseed; + + /* Function Body */ + i__1 = *n; + for (iv = 1; iv <= i__1; iv += 64) { +/* Computing MIN */ + i__2 = 64, i__3 = *n - iv + 1; + il = f2cmin(i__2,i__3); + if (*idist == 3) { + il2 = il << 1; + } else { + il2 = il; + } + +/* Call SLARUV to generate IL2 numbers from a uniform (0,1) */ +/* distribution (IL2 <= LV) */ + + slaruv_(&iseed[1], &il2, u); + + if (*idist == 1) { + +/* Copy generated numbers */ + + i__2 = il; + for (i__ = 1; i__ <= i__2; ++i__) { + x[iv + i__ - 1] = u[i__ - 1]; +/* L10: */ + } + } else if (*idist == 2) { + +/* Convert generated numbers to uniform (-1,1) distribution */ + + i__2 = il; + for (i__ = 1; i__ <= i__2; ++i__) { + x[iv + i__ - 1] = u[i__ - 1] * 2.f - 1.f; +/* L20: */ + } + } else if (*idist == 3) { + +/* Convert generated numbers to normal (0,1) distribution */ + + i__2 = il; + for (i__ = 1; i__ <= i__2; ++i__) { + x[iv + i__ - 1] = sqrt(log(u[(i__ << 1) - 2]) * -2.f) * cos(u[ + (i__ << 1) - 1] * 6.2831853071795864769252867663f); +/* L30: */ + } + } +/* L40: */ + } + return 0; + +/* End of SLARNV */ + +} /* slarnv_ */ + diff --git a/lapack-netlib/SRC/slarra.c b/lapack-netlib/SRC/slarra.c new file mode 100644 index 000000000..6f744514a --- /dev/null +++ b/lapack-netlib/SRC/slarra.c @@ -0,0 +1,597 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLARRA computes the splitting points with the specified threshold. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARRA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARRA( N, D, E, E2, SPLTOL, TNRM, */ +/* NSPLIT, ISPLIT, INFO ) */ + +/* INTEGER INFO, N, NSPLIT */ +/* REAL SPLTOL, TNRM */ +/* INTEGER ISPLIT( * ) */ +/* REAL D( * ), E( * ), E2( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Compute the splitting points with threshold SPLTOL. */ +/* > SLARRA sets any "small" off-diagonal elements to zero. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry, the N diagonal elements of the tridiagonal */ +/* > matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (N) */ +/* > On entry, the first (N-1) entries contain the subdiagonal */ +/* > elements of the tridiagonal matrix T; E(N) need not be set. */ +/* > On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT, */ +/* > are set to zero, the other entries of E are untouched. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E2 */ +/* > \verbatim */ +/* > E2 is REAL array, dimension (N) */ +/* > On entry, the first (N-1) entries contain the SQUARES of the */ +/* > subdiagonal elements of the tridiagonal matrix T; */ +/* > E2(N) need not be set. */ +/* > On exit, the entries E2( ISPLIT( I ) ), */ +/* > 1 <= I <= NSPLIT, have been set to zero */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SPLTOL */ +/* > \verbatim */ +/* > SPLTOL is REAL */ +/* > The threshold for splitting. Two criteria can be used: */ +/* > SPLTOL<0 : criterion based on absolute off-diagonal value */ +/* > SPLTOL>0 : criterion that preserves relative accuracy */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TNRM */ +/* > \verbatim */ +/* > TNRM is REAL */ +/* > The norm of the matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] NSPLIT */ +/* > \verbatim */ +/* > NSPLIT is INTEGER */ +/* > The number of blocks T splits into. 1 <= NSPLIT <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ISPLIT */ +/* > \verbatim */ +/* > ISPLIT is INTEGER array, dimension (N) */ +/* > The splitting points, at which T breaks up into blocks. */ +/* > The first block consists of rows/columns 1 to ISPLIT(1), */ +/* > the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */ +/* > etc., and the NSPLIT-th consists of rows/columns */ +/* > ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Beresford Parlett, University of California, Berkeley, USA \n */ +/* > Jim Demmel, University of California, Berkeley, USA \n */ +/* > Inderjit Dhillon, University of Texas, Austin, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ +/* > Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ +/* Subroutine */ int slarra_(integer *n, real *d__, real *e, real *e2, real * + spltol, real *tnrm, integer *nsplit, integer *isplit, integer *info) +{ + /* System generated locals */ + integer i__1; + real r__1, r__2; + + /* Local variables */ + real eabs; + integer i__; + real tmp1; + + +/* -- 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 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --isplit; + --e2; + --e; + --d__; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n <= 0) { + return 0; + } + +/* Compute splitting points */ + *nsplit = 1; + if (*spltol < 0.f) { +/* Criterion based on absolute off-diagonal value */ + tmp1 = abs(*spltol) * *tnrm; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + eabs = (r__1 = e[i__], abs(r__1)); + if (eabs <= tmp1) { + e[i__] = 0.f; + e2[i__] = 0.f; + isplit[*nsplit] = i__; + ++(*nsplit); + } +/* L9: */ + } + } else { +/* Criterion that guarantees relative accuracy */ + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + eabs = (r__1 = e[i__], abs(r__1)); + if (eabs <= *spltol * sqrt((r__1 = d__[i__], abs(r__1))) * sqrt(( + r__2 = d__[i__ + 1], abs(r__2)))) { + e[i__] = 0.f; + e2[i__] = 0.f; + isplit[*nsplit] = i__; + ++(*nsplit); + } +/* L10: */ + } + } + isplit[*nsplit] = *n; + return 0; + +/* End of SLARRA */ + +} /* slarra_ */ + diff --git a/lapack-netlib/SRC/slarrb.c b/lapack-netlib/SRC/slarrb.c new file mode 100644 index 000000000..75e37312d --- /dev/null +++ b/lapack-netlib/SRC/slarrb.c @@ -0,0 +1,816 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLARRB provides limited bisection to locate eigenvalues for more accuracy. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARRB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARRB( N, D, LLD, IFIRST, ILAST, RTOL1, */ +/* RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK, */ +/* PIVMIN, SPDIAM, TWIST, INFO ) */ + +/* INTEGER IFIRST, ILAST, INFO, N, OFFSET, TWIST */ +/* REAL PIVMIN, RTOL1, RTOL2, SPDIAM */ +/* INTEGER IWORK( * ) */ +/* REAL D( * ), LLD( * ), W( * ), */ +/* $ WERR( * ), WGAP( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Given the relatively robust representation(RRR) L D L^T, SLARRB */ +/* > does "limited" bisection to refine the eigenvalues of L D L^T, */ +/* > W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial */ +/* > guesses for these eigenvalues are input in W, the corresponding estimate */ +/* > of the error in these guesses and their gaps are input in WERR */ +/* > and WGAP, respectively. During bisection, intervals */ +/* > [left, right] are maintained by storing their mid-points and */ +/* > semi-widths in the arrays W and WERR respectively. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The N diagonal elements of the diagonal matrix D. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LLD */ +/* > \verbatim */ +/* > LLD is REAL array, dimension (N-1) */ +/* > The (N-1) elements L(i)*L(i)*D(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IFIRST */ +/* > \verbatim */ +/* > IFIRST is INTEGER */ +/* > The index of the first eigenvalue to be computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILAST */ +/* > \verbatim */ +/* > ILAST is INTEGER */ +/* > The index of the last eigenvalue to be computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RTOL1 */ +/* > \verbatim */ +/* > RTOL1 is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RTOL2 */ +/* > \verbatim */ +/* > RTOL2 is REAL */ +/* > Tolerance for the convergence of the bisection intervals. */ +/* > An interval [LEFT,RIGHT] has converged if */ +/* > RIGHT-LEFT < MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */ +/* > where GAP is the (estimated) distance to the nearest */ +/* > eigenvalue. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] OFFSET */ +/* > \verbatim */ +/* > OFFSET is INTEGER */ +/* > Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET */ +/* > through ILAST-OFFSET elements of these arrays are to be used. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] W */ +/* > \verbatim */ +/* > W is REAL array, dimension (N) */ +/* > On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are */ +/* > estimates of the eigenvalues of L D L^T indexed IFIRST through */ +/* > ILAST. */ +/* > On output, these estimates are refined. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] WGAP */ +/* > \verbatim */ +/* > WGAP is REAL array, dimension (N-1) */ +/* > On input, the (estimated) gaps between consecutive */ +/* > eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between */ +/* > eigenvalues I and I+1. Note that if IFIRST = ILAST */ +/* > then WGAP(IFIRST-OFFSET) must be set to ZERO. */ +/* > On output, these gaps are refined. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] WERR */ +/* > \verbatim */ +/* > WERR is REAL array, dimension (N) */ +/* > On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are */ +/* > the errors in the estimates of the corresponding elements in W. */ +/* > On output, these errors are refined. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (2*N) */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (2*N) */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PIVMIN */ +/* > \verbatim */ +/* > PIVMIN is REAL */ +/* > The minimum pivot in the Sturm sequence. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SPDIAM */ +/* > \verbatim */ +/* > SPDIAM is REAL */ +/* > The spectral diameter of the matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TWIST */ +/* > \verbatim */ +/* > TWIST is INTEGER */ +/* > The twist index for the twisted factorization that is used */ +/* > for the negcount. */ +/* > TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T */ +/* > TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T */ +/* > TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > Error flag. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Beresford Parlett, University of California, Berkeley, USA \n */ +/* > Jim Demmel, University of California, Berkeley, USA \n */ +/* > Inderjit Dhillon, University of Texas, Austin, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ +/* > Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ +/* Subroutine */ int slarrb_(integer *n, real *d__, real *lld, integer * + ifirst, integer *ilast, real *rtol1, real *rtol2, integer *offset, + real *w, real *wgap, real *werr, real *work, integer *iwork, real * + pivmin, real *spdiam, integer *twist, integer *info) +{ + /* System generated locals */ + integer i__1; + real r__1, r__2; + + /* Local variables */ + real back, lgap, rgap, left; + integer iter, nint, prev, next, i__, k, r__; + real cvrgd, right, width; + integer i1, ii, ip; + extern integer slaneg_(integer *, real *, real *, real *, real *, integer + *); + integer negcnt; + real mnwdth; + integer olnint, maxitr; + real gap, mid, tmp; + + +/* -- 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 */ + + +/* ===================================================================== */ + + + + /* Parameter adjustments */ + --iwork; + --work; + --werr; + --wgap; + --w; + --lld; + --d__; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n <= 0) { + return 0; + } + + maxitr = (integer) ((log(*spdiam + *pivmin) - log(*pivmin)) / log(2.f)) + + 2; + mnwdth = *pivmin * 2.f; + + r__ = *twist; + if (r__ < 1 || r__ > *n) { + r__ = *n; + } + +/* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ]. */ +/* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while */ +/* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 ) */ +/* for an unconverged interval is set to the index of the next unconverged */ +/* interval, and is -1 or 0 for a converged interval. Thus a linked */ +/* list of unconverged intervals is set up. */ + + i1 = *ifirst; +/* The number of unconverged intervals */ + nint = 0; +/* The last unconverged interval found */ + prev = 0; + rgap = wgap[i1 - *offset]; + i__1 = *ilast; + for (i__ = i1; i__ <= i__1; ++i__) { + k = i__ << 1; + ii = i__ - *offset; + left = w[ii] - werr[ii]; + right = w[ii] + werr[ii]; + lgap = rgap; + rgap = wgap[ii]; + gap = f2cmin(lgap,rgap); +/* Make sure that [LEFT,RIGHT] contains the desired eigenvalue */ +/* Compute negcount from dstqds facto L+D+L+^T = L D L^T - LEFT */ + +/* Do while( NEGCNT(LEFT).GT.I-1 ) */ + + back = werr[ii]; +L20: + negcnt = slaneg_(n, &d__[1], &lld[1], &left, pivmin, &r__); + if (negcnt > i__ - 1) { + left -= back; + back *= 2.f; + goto L20; + } + +/* Do while( NEGCNT(RIGHT).LT.I ) */ +/* Compute negcount from dstqds facto L+D+L+^T = L D L^T - RIGHT */ + + back = werr[ii]; +L50: + negcnt = slaneg_(n, &d__[1], &lld[1], &right, pivmin, &r__); + if (negcnt < i__) { + right += back; + back *= 2.f; + goto L50; + } + width = (r__1 = left - right, abs(r__1)) * .5f; +/* Computing MAX */ + r__1 = abs(left), r__2 = abs(right); + tmp = f2cmax(r__1,r__2); +/* Computing MAX */ + r__1 = *rtol1 * gap, r__2 = *rtol2 * tmp; + cvrgd = f2cmax(r__1,r__2); + if (width <= cvrgd || width <= mnwdth) { +/* This interval has already converged and does not need refinement. */ +/* (Note that the gaps might change through refining the */ +/* eigenvalues, however, they can only get bigger.) */ +/* Remove it from the list. */ + iwork[k - 1] = -1; +/* Make sure that I1 always points to the first unconverged interval */ + if (i__ == i1 && i__ < *ilast) { + i1 = i__ + 1; + } + if (prev >= i1 && i__ <= *ilast) { + iwork[(prev << 1) - 1] = i__ + 1; + } + } else { +/* unconverged interval found */ + prev = i__; + ++nint; + iwork[k - 1] = i__ + 1; + iwork[k] = negcnt; + } + work[k - 1] = left; + work[k] = right; +/* L75: */ + } + +/* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals */ +/* and while (ITER.LT.MAXITR) */ + + iter = 0; +L80: + prev = i1 - 1; + i__ = i1; + olnint = nint; + i__1 = olnint; + for (ip = 1; ip <= i__1; ++ip) { + k = i__ << 1; + ii = i__ - *offset; + rgap = wgap[ii]; + lgap = rgap; + if (ii > 1) { + lgap = wgap[ii - 1]; + } + gap = f2cmin(lgap,rgap); + next = iwork[k - 1]; + left = work[k - 1]; + right = work[k]; + mid = (left + right) * .5f; +/* semiwidth of interval */ + width = right - mid; +/* Computing MAX */ + r__1 = abs(left), r__2 = abs(right); + tmp = f2cmax(r__1,r__2); +/* Computing MAX */ + r__1 = *rtol1 * gap, r__2 = *rtol2 * tmp; + cvrgd = f2cmax(r__1,r__2); + if (width <= cvrgd || width <= mnwdth || iter == maxitr) { +/* reduce number of unconverged intervals */ + --nint; +/* Mark interval as converged. */ + iwork[k - 1] = 0; + if (i1 == i__) { + i1 = next; + } else { +/* Prev holds the last unconverged interval previously examined */ + if (prev >= i1) { + iwork[(prev << 1) - 1] = next; + } + } + i__ = next; + goto L100; + } + prev = i__; + +/* Perform one bisection step */ + + negcnt = slaneg_(n, &d__[1], &lld[1], &mid, pivmin, &r__); + if (negcnt <= i__ - 1) { + work[k - 1] = mid; + } else { + work[k] = mid; + } + i__ = next; +L100: + ; + } + ++iter; +/* do another loop if there are still unconverged intervals */ +/* However, in the last iteration, all intervals are accepted */ +/* since this is the best we can do. */ + if (nint > 0 && iter <= maxitr) { + goto L80; + } + + +/* At this point, all the intervals have converged */ + i__1 = *ilast; + for (i__ = *ifirst; i__ <= i__1; ++i__) { + k = i__ << 1; + ii = i__ - *offset; +/* All intervals marked by '0' have been refined. */ + if (iwork[k - 1] == 0) { + w[ii] = (work[k - 1] + work[k]) * .5f; + werr[ii] = work[k] - w[ii]; + } +/* L110: */ + } + + i__1 = *ilast; + for (i__ = *ifirst + 1; i__ <= i__1; ++i__) { + k = i__ << 1; + ii = i__ - *offset; +/* Computing MAX */ + r__1 = 0.f, r__2 = w[ii] - werr[ii] - w[ii - 1] - werr[ii - 1]; + wgap[ii - 1] = f2cmax(r__1,r__2); +/* L111: */ + } + return 0; + +/* End of SLARRB */ + +} /* slarrb_ */ + diff --git a/lapack-netlib/SRC/slarrc.c b/lapack-netlib/SRC/slarrc.c new file mode 100644 index 000000000..30fce9ce3 --- /dev/null +++ b/lapack-netlib/SRC/slarrc.c @@ -0,0 +1,636 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLARRC computes the number of eigenvalues of the symmetric tridiagonal matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARRC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARRC( JOBT, N, VL, VU, D, E, PIVMIN, */ +/* EIGCNT, LCNT, RCNT, INFO ) */ + +/* CHARACTER JOBT */ +/* INTEGER EIGCNT, INFO, LCNT, N, RCNT */ +/* REAL PIVMIN, VL, VU */ +/* REAL D( * ), E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Find the number of eigenvalues of the symmetric tridiagonal matrix T */ +/* > that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T */ +/* > if JOBT = 'L'. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBT */ +/* > \verbatim */ +/* > JOBT is CHARACTER*1 */ +/* > = 'T': Compute Sturm count for matrix T. */ +/* > = 'L': Compute Sturm count for matrix L D L^T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VL */ +/* > \verbatim */ +/* > VL is REAL */ +/* > The lower bound for the eigenvalues. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VU */ +/* > \verbatim */ +/* > VU is REAL */ +/* > The upper bound for the eigenvalues. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > JOBT = 'T': The N diagonal elements of the tridiagonal matrix T. */ +/* > JOBT = 'L': The N diagonal elements of the diagonal matrix D. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (N) */ +/* > JOBT = 'T': The N-1 offdiagonal elements of the matrix T. */ +/* > JOBT = 'L': The N-1 offdiagonal elements of the matrix L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PIVMIN */ +/* > \verbatim */ +/* > PIVMIN is REAL */ +/* > The minimum pivot in the Sturm sequence for T. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] EIGCNT */ +/* > \verbatim */ +/* > EIGCNT is INTEGER */ +/* > The number of eigenvalues of the symmetric tridiagonal matrix T */ +/* > that are in the interval (VL,VU] */ +/* > \endverbatim */ +/* > */ +/* > \param[out] LCNT */ +/* > \verbatim */ +/* > LCNT is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCNT */ +/* > \verbatim */ +/* > RCNT is INTEGER */ +/* > The left and right negcounts of the interval. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Beresford Parlett, University of California, Berkeley, USA \n */ +/* > Jim Demmel, University of California, Berkeley, USA \n */ +/* > Inderjit Dhillon, University of Texas, Austin, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ +/* > Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ +/* Subroutine */ int slarrc_(char *jobt, integer *n, real *vl, real *vu, real + *d__, real *e, real *pivmin, integer *eigcnt, integer *lcnt, integer * + rcnt, integer *info) +{ + /* System generated locals */ + integer i__1; + real r__1; + + /* Local variables */ + logical matt; + integer i__; + extern logical lsame_(char *, char *); + real sl, su, lpivot, rpivot, tmp, tmp2; + + +/* -- LAPACK auxiliary routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --e; + --d__; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n <= 0) { + return 0; + } + + *lcnt = 0; + *rcnt = 0; + *eigcnt = 0; + matt = lsame_(jobt, "T"); + if (matt) { +/* Sturm sequence count on T */ + lpivot = d__[1] - *vl; + rpivot = d__[1] - *vu; + if (lpivot <= 0.f) { + ++(*lcnt); + } + if (rpivot <= 0.f) { + ++(*rcnt); + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing 2nd power */ + r__1 = e[i__]; + tmp = r__1 * r__1; + lpivot = d__[i__ + 1] - *vl - tmp / lpivot; + rpivot = d__[i__ + 1] - *vu - tmp / rpivot; + if (lpivot <= 0.f) { + ++(*lcnt); + } + if (rpivot <= 0.f) { + ++(*rcnt); + } +/* L10: */ + } + } else { +/* Sturm sequence count on L D L^T */ + sl = -(*vl); + su = -(*vu); + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + lpivot = d__[i__] + sl; + rpivot = d__[i__] + su; + if (lpivot <= 0.f) { + ++(*lcnt); + } + if (rpivot <= 0.f) { + ++(*rcnt); + } + tmp = e[i__] * d__[i__] * e[i__]; + + tmp2 = tmp / lpivot; + if (tmp2 == 0.f) { + sl = tmp - *vl; + } else { + sl = sl * tmp2 - *vl; + } + + tmp2 = tmp / rpivot; + if (tmp2 == 0.f) { + su = tmp - *vu; + } else { + su = su * tmp2 - *vu; + } +/* L20: */ + } + lpivot = d__[*n] + sl; + rpivot = d__[*n] + su; + if (lpivot <= 0.f) { + ++(*lcnt); + } + if (rpivot <= 0.f) { + ++(*rcnt); + } + } + *eigcnt = *rcnt - *lcnt; + return 0; + +/* end of SLARRC */ + +} /* slarrc_ */ + diff --git a/lapack-netlib/SRC/slarrd.c b/lapack-netlib/SRC/slarrd.c new file mode 100644 index 000000000..9611bb6ac --- /dev/null +++ b/lapack-netlib/SRC/slarrd.c @@ -0,0 +1,1294 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLARRD computes the eigenvalues of a symmetric tridiagonal matrix to suitable accuracy. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARRD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARRD( RANGE, ORDER, N, VL, VU, IL, IU, GERS, */ +/* RELTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT, */ +/* M, W, WERR, WL, WU, IBLOCK, INDEXW, */ +/* WORK, IWORK, INFO ) */ + +/* CHARACTER ORDER, RANGE */ +/* INTEGER IL, INFO, IU, M, N, NSPLIT */ +/* REAL PIVMIN, RELTOL, VL, VU, WL, WU */ +/* INTEGER IBLOCK( * ), INDEXW( * ), */ +/* $ ISPLIT( * ), IWORK( * ) */ +/* REAL D( * ), E( * ), E2( * ), */ +/* $ GERS( * ), W( * ), WERR( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARRD computes the eigenvalues of a symmetric tridiagonal */ +/* > matrix T to suitable accuracy. This is an auxiliary code to be */ +/* > called from SSTEMR. */ +/* > The user may ask for all eigenvalues, all eigenvalues */ +/* > in the half-open interval (VL, VU], or the IL-th through IU-th */ +/* > eigenvalues. */ +/* > */ +/* > To avoid overflow, the matrix must be scaled so that its */ +/* > largest element is no greater than overflow**(1/2) * underflow**(1/4) in absolute value, and for greatest + */ +/* > accuracy, it should not be much smaller than that. */ +/* > */ +/* > See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */ +/* > Matrix", Report CS41, Computer Science Dept., Stanford */ +/* > University, July 21, 1966. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] RANGE */ +/* > \verbatim */ +/* > RANGE is CHARACTER*1 */ +/* > = 'A': ("All") all eigenvalues will be found. */ +/* > = 'V': ("Value") all eigenvalues in the half-open interval */ +/* > (VL, VU] will be found. */ +/* > = 'I': ("Index") the IL-th through IU-th eigenvalues (of the */ +/* > entire matrix) will be found. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ORDER */ +/* > \verbatim */ +/* > ORDER is CHARACTER*1 */ +/* > = 'B': ("By Block") the eigenvalues will be grouped by */ +/* > split-off block (see IBLOCK, ISPLIT) and */ +/* > ordered from smallest to largest within */ +/* > the block. */ +/* > = 'E': ("Entire matrix") */ +/* > the eigenvalues for the entire matrix */ +/* > will be ordered from smallest to */ +/* > largest. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the tridiagonal matrix T. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VL */ +/* > \verbatim */ +/* > VL is REAL */ +/* > If RANGE='V', the lower bound of the interval to */ +/* > be searched for eigenvalues. Eigenvalues less than or equal */ +/* > to VL, or greater than VU, will not be returned. VL < VU. */ +/* > Not referenced if RANGE = 'A' or 'I'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VU */ +/* > \verbatim */ +/* > VU is REAL */ +/* > If RANGE='V', the upper bound of the interval to */ +/* > be searched for eigenvalues. Eigenvalues less than or equal */ +/* > to VL, or greater than VU, will not be returned. VL < VU. */ +/* > Not referenced if RANGE = 'A' or 'I'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IL */ +/* > \verbatim */ +/* > IL is INTEGER */ +/* > If RANGE='I', the index of the */ +/* > smallest eigenvalue to be returned. */ +/* > 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ +/* > Not referenced if RANGE = 'A' or 'V'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IU */ +/* > \verbatim */ +/* > IU is INTEGER */ +/* > If RANGE='I', the index of the */ +/* > largest eigenvalue to be returned. */ +/* > 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ +/* > Not referenced if RANGE = 'A' or 'V'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GERS */ +/* > \verbatim */ +/* > GERS is REAL array, dimension (2*N) */ +/* > The N Gerschgorin intervals (the i-th Gerschgorin interval */ +/* > is (GERS(2*i-1), GERS(2*i)). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RELTOL */ +/* > \verbatim */ +/* > RELTOL is REAL */ +/* > The minimum relative width of an interval. When an interval */ +/* > is narrower than RELTOL times the larger (in */ +/* > magnitude) endpoint, then it is considered to be */ +/* > sufficiently small, i.e., converged. Note: this should */ +/* > always be at least radix*machine epsilon. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The n diagonal elements of the tridiagonal matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (N-1) */ +/* > The (n-1) off-diagonal elements of the tridiagonal matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E2 */ +/* > \verbatim */ +/* > E2 is REAL array, dimension (N-1) */ +/* > The (n-1) squared off-diagonal elements of the tridiagonal matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PIVMIN */ +/* > \verbatim */ +/* > PIVMIN is REAL */ +/* > The minimum pivot allowed in the Sturm sequence for T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NSPLIT */ +/* > \verbatim */ +/* > NSPLIT is INTEGER */ +/* > The number of diagonal blocks in the matrix T. */ +/* > 1 <= NSPLIT <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ISPLIT */ +/* > \verbatim */ +/* > ISPLIT is INTEGER array, dimension (N) */ +/* > The splitting points, at which T breaks up into submatrices. */ +/* > The first submatrix consists of rows/columns 1 to ISPLIT(1), */ +/* > the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */ +/* > etc., and the NSPLIT-th consists of rows/columns */ +/* > ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */ +/* > (Only the first NSPLIT elements will actually be used, but */ +/* > since the user cannot know a priori what value NSPLIT will */ +/* > have, N words must be reserved for ISPLIT.) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The actual number of eigenvalues found. 0 <= M <= N. */ +/* > (See also the description of INFO=2,3.) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is REAL array, dimension (N) */ +/* > On exit, the first M elements of W will contain the */ +/* > eigenvalue approximations. SLARRD computes an interval */ +/* > I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue */ +/* > approximation is given as the interval midpoint */ +/* > W(j)= ( a_j + b_j)/2. The corresponding error is bounded by */ +/* > WERR(j) = abs( a_j - b_j)/2 */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WERR */ +/* > \verbatim */ +/* > WERR is REAL array, dimension (N) */ +/* > The error bound on the corresponding eigenvalue approximation */ +/* > in W. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WL */ +/* > \verbatim */ +/* > WL is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WU */ +/* > \verbatim */ +/* > WU is REAL */ +/* > The interval (WL, WU] contains all the wanted eigenvalues. */ +/* > If RANGE='V', then WL=VL and WU=VU. */ +/* > If RANGE='A', then WL and WU are the global Gerschgorin bounds */ +/* > on the spectrum. */ +/* > If RANGE='I', then WL and WU are computed by SLAEBZ from the */ +/* > index range specified. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IBLOCK */ +/* > \verbatim */ +/* > IBLOCK is INTEGER array, dimension (N) */ +/* > At each row/column j where E(j) is zero or small, the */ +/* > matrix T is considered to split into a block diagonal */ +/* > matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which */ +/* > block (from 1 to the number of blocks) the eigenvalue W(i) */ +/* > belongs. (SLARRD may use the remaining N-M elements as */ +/* > workspace.) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INDEXW */ +/* > \verbatim */ +/* > INDEXW is INTEGER array, dimension (N) */ +/* > The indices of the eigenvalues within each block (submatrix); */ +/* > for example, INDEXW(i)= j and IBLOCK(i)=k imply that the */ +/* > i-th eigenvalue W(i) is the j-th eigenvalue in block k. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (4*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: some or all of the eigenvalues failed to converge or */ +/* > were not computed: */ +/* > =1 or 3: Bisection failed to converge for some */ +/* > eigenvalues; these eigenvalues are flagged by a */ +/* > negative block number. The effect is that the */ +/* > eigenvalues may not be as accurate as the */ +/* > absolute and relative tolerances. This is */ +/* > generally caused by unexpectedly inaccurate */ +/* > arithmetic. */ +/* > =2 or 3: RANGE='I' only: Not all of the eigenvalues */ +/* > IL:IU were found. */ +/* > Effect: M < IU+1-IL */ +/* > Cause: non-monotonic arithmetic, causing the */ +/* > Sturm sequence to be non-monotonic. */ +/* > Cure: recalculate, using RANGE='A', and pick */ +/* > out eigenvalues IL:IU. In some cases, */ +/* > increasing the PARAMETER "FUDGE" may */ +/* > make things work. */ +/* > = 4: RANGE='I', and the Gershgorin interval */ +/* > initially used was too small. No eigenvalues */ +/* > were computed. */ +/* > Probable cause: your machine has sloppy */ +/* > floating-point arithmetic. */ +/* > Cure: Increase the PARAMETER "FUDGE", */ +/* > recompile, and try again. */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > FUDGE REAL, default = 2 */ +/* > A "fudge factor" to widen the Gershgorin intervals. Ideally, */ +/* > a value of 1 should work, but on machines with sloppy */ +/* > arithmetic, this needs to be larger. The default for */ +/* > publicly released versions should be large enough to handle */ +/* > the worst machine around. Note that this has no effect */ +/* > on accuracy of the solution. */ +/* > \endverbatim */ +/* > */ +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > W. Kahan, University of California, Berkeley, USA \n */ +/* > Beresford Parlett, University of California, Berkeley, USA \n */ +/* > Jim Demmel, University of California, Berkeley, USA \n */ +/* > Inderjit Dhillon, University of Texas, Austin, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ +/* > Christof Voemel, University of California, Berkeley, USA \n */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slarrd_(char *range, char *order, integer *n, real *vl, + real *vu, integer *il, integer *iu, real *gers, real *reltol, real * + d__, real *e, real *e2, real *pivmin, integer *nsplit, integer * + isplit, integer *m, real *w, real *werr, real *wl, real *wu, integer * + iblock, integer *indexw, real *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + real r__1, r__2; + + /* Local variables */ + integer iend, jblk, ioff, iout, itmp1, itmp2, i__, j, jdisc; + extern logical lsame_(char *, char *); + integer iinfo; + real atoli; + integer iwoff, itmax; + real wkill, rtoli, uflow, tnorm; + integer ib, ie, je, nb; + real gl; + integer im, in; + real gu; + integer ibegin, iw, irange, idiscl; + extern real slamch_(char *); + integer idumma[1]; + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer idiscu; + extern /* Subroutine */ int slaebz_(integer *, integer *, integer *, + integer *, integer *, integer *, real *, real *, real *, real *, + real *, real *, integer *, real *, real *, integer *, integer *, + real *, integer *, integer *); + logical ncnvrg, toofew; + integer jee; + real eps; + integer nwl; + real wlu, wul; + integer nwu; + real tmp1, tmp2; + + +/* -- LAPACK auxiliary routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --iwork; + --work; + --indexw; + --iblock; + --werr; + --w; + --isplit; + --e2; + --e; + --d__; + --gers; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n <= 0) { + return 0; + } + +/* Decode RANGE */ + + if (lsame_(range, "A")) { + irange = 1; + } else if (lsame_(range, "V")) { + irange = 2; + } else if (lsame_(range, "I")) { + irange = 3; + } else { + irange = 0; + } + +/* Check for Errors */ + + if (irange <= 0) { + *info = -1; + } else if (! (lsame_(order, "B") || lsame_(order, + "E"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (irange == 2) { + if (*vl >= *vu) { + *info = -5; + } + } else if (irange == 3 && (*il < 1 || *il > f2cmax(1,*n))) { + *info = -6; + } else if (irange == 3 && (*iu < f2cmin(*n,*il) || *iu > *n)) { + *info = -7; + } + + if (*info != 0) { + return 0; + } +/* Initialize error flags */ + *info = 0; + ncnvrg = FALSE_; + toofew = FALSE_; +/* Quick return if possible */ + *m = 0; + if (*n == 0) { + return 0; + } +/* Simplification: */ + if (irange == 3 && *il == 1 && *iu == *n) { + irange = 1; + } +/* Get machine constants */ + eps = slamch_("P"); + uflow = slamch_("U"); +/* Special Case when N=1 */ +/* Treat case of 1x1 matrix for quick return */ + if (*n == 1) { + if (irange == 1 || irange == 2 && d__[1] > *vl && d__[1] <= *vu || + irange == 3 && *il == 1 && *iu == 1) { + *m = 1; + w[1] = d__[1]; +/* The computation error of the eigenvalue is zero */ + werr[1] = 0.f; + iblock[1] = 1; + indexw[1] = 1; + } + return 0; + } +/* NB is the minimum vector length for vector bisection, or 0 */ +/* if only scalar is to be done. */ + nb = ilaenv_(&c__1, "SSTEBZ", " ", n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + if (nb <= 1) { + nb = 0; + } +/* Find global spectral radius */ + gl = d__[1]; + gu = d__[1]; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MIN */ + r__1 = gl, r__2 = gers[(i__ << 1) - 1]; + gl = f2cmin(r__1,r__2); +/* Computing MAX */ + r__1 = gu, r__2 = gers[i__ * 2]; + gu = f2cmax(r__1,r__2); +/* L5: */ + } +/* Compute global Gerschgorin bounds and spectral diameter */ +/* Computing MAX */ + r__1 = abs(gl), r__2 = abs(gu); + tnorm = f2cmax(r__1,r__2); + gl = gl - tnorm * 2.f * eps * *n - *pivmin * 4.f; + gu = gu + tnorm * 2.f * eps * *n + *pivmin * 4.f; +/* [JAN/28/2009] remove the line below since SPDIAM variable not use */ +/* SPDIAM = GU - GL */ +/* Input arguments for SLAEBZ: */ +/* The relative tolerance. An interval (a,b] lies within */ +/* "relative tolerance" if b-a < RELTOL*f2cmax(|a|,|b|), */ + rtoli = *reltol; +/* Set the absolute tolerance for interval convergence to zero to force */ +/* interval convergence based on relative size of the interval. */ +/* This is dangerous because intervals might not converge when RELTOL is */ +/* small. But at least a very small number should be selected so that for */ +/* strongly graded matrices, the code can get relatively accurate */ +/* eigenvalues. */ + atoli = uflow * 4.f + *pivmin * 4.f; + if (irange == 3) { +/* RANGE='I': Compute an interval containing eigenvalues */ +/* IL through IU. The initial interval [GL,GU] from the global */ +/* Gerschgorin bounds GL and GU is refined by SLAEBZ. */ + itmax = (integer) ((log(tnorm + *pivmin) - log(*pivmin)) / log(2.f)) + + 2; + work[*n + 1] = gl; + work[*n + 2] = gl; + work[*n + 3] = gu; + work[*n + 4] = gu; + work[*n + 5] = gl; + work[*n + 6] = gu; + iwork[1] = -1; + iwork[2] = -1; + iwork[3] = *n + 1; + iwork[4] = *n + 1; + iwork[5] = *il - 1; + iwork[6] = *iu; + + slaebz_(&c__3, &itmax, n, &c__2, &c__2, &nb, &atoli, &rtoli, pivmin, & + d__[1], &e[1], &e2[1], &iwork[5], &work[*n + 1], &work[*n + 5] + , &iout, &iwork[1], &w[1], &iblock[1], &iinfo); + if (iinfo != 0) { + *info = iinfo; + return 0; + } +/* On exit, output intervals may not be ordered by ascending negcount */ + if (iwork[6] == *iu) { + *wl = work[*n + 1]; + wlu = work[*n + 3]; + nwl = iwork[1]; + *wu = work[*n + 4]; + wul = work[*n + 2]; + nwu = iwork[4]; + } else { + *wl = work[*n + 2]; + wlu = work[*n + 4]; + nwl = iwork[2]; + *wu = work[*n + 3]; + wul = work[*n + 1]; + nwu = iwork[3]; + } +/* On exit, the interval [WL, WLU] contains a value with negcount NWL, */ +/* and [WUL, WU] contains a value with negcount NWU. */ + if (nwl < 0 || nwl >= *n || nwu < 1 || nwu > *n) { + *info = 4; + return 0; + } + } else if (irange == 2) { + *wl = *vl; + *wu = *vu; + } else if (irange == 1) { + *wl = gl; + *wu = gu; + } +/* Find Eigenvalues -- Loop Over blocks and recompute NWL and NWU. */ +/* NWL accumulates the number of eigenvalues .le. WL, */ +/* NWU accumulates the number of eigenvalues .le. WU */ + *m = 0; + iend = 0; + *info = 0; + nwl = 0; + nwu = 0; + + i__1 = *nsplit; + for (jblk = 1; jblk <= i__1; ++jblk) { + ioff = iend; + ibegin = ioff + 1; + iend = isplit[jblk]; + in = iend - ioff; + + if (in == 1) { +/* 1x1 block */ + if (*wl >= d__[ibegin] - *pivmin) { + ++nwl; + } + if (*wu >= d__[ibegin] - *pivmin) { + ++nwu; + } + if (irange == 1 || *wl < d__[ibegin] - *pivmin && *wu >= d__[ + ibegin] - *pivmin) { + ++(*m); + w[*m] = d__[ibegin]; + werr[*m] = 0.f; +/* The gap for a single block doesn't matter for the later */ +/* algorithm and is assigned an arbitrary large value */ + iblock[*m] = jblk; + indexw[*m] = 1; + } +/* Disabled 2x2 case because of a failure on the following matrix */ +/* RANGE = 'I', IL = IU = 4 */ +/* Original Tridiagonal, d = [ */ +/* -0.150102010615740E+00 */ +/* -0.849897989384260E+00 */ +/* -0.128208148052635E-15 */ +/* 0.128257718286320E-15 */ +/* ]; */ +/* e = [ */ +/* -0.357171383266986E+00 */ +/* -0.180411241501588E-15 */ +/* -0.175152352710251E-15 */ +/* ]; */ + +/* ELSE IF( IN.EQ.2 ) THEN */ +/* * 2x2 block */ +/* DISC = SQRT( (HALF*(D(IBEGIN)-D(IEND)))**2 + E(IBEGIN)**2 ) */ +/* TMP1 = HALF*(D(IBEGIN)+D(IEND)) */ +/* L1 = TMP1 - DISC */ +/* IF( WL.GE. L1-PIVMIN ) */ +/* $ NWL = NWL + 1 */ +/* IF( WU.GE. L1-PIVMIN ) */ +/* $ NWU = NWU + 1 */ +/* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L1-PIVMIN .AND. WU.GE. */ +/* $ L1-PIVMIN ) ) THEN */ +/* M = M + 1 */ +/* W( M ) = L1 */ +/* * The uncertainty of eigenvalues of a 2x2 matrix is very small */ +/* WERR( M ) = EPS * ABS( W( M ) ) * TWO */ +/* IBLOCK( M ) = JBLK */ +/* INDEXW( M ) = 1 */ +/* ENDIF */ +/* L2 = TMP1 + DISC */ +/* IF( WL.GE. L2-PIVMIN ) */ +/* $ NWL = NWL + 1 */ +/* IF( WU.GE. L2-PIVMIN ) */ +/* $ NWU = NWU + 1 */ +/* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L2-PIVMIN .AND. WU.GE. */ +/* $ L2-PIVMIN ) ) THEN */ +/* M = M + 1 */ +/* W( M ) = L2 */ +/* * The uncertainty of eigenvalues of a 2x2 matrix is very small */ +/* WERR( M ) = EPS * ABS( W( M ) ) * TWO */ +/* IBLOCK( M ) = JBLK */ +/* INDEXW( M ) = 2 */ +/* ENDIF */ + } else { +/* General Case - block of size IN >= 2 */ +/* Compute local Gerschgorin interval and use it as the initial */ +/* interval for SLAEBZ */ + gu = d__[ibegin]; + gl = d__[ibegin]; + tmp1 = 0.f; + i__2 = iend; + for (j = ibegin; j <= i__2; ++j) { +/* Computing MIN */ + r__1 = gl, r__2 = gers[(j << 1) - 1]; + gl = f2cmin(r__1,r__2); +/* Computing MAX */ + r__1 = gu, r__2 = gers[j * 2]; + gu = f2cmax(r__1,r__2); +/* L40: */ + } +/* [JAN/28/2009] */ +/* change SPDIAM by TNORM in lines 2 and 3 thereafter */ +/* line 1: remove computation of SPDIAM (not useful anymore) */ +/* SPDIAM = GU - GL */ +/* GL = GL - FUDGE*SPDIAM*EPS*IN - FUDGE*PIVMIN */ +/* GU = GU + FUDGE*SPDIAM*EPS*IN + FUDGE*PIVMIN */ + gl = gl - tnorm * 2.f * eps * in - *pivmin * 2.f; + gu = gu + tnorm * 2.f * eps * in + *pivmin * 2.f; + + if (irange > 1) { + if (gu < *wl) { +/* the local block contains none of the wanted eigenvalues */ + nwl += in; + nwu += in; + goto L70; + } +/* refine search interval if possible, only range (WL,WU] matters */ + gl = f2cmax(gl,*wl); + gu = f2cmin(gu,*wu); + if (gl >= gu) { + goto L70; + } + } +/* Find negcount of initial interval boundaries GL and GU */ + work[*n + 1] = gl; + work[*n + in + 1] = gu; + slaebz_(&c__1, &c__0, &in, &in, &c__1, &nb, &atoli, &rtoli, + pivmin, &d__[ibegin], &e[ibegin], &e2[ibegin], idumma, & + work[*n + 1], &work[*n + (in << 1) + 1], &im, &iwork[1], & + w[*m + 1], &iblock[*m + 1], &iinfo); + if (iinfo != 0) { + *info = iinfo; + return 0; + } + + nwl += iwork[1]; + nwu += iwork[in + 1]; + iwoff = *m - iwork[1]; +/* Compute Eigenvalues */ + itmax = (integer) ((log(gu - gl + *pivmin) - log(*pivmin)) / log( + 2.f)) + 2; + slaebz_(&c__2, &itmax, &in, &in, &c__1, &nb, &atoli, &rtoli, + pivmin, &d__[ibegin], &e[ibegin], &e2[ibegin], idumma, & + work[*n + 1], &work[*n + (in << 1) + 1], &iout, &iwork[1], + &w[*m + 1], &iblock[*m + 1], &iinfo); + if (iinfo != 0) { + *info = iinfo; + return 0; + } + +/* Copy eigenvalues into W and IBLOCK */ +/* Use -JBLK for block number for unconverged eigenvalues. */ +/* Loop over the number of output intervals from SLAEBZ */ + i__2 = iout; + for (j = 1; j <= i__2; ++j) { +/* eigenvalue approximation is middle point of interval */ + tmp1 = (work[j + *n] + work[j + in + *n]) * .5f; +/* semi length of error interval */ + tmp2 = (r__1 = work[j + *n] - work[j + in + *n], abs(r__1)) * + .5f; + if (j > iout - iinfo) { +/* Flag non-convergence. */ + ncnvrg = TRUE_; + ib = -jblk; + } else { + ib = jblk; + } + i__3 = iwork[j + in] + iwoff; + for (je = iwork[j] + 1 + iwoff; je <= i__3; ++je) { + w[je] = tmp1; + werr[je] = tmp2; + indexw[je] = je - iwoff; + iblock[je] = ib; +/* L50: */ + } +/* L60: */ + } + + *m += im; + } +L70: + ; + } +/* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU */ +/* If NWL+1 < IL or NWU > IU, discard extra eigenvalues. */ + if (irange == 3) { + idiscl = *il - 1 - nwl; + idiscu = nwu - *iu; + + if (idiscl > 0) { + im = 0; + i__1 = *m; + for (je = 1; je <= i__1; ++je) { +/* Remove some of the smallest eigenvalues from the left so that */ +/* at the end IDISCL =0. Move all eigenvalues up to the left. */ + if (w[je] <= wlu && idiscl > 0) { + --idiscl; + } else { + ++im; + w[im] = w[je]; + werr[im] = werr[je]; + indexw[im] = indexw[je]; + iblock[im] = iblock[je]; + } +/* L80: */ + } + *m = im; + } + if (idiscu > 0) { +/* Remove some of the largest eigenvalues from the right so that */ +/* at the end IDISCU =0. Move all eigenvalues up to the left. */ + im = *m + 1; + for (je = *m; je >= 1; --je) { + if (w[je] >= wul && idiscu > 0) { + --idiscu; + } else { + --im; + w[im] = w[je]; + werr[im] = werr[je]; + indexw[im] = indexw[je]; + iblock[im] = iblock[je]; + } +/* L81: */ + } + jee = 0; + i__1 = *m; + for (je = im; je <= i__1; ++je) { + ++jee; + w[jee] = w[je]; + werr[jee] = werr[je]; + indexw[jee] = indexw[je]; + iblock[jee] = iblock[je]; +/* L82: */ + } + *m = *m - im + 1; + } + if (idiscl > 0 || idiscu > 0) { +/* Code to deal with effects of bad arithmetic. (If N(w) is */ +/* monotone non-decreasing, this should never happen.) */ +/* Some low eigenvalues to be discarded are not in (WL,WLU], */ +/* or high eigenvalues to be discarded are not in (WUL,WU] */ +/* so just kill off the smallest IDISCL/largest IDISCU */ +/* eigenvalues, by marking the corresponding IBLOCK = 0 */ + if (idiscl > 0) { + wkill = *wu; + i__1 = idiscl; + for (jdisc = 1; jdisc <= i__1; ++jdisc) { + iw = 0; + i__2 = *m; + for (je = 1; je <= i__2; ++je) { + if (iblock[je] != 0 && (w[je] < wkill || iw == 0)) { + iw = je; + wkill = w[je]; + } +/* L90: */ + } + iblock[iw] = 0; +/* L100: */ + } + } + if (idiscu > 0) { + wkill = *wl; + i__1 = idiscu; + for (jdisc = 1; jdisc <= i__1; ++jdisc) { + iw = 0; + i__2 = *m; + for (je = 1; je <= i__2; ++je) { + if (iblock[je] != 0 && (w[je] >= wkill || iw == 0)) { + iw = je; + wkill = w[je]; + } +/* L110: */ + } + iblock[iw] = 0; +/* L120: */ + } + } +/* Now erase all eigenvalues with IBLOCK set to zero */ + im = 0; + i__1 = *m; + for (je = 1; je <= i__1; ++je) { + if (iblock[je] != 0) { + ++im; + w[im] = w[je]; + werr[im] = werr[je]; + indexw[im] = indexw[je]; + iblock[im] = iblock[je]; + } +/* L130: */ + } + *m = im; + } + if (idiscl < 0 || idiscu < 0) { + toofew = TRUE_; + } + } + + if (irange == 1 && *m != *n || irange == 3 && *m != *iu - *il + 1) { + toofew = TRUE_; + } +/* If ORDER='B', do nothing the eigenvalues are already sorted by */ +/* block. */ +/* If ORDER='E', sort the eigenvalues from smallest to largest */ + if (lsame_(order, "E") && *nsplit > 1) { + i__1 = *m - 1; + for (je = 1; je <= i__1; ++je) { + ie = 0; + tmp1 = w[je]; + i__2 = *m; + for (j = je + 1; j <= i__2; ++j) { + if (w[j] < tmp1) { + ie = j; + tmp1 = w[j]; + } +/* L140: */ + } + if (ie != 0) { + tmp2 = werr[ie]; + itmp1 = iblock[ie]; + itmp2 = indexw[ie]; + w[ie] = w[je]; + werr[ie] = werr[je]; + iblock[ie] = iblock[je]; + indexw[ie] = indexw[je]; + w[je] = tmp1; + werr[je] = tmp2; + iblock[je] = itmp1; + indexw[je] = itmp2; + } +/* L150: */ + } + } + + *info = 0; + if (ncnvrg) { + ++(*info); + } + if (toofew) { + *info += 2; + } + return 0; + +/* End of SLARRD */ + +} /* slarrd_ */ + diff --git a/lapack-netlib/SRC/slarre.c b/lapack-netlib/SRC/slarre.c new file mode 100644 index 000000000..dbf5de6b1 --- /dev/null +++ b/lapack-netlib/SRC/slarre.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 SLARRE given the tridiagonal matrix T, sets small off-diagonal elements to zero and for each un +reduced block Ti, finds base representations and eigenvalues. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARRE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARRE( RANGE, N, VL, VU, IL, IU, D, E, E2, */ +/* RTOL1, RTOL2, SPLTOL, NSPLIT, ISPLIT, M, */ +/* W, WERR, WGAP, IBLOCK, INDEXW, GERS, PIVMIN, */ +/* WORK, IWORK, INFO ) */ + +/* CHARACTER RANGE */ +/* INTEGER IL, INFO, IU, M, N, NSPLIT */ +/* REAL PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU */ +/* INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ), */ +/* $ INDEXW( * ) */ +/* REAL D( * ), E( * ), E2( * ), GERS( * ), */ +/* $ W( * ),WERR( * ), WGAP( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > To find the desired eigenvalues of a given real symmetric */ +/* > tridiagonal matrix T, SLARRE sets any "small" off-diagonal */ +/* > elements to zero, and for each unreduced block T_i, it finds */ +/* > (a) a suitable shift at one end of the block's spectrum, */ +/* > (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and */ +/* > (c) eigenvalues of each L_i D_i L_i^T. */ +/* > The representations and eigenvalues found are then used by */ +/* > SSTEMR to compute the eigenvectors of T. */ +/* > The accuracy varies depending on whether bisection is used to */ +/* > find a few eigenvalues or the dqds algorithm (subroutine SLASQ2) to */ +/* > conpute all and then discard any unwanted one. */ +/* > As an added benefit, SLARRE also outputs the n */ +/* > Gerschgorin intervals for the matrices L_i D_i L_i^T. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] RANGE */ +/* > \verbatim */ +/* > RANGE is CHARACTER*1 */ +/* > = 'A': ("All") all eigenvalues will be found. */ +/* > = 'V': ("Value") all eigenvalues in the half-open interval */ +/* > (VL, VU] will be found. */ +/* > = 'I': ("Index") the IL-th through IU-th eigenvalues (of the */ +/* > entire matrix) will be found. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VL */ +/* > \verbatim */ +/* > VL is REAL */ +/* > If RANGE='V', the lower bound for the eigenvalues. */ +/* > Eigenvalues less than or equal to VL, or greater than VU, */ +/* > will not be returned. VL < VU. */ +/* > If RANGE='I' or ='A', SLARRE computes bounds on the desired */ +/* > part of the spectrum. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VU */ +/* > \verbatim */ +/* > VU is REAL */ +/* > If RANGE='V', the upper bound for the eigenvalues. */ +/* > Eigenvalues less than or equal to VL, or greater than VU, */ +/* > will not be returned. VL < VU. */ +/* > If RANGE='I' or ='A', SLARRE computes bounds on the desired */ +/* > part of the spectrum. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IL */ +/* > \verbatim */ +/* > IL is INTEGER */ +/* > If RANGE='I', the index of the */ +/* > smallest eigenvalue to be returned. */ +/* > 1 <= IL <= IU <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IU */ +/* > \verbatim */ +/* > IU is INTEGER */ +/* > If RANGE='I', the index of the */ +/* > largest eigenvalue to be returned. */ +/* > 1 <= IL <= IU <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry, the N diagonal elements of the tridiagonal */ +/* > matrix T. */ +/* > On exit, the N diagonal elements of the diagonal */ +/* > matrices D_i. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (N) */ +/* > On entry, the first (N-1) entries contain the subdiagonal */ +/* > elements of the tridiagonal matrix T; E(N) need not be set. */ +/* > On exit, E contains the subdiagonal elements of the unit */ +/* > bidiagonal matrices L_i. The entries E( ISPLIT( I ) ), */ +/* > 1 <= I <= NSPLIT, contain the base points sigma_i on output. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E2 */ +/* > \verbatim */ +/* > E2 is REAL array, dimension (N) */ +/* > On entry, the first (N-1) entries contain the SQUARES of the */ +/* > subdiagonal elements of the tridiagonal matrix T; */ +/* > E2(N) need not be set. */ +/* > On exit, the entries E2( ISPLIT( I ) ), */ +/* > 1 <= I <= NSPLIT, have been set to zero */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RTOL1 */ +/* > \verbatim */ +/* > RTOL1 is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RTOL2 */ +/* > \verbatim */ +/* > RTOL2 is REAL */ +/* > Parameters for bisection. */ +/* > An interval [LEFT,RIGHT] has converged if */ +/* > RIGHT-LEFT < MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SPLTOL */ +/* > \verbatim */ +/* > SPLTOL is REAL */ +/* > The threshold for splitting. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] NSPLIT */ +/* > \verbatim */ +/* > NSPLIT is INTEGER */ +/* > The number of blocks T splits into. 1 <= NSPLIT <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ISPLIT */ +/* > \verbatim */ +/* > ISPLIT is INTEGER array, dimension (N) */ +/* > The splitting points, at which T breaks up into blocks. */ +/* > The first block consists of rows/columns 1 to ISPLIT(1), */ +/* > the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */ +/* > etc., and the NSPLIT-th consists of rows/columns */ +/* > ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The total number of eigenvalues (of all L_i D_i L_i^T) */ +/* > found. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is REAL array, dimension (N) */ +/* > The first M elements contain the eigenvalues. The */ +/* > eigenvalues of each of the blocks, L_i D_i L_i^T, are */ +/* > sorted in ascending order ( SLARRE may use the */ +/* > remaining N-M elements as workspace). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WERR */ +/* > \verbatim */ +/* > WERR is REAL array, dimension (N) */ +/* > The error bound on the corresponding eigenvalue in W. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WGAP */ +/* > \verbatim */ +/* > WGAP is REAL array, dimension (N) */ +/* > The separation from the right neighbor eigenvalue in W. */ +/* > The gap is only with respect to the eigenvalues of the same block */ +/* > as each block has its own representation tree. */ +/* > Exception: at the right end of a block we store the left gap */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IBLOCK */ +/* > \verbatim */ +/* > IBLOCK is INTEGER array, dimension (N) */ +/* > The indices of the blocks (submatrices) associated with the */ +/* > corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue */ +/* > W(i) belongs to the first block from the top, =2 if W(i) */ +/* > belongs to the second block, etc. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INDEXW */ +/* > \verbatim */ +/* > INDEXW is INTEGER array, dimension (N) */ +/* > The indices of the eigenvalues within each block (submatrix); */ +/* > for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the */ +/* > i-th eigenvalue W(i) is the 10-th eigenvalue in block 2 */ +/* > \endverbatim */ +/* > */ +/* > \param[out] GERS */ +/* > \verbatim */ +/* > GERS is REAL array, dimension (2*N) */ +/* > The N Gerschgorin intervals (the i-th Gerschgorin interval */ +/* > is (GERS(2*i-1), GERS(2*i)). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PIVMIN */ +/* > \verbatim */ +/* > PIVMIN is REAL */ +/* > The minimum pivot in the Sturm sequence for T. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (6*N) */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (5*N) */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > > 0: A problem occurred in SLARRE. */ +/* > < 0: One of the called subroutines signaled an internal problem. */ +/* > Needs inspection of the corresponding parameter IINFO */ +/* > for further information. */ +/* > */ +/* > =-1: Problem in SLARRD. */ +/* > = 2: No base representation could be found in MAXTRY iterations. */ +/* > Increasing MAXTRY and recompilation might be a remedy. */ +/* > =-3: Problem in SLARRB when computing the refined root */ +/* > representation for SLASQ2. */ +/* > =-4: Problem in SLARRB when preforming bisection on the */ +/* > desired part of the spectrum. */ +/* > =-5: Problem in SLASQ2. */ +/* > =-6: Problem in SLASQ2. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The base representations are required to suffer very little */ +/* > element growth and consequently define all their eigenvalues to */ +/* > high relative accuracy. */ +/* > \endverbatim */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Beresford Parlett, University of California, Berkeley, USA \n */ +/* > Jim Demmel, University of California, Berkeley, USA \n */ +/* > Inderjit Dhillon, University of Texas, Austin, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ +/* > Christof Voemel, University of California, Berkeley, USA \n */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slarre_(char *range, integer *n, real *vl, real *vu, + integer *il, integer *iu, real *d__, real *e, real *e2, real *rtol1, + real *rtol2, real *spltol, integer *nsplit, integer *isplit, integer * + m, real *w, real *werr, real *wgap, integer *iblock, integer *indexw, + real *gers, real *pivmin, real *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + real r__1, r__2, r__3; + + /* Local variables */ + real eabs; + integer iend, jblk; + real eold; + integer indl; + real dmax__, emax; + integer wend, idum, indu; + real rtol; + integer i__, j, iseed[4]; + real avgap, sigma; + extern logical lsame_(char *, char *); + integer iinfo; + logical norep; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + real s1, s2; + extern /* Subroutine */ int slasq2_(integer *, real *, integer *); + integer mb; + real gl; + integer in, mm; + real gu; + integer ibegin; + logical forceb; + integer irange; + real sgndef; + extern real slamch_(char *); + integer wbegin; + real safmin, spdiam; + extern /* Subroutine */ int slarra_(integer *, real *, real *, real *, + real *, real *, integer *, integer *, integer *); + logical usedqd; + real clwdth, isleft; + extern /* Subroutine */ int slarrb_(integer *, real *, real *, integer *, + integer *, real *, real *, integer *, real *, real *, real *, + real *, integer *, real *, real *, integer *, integer *), slarrc_( + char *, integer *, real *, real *, real *, real *, real *, + integer *, integer *, integer *, integer *), slarrd_(char + *, char *, integer *, real *, real *, integer *, integer *, real * + , real *, real *, real *, real *, real *, integer *, integer *, + integer *, real *, real *, real *, real *, integer *, integer *, + real *, integer *, integer *), slarrk_(integer *, + integer *, real *, real *, real *, real *, real *, real *, real *, + real *, integer *); + real isrght, bsrtol, dpivot; + extern /* Subroutine */ int slarnv_(integer *, integer *, integer *, real + *); + integer cnt; + real eps, tau, tmp, rtl; + integer cnt1, cnt2; + real tmp1; + + +/* -- LAPACK auxiliary routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --iwork; + --work; + --gers; + --indexw; + --iblock; + --wgap; + --werr; + --w; + --isplit; + --e2; + --e; + --d__; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n <= 0) { + return 0; + } + +/* Decode RANGE */ + + if (lsame_(range, "A")) { + irange = 1; + } else if (lsame_(range, "V")) { + irange = 3; + } else if (lsame_(range, "I")) { + irange = 2; + } + *m = 0; +/* Get machine constants */ + safmin = slamch_("S"); + eps = slamch_("P"); +/* Set parameters */ + rtl = eps * 100.f; +/* If one were ever to ask for less initial precision in BSRTOL, */ +/* one should keep in mind that for the subset case, the extremal */ +/* eigenvalues must be at least as accurate as the current setting */ +/* (eigenvalues in the middle need not as much accuracy) */ + bsrtol = sqrt(eps) * 5e-4f; +/* Treat case of 1x1 matrix for quick return */ + if (*n == 1) { + if (irange == 1 || irange == 3 && d__[1] > *vl && d__[1] <= *vu || + irange == 2 && *il == 1 && *iu == 1) { + *m = 1; + w[1] = d__[1]; +/* The computation error of the eigenvalue is zero */ + werr[1] = 0.f; + wgap[1] = 0.f; + iblock[1] = 1; + indexw[1] = 1; + gers[1] = d__[1]; + gers[2] = d__[1]; + } +/* store the shift for the initial RRR, which is zero in this case */ + e[1] = 0.f; + return 0; + } +/* General case: tridiagonal matrix of order > 1 */ + +/* Init WERR, WGAP. Compute Gerschgorin intervals and spectral diameter. */ +/* Compute maximum off-diagonal entry and pivmin. */ + gl = d__[1]; + gu = d__[1]; + eold = 0.f; + emax = 0.f; + e[*n] = 0.f; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + werr[i__] = 0.f; + wgap[i__] = 0.f; + eabs = (r__1 = e[i__], abs(r__1)); + if (eabs >= emax) { + emax = eabs; + } + tmp1 = eabs + eold; + gers[(i__ << 1) - 1] = d__[i__] - tmp1; +/* Computing MIN */ + r__1 = gl, r__2 = gers[(i__ << 1) - 1]; + gl = f2cmin(r__1,r__2); + gers[i__ * 2] = d__[i__] + tmp1; +/* Computing MAX */ + r__1 = gu, r__2 = gers[i__ * 2]; + gu = f2cmax(r__1,r__2); + eold = eabs; +/* L5: */ + } +/* The minimum pivot allowed in the Sturm sequence for T */ +/* Computing MAX */ +/* Computing 2nd power */ + r__3 = emax; + r__1 = 1.f, r__2 = r__3 * r__3; + *pivmin = safmin * f2cmax(r__1,r__2); +/* Compute spectral diameter. The Gerschgorin bounds give an */ +/* estimate that is wrong by at most a factor of SQRT(2) */ + spdiam = gu - gl; +/* Compute splitting points */ + slarra_(n, &d__[1], &e[1], &e2[1], spltol, &spdiam, nsplit, &isplit[1], & + iinfo); +/* Can force use of bisection instead of faster DQDS. */ +/* Option left in the code for future multisection work. */ + forceb = FALSE_; +/* Initialize USEDQD, DQDS should be used for ALLRNG unless someone */ +/* explicitly wants bisection. */ + usedqd = irange == 1 && ! forceb; + if (irange == 1 && ! forceb) { +/* Set interval [VL,VU] that contains all eigenvalues */ + *vl = gl; + *vu = gu; + } else { +/* We call SLARRD to find crude approximations to the eigenvalues */ +/* in the desired range. In case IRANGE = INDRNG, we also obtain the */ +/* interval (VL,VU] that contains all the wanted eigenvalues. */ +/* An interval [LEFT,RIGHT] has converged if */ +/* RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT)) */ +/* SLARRD needs a WORK of size 4*N, IWORK of size 3*N */ + slarrd_(range, "B", n, vl, vu, il, iu, &gers[1], &bsrtol, &d__[1], &e[ + 1], &e2[1], pivmin, nsplit, &isplit[1], &mm, &w[1], &werr[1], + vl, vu, &iblock[1], &indexw[1], &work[1], &iwork[1], &iinfo); + if (iinfo != 0) { + *info = -1; + return 0; + } +/* Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0 */ + i__1 = *n; + for (i__ = mm + 1; i__ <= i__1; ++i__) { + w[i__] = 0.f; + werr[i__] = 0.f; + iblock[i__] = 0; + indexw[i__] = 0; +/* L14: */ + } + } +/* ** */ +/* Loop over unreduced blocks */ + ibegin = 1; + wbegin = 1; + i__1 = *nsplit; + for (jblk = 1; jblk <= i__1; ++jblk) { + iend = isplit[jblk]; + in = iend - ibegin + 1; +/* 1 X 1 block */ + if (in == 1) { + if (irange == 1 || irange == 3 && d__[ibegin] > *vl && d__[ibegin] + <= *vu || irange == 2 && iblock[wbegin] == jblk) { + ++(*m); + w[*m] = d__[ibegin]; + werr[*m] = 0.f; +/* The gap for a single block doesn't matter for the later */ +/* algorithm and is assigned an arbitrary large value */ + wgap[*m] = 0.f; + iblock[*m] = jblk; + indexw[*m] = 1; + ++wbegin; + } +/* E( IEND ) holds the shift for the initial RRR */ + e[iend] = 0.f; + ibegin = iend + 1; + goto L170; + } + +/* Blocks of size larger than 1x1 */ + +/* E( IEND ) will hold the shift for the initial RRR, for now set it =0 */ + e[iend] = 0.f; + +/* Find local outer bounds GL,GU for the block */ + gl = d__[ibegin]; + gu = d__[ibegin]; + i__2 = iend; + for (i__ = ibegin; i__ <= i__2; ++i__) { +/* Computing MIN */ + r__1 = gers[(i__ << 1) - 1]; + gl = f2cmin(r__1,gl); +/* Computing MAX */ + r__1 = gers[i__ * 2]; + gu = f2cmax(r__1,gu); +/* L15: */ + } + spdiam = gu - gl; + if (! (irange == 1 && ! forceb)) { +/* Count the number of eigenvalues in the current block. */ + mb = 0; + i__2 = mm; + for (i__ = wbegin; i__ <= i__2; ++i__) { + if (iblock[i__] == jblk) { + ++mb; + } else { + goto L21; + } +/* L20: */ + } +L21: + if (mb == 0) { +/* No eigenvalue in the current block lies in the desired range */ +/* E( IEND ) holds the shift for the initial RRR */ + e[iend] = 0.f; + ibegin = iend + 1; + goto L170; + } else { +/* Decide whether dqds or bisection is more efficient */ + usedqd = (real) mb > in * .5f && ! forceb; + wend = wbegin + mb - 1; +/* Calculate gaps for the current block */ +/* In later stages, when representations for individual */ +/* eigenvalues are different, we use SIGMA = E( IEND ). */ + sigma = 0.f; + i__2 = wend - 1; + for (i__ = wbegin; i__ <= i__2; ++i__) { +/* Computing MAX */ + r__1 = 0.f, r__2 = w[i__ + 1] - werr[i__ + 1] - (w[i__] + + werr[i__]); + wgap[i__] = f2cmax(r__1,r__2); +/* L30: */ + } +/* Computing MAX */ + r__1 = 0.f, r__2 = *vu - sigma - (w[wend] + werr[wend]); + wgap[wend] = f2cmax(r__1,r__2); +/* Find local index of the first and last desired evalue. */ + indl = indexw[wbegin]; + indu = indexw[wend]; + } + } + if (irange == 1 && ! forceb || usedqd) { +/* Case of DQDS */ +/* Find approximations to the extremal eigenvalues of the block */ + slarrk_(&in, &c__1, &gl, &gu, &d__[ibegin], &e2[ibegin], pivmin, & + rtl, &tmp, &tmp1, &iinfo); + if (iinfo != 0) { + *info = -1; + return 0; + } +/* Computing MAX */ + r__2 = gl, r__3 = tmp - tmp1 - eps * 100.f * (r__1 = tmp - tmp1, + abs(r__1)); + isleft = f2cmax(r__2,r__3); + slarrk_(&in, &in, &gl, &gu, &d__[ibegin], &e2[ibegin], pivmin, & + rtl, &tmp, &tmp1, &iinfo); + if (iinfo != 0) { + *info = -1; + return 0; + } +/* Computing MIN */ + r__2 = gu, r__3 = tmp + tmp1 + eps * 100.f * (r__1 = tmp + tmp1, + abs(r__1)); + isrght = f2cmin(r__2,r__3); +/* Improve the estimate of the spectral diameter */ + spdiam = isrght - isleft; + } else { +/* Case of bisection */ +/* Find approximations to the wanted extremal eigenvalues */ +/* Computing MAX */ + r__2 = gl, r__3 = w[wbegin] - werr[wbegin] - eps * 100.f * (r__1 = + w[wbegin] - werr[wbegin], abs(r__1)); + isleft = f2cmax(r__2,r__3); +/* Computing MIN */ + r__2 = gu, r__3 = w[wend] + werr[wend] + eps * 100.f * (r__1 = w[ + wend] + werr[wend], abs(r__1)); + isrght = f2cmin(r__2,r__3); + } +/* Decide whether the base representation for the current block */ +/* L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I */ +/* should be on the left or the right end of the current block. */ +/* The strategy is to shift to the end which is "more populated" */ +/* Furthermore, decide whether to use DQDS for the computation of */ +/* the eigenvalue approximations at the end of SLARRE or bisection. */ +/* dqds is chosen if all eigenvalues are desired or the number of */ +/* eigenvalues to be computed is large compared to the blocksize. */ + if (irange == 1 && ! forceb) { +/* If all the eigenvalues have to be computed, we use dqd */ + usedqd = TRUE_; +/* INDL is the local index of the first eigenvalue to compute */ + indl = 1; + indu = in; +/* MB = number of eigenvalues to compute */ + mb = in; + wend = wbegin + mb - 1; +/* Define 1/4 and 3/4 points of the spectrum */ + s1 = isleft + spdiam * .25f; + s2 = isrght - spdiam * .25f; + } else { +/* SLARRD has computed IBLOCK and INDEXW for each eigenvalue */ +/* approximation. */ +/* choose sigma */ + if (usedqd) { + s1 = isleft + spdiam * .25f; + s2 = isrght - spdiam * .25f; + } else { + tmp = f2cmin(isrght,*vu) - f2cmax(isleft,*vl); + s1 = f2cmax(isleft,*vl) + tmp * .25f; + s2 = f2cmin(isrght,*vu) - tmp * .25f; + } + } +/* Compute the negcount at the 1/4 and 3/4 points */ + if (mb > 1) { + slarrc_("T", &in, &s1, &s2, &d__[ibegin], &e[ibegin], pivmin, & + cnt, &cnt1, &cnt2, &iinfo); + } + if (mb == 1) { + sigma = gl; + sgndef = 1.f; + } else if (cnt1 - indl >= indu - cnt2) { + if (irange == 1 && ! forceb) { + sigma = f2cmax(isleft,gl); + } else if (usedqd) { +/* use Gerschgorin bound as shift to get pos def matrix */ +/* for dqds */ + sigma = isleft; + } else { +/* use approximation of the first desired eigenvalue of the */ +/* block as shift */ + sigma = f2cmax(isleft,*vl); + } + sgndef = 1.f; + } else { + if (irange == 1 && ! forceb) { + sigma = f2cmin(isrght,gu); + } else if (usedqd) { +/* use Gerschgorin bound as shift to get neg def matrix */ +/* for dqds */ + sigma = isrght; + } else { +/* use approximation of the first desired eigenvalue of the */ +/* block as shift */ + sigma = f2cmin(isrght,*vu); + } + sgndef = -1.f; + } +/* An initial SIGMA has been chosen that will be used for computing */ +/* T - SIGMA I = L D L^T */ +/* Define the increment TAU of the shift in case the initial shift */ +/* needs to be refined to obtain a factorization with not too much */ +/* element growth. */ + if (usedqd) { +/* The initial SIGMA was to the outer end of the spectrum */ +/* the matrix is definite and we need not retreat. */ + tau = spdiam * eps * *n + *pivmin * 2.f; +/* Computing MAX */ + r__1 = tau, r__2 = eps * 2.f * abs(sigma); + tau = f2cmax(r__1,r__2); + } else { + if (mb > 1) { + clwdth = w[wend] + werr[wend] - w[wbegin] - werr[wbegin]; + avgap = (r__1 = clwdth / (real) (wend - wbegin), abs(r__1)); + if (sgndef == 1.f) { +/* Computing MAX */ + r__1 = wgap[wbegin]; + tau = f2cmax(r__1,avgap) * .5f; +/* Computing MAX */ + r__1 = tau, r__2 = werr[wbegin]; + tau = f2cmax(r__1,r__2); + } else { +/* Computing MAX */ + r__1 = wgap[wend - 1]; + tau = f2cmax(r__1,avgap) * .5f; +/* Computing MAX */ + r__1 = tau, r__2 = werr[wend]; + tau = f2cmax(r__1,r__2); + } + } else { + tau = werr[wbegin]; + } + } + + for (idum = 1; idum <= 6; ++idum) { +/* Compute L D L^T factorization of tridiagonal matrix T - sigma I. */ +/* Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of */ +/* pivots in WORK(2*IN+1:3*IN) */ + dpivot = d__[ibegin] - sigma; + work[1] = dpivot; + dmax__ = abs(work[1]); + j = ibegin; + i__2 = in - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[(in << 1) + i__] = 1.f / work[i__]; + tmp = e[j] * work[(in << 1) + i__]; + work[in + i__] = tmp; + dpivot = d__[j + 1] - sigma - tmp * e[j]; + work[i__ + 1] = dpivot; +/* Computing MAX */ + r__1 = dmax__, r__2 = abs(dpivot); + dmax__ = f2cmax(r__1,r__2); + ++j; +/* L70: */ + } +/* check for element growth */ + if (dmax__ > spdiam * 64.f) { + norep = TRUE_; + } else { + norep = FALSE_; + } + if (usedqd && ! norep) { +/* Ensure the definiteness of the representation */ +/* All entries of D (of L D L^T) must have the same sign */ + i__2 = in; + for (i__ = 1; i__ <= i__2; ++i__) { + tmp = sgndef * work[i__]; + if (tmp < 0.f) { + norep = TRUE_; + } +/* L71: */ + } + } + if (norep) { +/* Note that in the case of IRANGE=ALLRNG, we use the Gerschgorin */ +/* shift which makes the matrix definite. So we should end up */ +/* here really only in the case of IRANGE = VALRNG or INDRNG. */ + if (idum == 5) { + if (sgndef == 1.f) { +/* The fudged Gerschgorin shift should succeed */ + sigma = gl - spdiam * 2.f * eps * *n - *pivmin * 4.f; + } else { + sigma = gu + spdiam * 2.f * eps * *n + *pivmin * 4.f; + } + } else { + sigma -= sgndef * tau; + tau *= 2.f; + } + } else { +/* an initial RRR is found */ + goto L83; + } +/* L80: */ + } +/* if the program reaches this point, no base representation could be */ +/* found in MAXTRY iterations. */ + *info = 2; + return 0; +L83: +/* At this point, we have found an initial base representation */ +/* T - SIGMA I = L D L^T with not too much element growth. */ +/* Store the shift. */ + e[iend] = sigma; +/* Store D and L. */ + scopy_(&in, &work[1], &c__1, &d__[ibegin], &c__1); + i__2 = in - 1; + scopy_(&i__2, &work[in + 1], &c__1, &e[ibegin], &c__1); + if (mb > 1) { + +/* Perturb each entry of the base representation by a small */ +/* (but random) relative amount to overcome difficulties with */ +/* glued matrices. */ + + for (i__ = 1; i__ <= 4; ++i__) { + iseed[i__ - 1] = 1; +/* L122: */ + } + i__2 = (in << 1) - 1; + slarnv_(&c__2, iseed, &i__2, &work[1]); + i__2 = in - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + d__[ibegin + i__ - 1] *= eps * 4.f * work[i__] + 1.f; + e[ibegin + i__ - 1] *= eps * 4.f * work[in + i__] + 1.f; +/* L125: */ + } + d__[iend] *= eps * 4.f * work[in] + 1.f; + + } + +/* Don't update the Gerschgorin intervals because keeping track */ +/* of the updates would be too much work in SLARRV. */ +/* We update W instead and use it to locate the proper Gerschgorin */ +/* intervals. */ +/* Compute the required eigenvalues of L D L' by bisection or dqds */ + if (! usedqd) { +/* If SLARRD has been used, shift the eigenvalue approximations */ +/* according to their representation. This is necessary for */ +/* a uniform SLARRV since dqds computes eigenvalues of the */ +/* shifted representation. In SLARRV, W will always hold the */ +/* UNshifted eigenvalue approximation. */ + i__2 = wend; + for (j = wbegin; j <= i__2; ++j) { + w[j] -= sigma; + werr[j] += (r__1 = w[j], abs(r__1)) * eps; +/* L134: */ + } +/* call SLARRB to reduce eigenvalue error of the approximations */ +/* from SLARRD */ + i__2 = iend - 1; + for (i__ = ibegin; i__ <= i__2; ++i__) { +/* Computing 2nd power */ + r__1 = e[i__]; + work[i__] = d__[i__] * (r__1 * r__1); +/* L135: */ + } +/* use bisection to find EV from INDL to INDU */ + i__2 = indl - 1; + slarrb_(&in, &d__[ibegin], &work[ibegin], &indl, &indu, rtol1, + rtol2, &i__2, &w[wbegin], &wgap[wbegin], &werr[wbegin], & + work[(*n << 1) + 1], &iwork[1], pivmin, &spdiam, &in, & + iinfo); + if (iinfo != 0) { + *info = -4; + return 0; + } +/* SLARRB computes all gaps correctly except for the last one */ +/* Record distance to VU/GU */ +/* Computing MAX */ + r__1 = 0.f, r__2 = *vu - sigma - (w[wend] + werr[wend]); + wgap[wend] = f2cmax(r__1,r__2); + i__2 = indu; + for (i__ = indl; i__ <= i__2; ++i__) { + ++(*m); + iblock[*m] = jblk; + indexw[*m] = i__; +/* L138: */ + } + } else { +/* Call dqds to get all eigs (and then possibly delete unwanted */ +/* eigenvalues). */ +/* Note that dqds finds the eigenvalues of the L D L^T representation */ +/* of T to high relative accuracy. High relative accuracy */ +/* might be lost when the shift of the RRR is subtracted to obtain */ +/* the eigenvalues of T. However, T is not guaranteed to define its */ +/* eigenvalues to high relative accuracy anyway. */ +/* Set RTOL to the order of the tolerance used in SLASQ2 */ +/* This is an ESTIMATED error, the worst case bound is 4*N*EPS */ +/* which is usually too large and requires unnecessary work to be */ +/* done by bisection when computing the eigenvectors */ + rtol = log((real) in) * 4.f * eps; + j = ibegin; + i__2 = in - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[(i__ << 1) - 1] = (r__1 = d__[j], abs(r__1)); + work[i__ * 2] = e[j] * e[j] * work[(i__ << 1) - 1]; + ++j; +/* L140: */ + } + work[(in << 1) - 1] = (r__1 = d__[iend], abs(r__1)); + work[in * 2] = 0.f; + slasq2_(&in, &work[1], &iinfo); + if (iinfo != 0) { +/* If IINFO = -5 then an index is part of a tight cluster */ +/* and should be changed. The index is in IWORK(1) and the */ +/* gap is in WORK(N+1) */ + *info = -5; + return 0; + } else { +/* Test that all eigenvalues are positive as expected */ + i__2 = in; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] < 0.f) { + *info = -6; + return 0; + } +/* L149: */ + } + } + if (sgndef > 0.f) { + i__2 = indu; + for (i__ = indl; i__ <= i__2; ++i__) { + ++(*m); + w[*m] = work[in - i__ + 1]; + iblock[*m] = jblk; + indexw[*m] = i__; +/* L150: */ + } + } else { + i__2 = indu; + for (i__ = indl; i__ <= i__2; ++i__) { + ++(*m); + w[*m] = -work[i__]; + iblock[*m] = jblk; + indexw[*m] = i__; +/* L160: */ + } + } + i__2 = *m; + for (i__ = *m - mb + 1; i__ <= i__2; ++i__) { +/* the value of RTOL below should be the tolerance in SLASQ2 */ + werr[i__] = rtol * (r__1 = w[i__], abs(r__1)); +/* L165: */ + } + i__2 = *m - 1; + for (i__ = *m - mb + 1; i__ <= i__2; ++i__) { +/* compute the right gap between the intervals */ +/* Computing MAX */ + r__1 = 0.f, r__2 = w[i__ + 1] - werr[i__ + 1] - (w[i__] + + werr[i__]); + wgap[i__] = f2cmax(r__1,r__2); +/* L166: */ + } +/* Computing MAX */ + r__1 = 0.f, r__2 = *vu - sigma - (w[*m] + werr[*m]); + wgap[*m] = f2cmax(r__1,r__2); + } +/* proceed with next block */ + ibegin = iend + 1; + wbegin = wend + 1; +L170: + ; + } + + return 0; + +/* end of SLARRE */ + +} /* slarre_ */ + diff --git a/lapack-netlib/SRC/slarrf.c b/lapack-netlib/SRC/slarrf.c new file mode 100644 index 000000000..fa0699fdf --- /dev/null +++ b/lapack-netlib/SRC/slarrf.c @@ -0,0 +1,905 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLARRF finds a new relatively robust representation such that at least one of the eigenvalues i +s relatively isolated. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARRF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARRF( N, D, L, LD, CLSTRT, CLEND, */ +/* W, WGAP, WERR, */ +/* SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA, */ +/* DPLUS, LPLUS, WORK, INFO ) */ + +/* INTEGER CLSTRT, CLEND, INFO, N */ +/* REAL CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM */ +/* REAL D( * ), DPLUS( * ), L( * ), LD( * ), */ +/* $ LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Given the initial representation L D L^T and its cluster of close */ +/* > eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ... */ +/* > W( CLEND ), SLARRF finds a new relatively robust representation */ +/* > L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the */ +/* > eigenvalues of L(+) D(+) L(+)^T is relatively isolated. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix (subblock, if the matrix split). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The N diagonal elements of the diagonal matrix D. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is REAL array, dimension (N-1) */ +/* > The (N-1) subdiagonal elements of the unit bidiagonal */ +/* > matrix L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LD */ +/* > \verbatim */ +/* > LD is REAL array, dimension (N-1) */ +/* > The (N-1) elements L(i)*D(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CLSTRT */ +/* > \verbatim */ +/* > CLSTRT is INTEGER */ +/* > The index of the first eigenvalue in the cluster. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CLEND */ +/* > \verbatim */ +/* > CLEND is INTEGER */ +/* > The index of the last eigenvalue in the cluster. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] W */ +/* > \verbatim */ +/* > W is REAL array, dimension */ +/* > dimension is >= (CLEND-CLSTRT+1) */ +/* > The eigenvalue APPROXIMATIONS of L D L^T in ascending order. */ +/* > W( CLSTRT ) through W( CLEND ) form the cluster of relatively */ +/* > close eigenalues. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] WGAP */ +/* > \verbatim */ +/* > WGAP is REAL array, dimension */ +/* > dimension is >= (CLEND-CLSTRT+1) */ +/* > The separation from the right neighbor eigenvalue in W. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WERR */ +/* > \verbatim */ +/* > WERR is REAL array, dimension */ +/* > dimension is >= (CLEND-CLSTRT+1) */ +/* > WERR contain the semiwidth of the uncertainty */ +/* > interval of the corresponding eigenvalue APPROXIMATION in W */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SPDIAM */ +/* > \verbatim */ +/* > SPDIAM is REAL */ +/* > estimate of the spectral diameter obtained from the */ +/* > Gerschgorin intervals */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CLGAPL */ +/* > \verbatim */ +/* > CLGAPL is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CLGAPR */ +/* > \verbatim */ +/* > CLGAPR is REAL */ +/* > absolute gap on each end of the cluster. */ +/* > Set by the calling routine to protect against shifts too close */ +/* > to eigenvalues outside the cluster. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PIVMIN */ +/* > \verbatim */ +/* > PIVMIN is REAL */ +/* > The minimum pivot allowed in the Sturm sequence. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SIGMA */ +/* > \verbatim */ +/* > SIGMA is REAL */ +/* > The shift used to form L(+) D(+) L(+)^T. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DPLUS */ +/* > \verbatim */ +/* > DPLUS is REAL array, dimension (N) */ +/* > The N diagonal elements of the diagonal matrix D(+). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] LPLUS */ +/* > \verbatim */ +/* > LPLUS is REAL array, dimension (N-1) */ +/* > The first (N-1) elements of LPLUS contain the subdiagonal */ +/* > elements of the unit bidiagonal matrix L(+). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (2*N) */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > Signals processing OK (=0) or failure (=1) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Beresford Parlett, University of California, Berkeley, USA \n */ +/* > Jim Demmel, University of California, Berkeley, USA \n */ +/* > Inderjit Dhillon, University of Texas, Austin, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ +/* > Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ +/* Subroutine */ int slarrf_(integer *n, real *d__, real *l, real *ld, + integer *clstrt, integer *clend, real *w, real *wgap, real *werr, + real *spdiam, real *clgapl, real *clgapr, real *pivmin, real *sigma, + real *dplus, real *lplus, real *work, integer *info) +{ + /* System generated locals */ + integer i__1; + real r__1, r__2, r__3; + + /* Local variables */ + real growthbound, fail, fact, oldp; + integer indx; + real prod; + integer ktry; + real fail2; + integer i__; + real s, avgap, ldmax, rdmax; + integer shift; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + real bestshift, smlgrowth; + logical dorrr1; + real ldelta; + extern real slamch_(char *); + logical nofail; + real mingap, lsigma, rdelta; + logical forcer; + real rsigma, clwdth; + extern logical sisnan_(real *); + logical sawnan1, sawnan2; + real eps, tmp; + logical tryrrr1; + real max1, max2, rrr1, rrr2, znm2; + + +/* -- LAPACK auxiliary routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --work; + --lplus; + --dplus; + --werr; + --wgap; + --w; + --ld; + --l; + --d__; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n <= 0) { + return 0; + } + + fact = 2.f; + eps = slamch_("Precision"); + shift = 0; + forcer = FALSE_; +/* Note that we cannot guarantee that for any of the shifts tried, */ +/* the factorization has a small or even moderate element growth. */ +/* There could be Ritz values at both ends of the cluster and despite */ +/* backing off, there are examples where all factorizations tried */ +/* (in IEEE mode, allowing zero pivots & infinities) have INFINITE */ +/* element growth. */ +/* For this reason, we should use PIVMIN in this subroutine so that at */ +/* least the L D L^T factorization exists. It can be checked afterwards */ +/* whether the element growth caused bad residuals/orthogonality. */ +/* Decide whether the code should accept the best among all */ +/* representations despite large element growth or signal INFO=1 */ +/* Setting NOFAIL to .FALSE. for quick fix for bug 113 */ + nofail = FALSE_; + +/* Compute the average gap length of the cluster */ + clwdth = (r__1 = w[*clend] - w[*clstrt], abs(r__1)) + werr[*clend] + werr[ + *clstrt]; + avgap = clwdth / (real) (*clend - *clstrt); + mingap = f2cmin(*clgapl,*clgapr); +/* Initial values for shifts to both ends of cluster */ +/* Computing MIN */ + r__1 = w[*clstrt], r__2 = w[*clend]; + lsigma = f2cmin(r__1,r__2) - werr[*clstrt]; +/* Computing MAX */ + r__1 = w[*clstrt], r__2 = w[*clend]; + rsigma = f2cmax(r__1,r__2) + werr[*clend]; +/* Use a small fudge to make sure that we really shift to the outside */ + lsigma -= abs(lsigma) * 2.f * eps; + rsigma += abs(rsigma) * 2.f * eps; +/* Compute upper bounds for how much to back off the initial shifts */ + ldmax = mingap * .25f + *pivmin * 2.f; + rdmax = mingap * .25f + *pivmin * 2.f; +/* Computing MAX */ + r__1 = avgap, r__2 = wgap[*clstrt]; + ldelta = f2cmax(r__1,r__2) / fact; +/* Computing MAX */ + r__1 = avgap, r__2 = wgap[*clend - 1]; + rdelta = f2cmax(r__1,r__2) / fact; + +/* Initialize the record of the best representation found */ + + s = slamch_("S"); + smlgrowth = 1.f / s; + fail = (real) (*n - 1) * mingap / (*spdiam * eps); + fail2 = (real) (*n - 1) * mingap / (*spdiam * sqrt(eps)); + bestshift = lsigma; + +/* while (KTRY <= KTRYMAX) */ + ktry = 0; + growthbound = *spdiam * 8.f; +L5: + sawnan1 = FALSE_; + sawnan2 = FALSE_; +/* Ensure that we do not back off too much of the initial shifts */ + ldelta = f2cmin(ldmax,ldelta); + rdelta = f2cmin(rdmax,rdelta); +/* Compute the element growth when shifting to both ends of the cluster */ +/* accept the shift if there is no element growth at one of the two ends */ +/* Left end */ + s = -lsigma; + dplus[1] = d__[1] + s; + if (abs(dplus[1]) < *pivmin) { + dplus[1] = -(*pivmin); +/* Need to set SAWNAN1 because refined RRR test should not be used */ +/* in this case */ + sawnan1 = TRUE_; + } + max1 = abs(dplus[1]); + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + lplus[i__] = ld[i__] / dplus[i__]; + s = s * lplus[i__] * l[i__] - lsigma; + dplus[i__ + 1] = d__[i__ + 1] + s; + if ((r__1 = dplus[i__ + 1], abs(r__1)) < *pivmin) { + dplus[i__ + 1] = -(*pivmin); +/* Need to set SAWNAN1 because refined RRR test should not be used */ +/* in this case */ + sawnan1 = TRUE_; + } +/* Computing MAX */ + r__2 = max1, r__3 = (r__1 = dplus[i__ + 1], abs(r__1)); + max1 = f2cmax(r__2,r__3); +/* L6: */ + } + sawnan1 = sawnan1 || sisnan_(&max1); + if (forcer || max1 <= growthbound && ! sawnan1) { + *sigma = lsigma; + shift = 1; + goto L100; + } +/* Right end */ + s = -rsigma; + work[1] = d__[1] + s; + if (abs(work[1]) < *pivmin) { + work[1] = -(*pivmin); +/* Need to set SAWNAN2 because refined RRR test should not be used */ +/* in this case */ + sawnan2 = TRUE_; + } + max2 = abs(work[1]); + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + work[*n + i__] = ld[i__] / work[i__]; + s = s * work[*n + i__] * l[i__] - rsigma; + work[i__ + 1] = d__[i__ + 1] + s; + if ((r__1 = work[i__ + 1], abs(r__1)) < *pivmin) { + work[i__ + 1] = -(*pivmin); +/* Need to set SAWNAN2 because refined RRR test should not be used */ +/* in this case */ + sawnan2 = TRUE_; + } +/* Computing MAX */ + r__2 = max2, r__3 = (r__1 = work[i__ + 1], abs(r__1)); + max2 = f2cmax(r__2,r__3); +/* L7: */ + } + sawnan2 = sawnan2 || sisnan_(&max2); + if (forcer || max2 <= growthbound && ! sawnan2) { + *sigma = rsigma; + shift = 2; + goto L100; + } +/* If we are at this point, both shifts led to too much element growth */ +/* Record the better of the two shifts (provided it didn't lead to NaN) */ + if (sawnan1 && sawnan2) { +/* both MAX1 and MAX2 are NaN */ + goto L50; + } else { + if (! sawnan1) { + indx = 1; + if (max1 <= smlgrowth) { + smlgrowth = max1; + bestshift = lsigma; + } + } + if (! sawnan2) { + if (sawnan1 || max2 <= max1) { + indx = 2; + } + if (max2 <= smlgrowth) { + smlgrowth = max2; + bestshift = rsigma; + } + } + } +/* If we are here, both the left and the right shift led to */ +/* element growth. If the element growth is moderate, then */ +/* we may still accept the representation, if it passes a */ +/* refined test for RRR. This test supposes that no NaN occurred. */ +/* Moreover, we use the refined RRR test only for isolated clusters. */ + if (clwdth < mingap / 128.f && f2cmin(max1,max2) < fail2 && ! sawnan1 && ! + sawnan2) { + dorrr1 = TRUE_; + } else { + dorrr1 = FALSE_; + } + tryrrr1 = TRUE_; + if (tryrrr1 && dorrr1) { + if (indx == 1) { + tmp = (r__1 = dplus[*n], abs(r__1)); + znm2 = 1.f; + prod = 1.f; + oldp = 1.f; + for (i__ = *n - 1; i__ >= 1; --i__) { + if (prod <= eps) { + prod = dplus[i__ + 1] * work[*n + i__ + 1] / (dplus[i__] * + work[*n + i__]) * oldp; + } else { + prod *= (r__1 = work[*n + i__], abs(r__1)); + } + oldp = prod; +/* Computing 2nd power */ + r__1 = prod; + znm2 += r__1 * r__1; +/* Computing MAX */ + r__2 = tmp, r__3 = (r__1 = dplus[i__] * prod, abs(r__1)); + tmp = f2cmax(r__2,r__3); +/* L15: */ + } + rrr1 = tmp / (*spdiam * sqrt(znm2)); + if (rrr1 <= 8.f) { + *sigma = lsigma; + shift = 1; + goto L100; + } + } else if (indx == 2) { + tmp = (r__1 = work[*n], abs(r__1)); + znm2 = 1.f; + prod = 1.f; + oldp = 1.f; + for (i__ = *n - 1; i__ >= 1; --i__) { + if (prod <= eps) { + prod = work[i__ + 1] * lplus[i__ + 1] / (work[i__] * + lplus[i__]) * oldp; + } else { + prod *= (r__1 = lplus[i__], abs(r__1)); + } + oldp = prod; +/* Computing 2nd power */ + r__1 = prod; + znm2 += r__1 * r__1; +/* Computing MAX */ + r__2 = tmp, r__3 = (r__1 = work[i__] * prod, abs(r__1)); + tmp = f2cmax(r__2,r__3); +/* L16: */ + } + rrr2 = tmp / (*spdiam * sqrt(znm2)); + if (rrr2 <= 8.f) { + *sigma = rsigma; + shift = 2; + goto L100; + } + } + } +L50: + if (ktry < 1) { +/* If we are here, both shifts failed also the RRR test. */ +/* Back off to the outside */ +/* Computing MAX */ + r__1 = lsigma - ldelta, r__2 = lsigma - ldmax; + lsigma = f2cmax(r__1,r__2); +/* Computing MIN */ + r__1 = rsigma + rdelta, r__2 = rsigma + rdmax; + rsigma = f2cmin(r__1,r__2); + ldelta *= 2.f; + rdelta *= 2.f; + ++ktry; + goto L5; + } else { +/* None of the representations investigated satisfied our */ +/* criteria. Take the best one we found. */ + if (smlgrowth < fail || nofail) { + lsigma = bestshift; + rsigma = bestshift; + forcer = TRUE_; + goto L5; + } else { + *info = 1; + return 0; + } + } +L100: + if (shift == 1) { + } else if (shift == 2) { +/* store new L and D back into DPLUS, LPLUS */ + scopy_(n, &work[1], &c__1, &dplus[1], &c__1); + i__1 = *n - 1; + scopy_(&i__1, &work[*n + 1], &c__1, &lplus[1], &c__1); + } + return 0; + +/* End of SLARRF */ + +} /* slarrf_ */ + diff --git a/lapack-netlib/SRC/slarrj.c b/lapack-netlib/SRC/slarrj.c new file mode 100644 index 000000000..6bd66f8b2 --- /dev/null +++ b/lapack-netlib/SRC/slarrj.c @@ -0,0 +1,793 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#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 SLARRJ performs refinement of the initial estimates of the eigenvalues of the matrix T. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARRJ + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARRJ( N, D, E2, IFIRST, ILAST, */ +/* RTOL, OFFSET, W, WERR, WORK, IWORK, */ +/* PIVMIN, SPDIAM, INFO ) */ + +/* INTEGER IFIRST, ILAST, INFO, N, OFFSET */ +/* REAL PIVMIN, RTOL, SPDIAM */ +/* INTEGER IWORK( * ) */ +/* REAL D( * ), E2( * ), W( * ), */ +/* $ WERR( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Given the initial eigenvalue approximations of T, SLARRJ */ +/* > does bisection to refine the eigenvalues of T, */ +/* > W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial */ +/* > guesses for these eigenvalues are input in W, the corresponding estimate */ +/* > of the error in these guesses in WERR. During bisection, intervals */ +/* > [left, right] are maintained by storing their mid-points and */ +/* > semi-widths in the arrays W and WERR respectively. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The N diagonal elements of T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E2 */ +/* > \verbatim */ +/* > E2 is REAL array, dimension (N-1) */ +/* > The Squares of the (N-1) subdiagonal elements of T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IFIRST */ +/* > \verbatim */ +/* > IFIRST is INTEGER */ +/* > The index of the first eigenvalue to be computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILAST */ +/* > \verbatim */ +/* > ILAST is INTEGER */ +/* > The index of the last eigenvalue to be computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RTOL */ +/* > \verbatim */ +/* > RTOL is REAL */ +/* > Tolerance for the convergence of the bisection intervals. */ +/* > An interval [LEFT,RIGHT] has converged if */ +/* > RIGHT-LEFT < RTOL*MAX(|LEFT|,|RIGHT|). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] OFFSET */ +/* > \verbatim */ +/* > OFFSET is INTEGER */ +/* > Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET */ +/* > through ILAST-OFFSET elements of these arrays are to be used. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] W */ +/* > \verbatim */ +/* > W is REAL array, dimension (N) */ +/* > On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are */ +/* > estimates of the eigenvalues of L D L^T indexed IFIRST through */ +/* > ILAST. */ +/* > On output, these estimates are refined. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] WERR */ +/* > \verbatim */ +/* > WERR is REAL array, dimension (N) */ +/* > On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are */ +/* > the errors in the estimates of the corresponding elements in W. */ +/* > On output, these errors are refined. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (2*N) */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (2*N) */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PIVMIN */ +/* > \verbatim */ +/* > PIVMIN is REAL */ +/* > The minimum pivot in the Sturm sequence for T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SPDIAM */ +/* > \verbatim */ +/* > SPDIAM is REAL */ +/* > The spectral diameter of T. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > Error flag. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Beresford Parlett, University of California, Berkeley, USA \n */ +/* > Jim Demmel, University of California, Berkeley, USA \n */ +/* > Inderjit Dhillon, University of Texas, Austin, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ +/* > Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ +/* Subroutine */ int slarrj_(integer *n, real *d__, real *e2, integer *ifirst, + integer *ilast, real *rtol, integer *offset, real *w, real *werr, + real *work, integer *iwork, real *pivmin, real *spdiam, integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + real r__1, r__2; + + /* Local variables */ + real left; + integer iter, nint, prev, next, savi1, i__, j, k, p; + real s, right, width, dplus; + integer i1, i2, ii, olnint, maxitr; + real fac, mid; + integer cnt; + real tmp; + + +/* -- 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 */ + + +/* ===================================================================== */ + + + + /* Parameter adjustments */ + --iwork; + --work; + --werr; + --w; + --e2; + --d__; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n <= 0) { + return 0; + } + + maxitr = (integer) ((log(*spdiam + *pivmin) - log(*pivmin)) / log(2.f)) + + 2; + +/* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ]. */ +/* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while */ +/* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 ) */ +/* for an unconverged interval is set to the index of the next unconverged */ +/* interval, and is -1 or 0 for a converged interval. Thus a linked */ +/* list of unconverged intervals is set up. */ + + i1 = *ifirst; + i2 = *ilast; +/* The number of unconverged intervals */ + nint = 0; +/* The last unconverged interval found */ + prev = 0; + i__1 = i2; + for (i__ = i1; i__ <= i__1; ++i__) { + k = i__ << 1; + ii = i__ - *offset; + left = w[ii] - werr[ii]; + mid = w[ii]; + right = w[ii] + werr[ii]; + width = right - mid; +/* Computing MAX */ + r__1 = abs(left), r__2 = abs(right); + tmp = f2cmax(r__1,r__2); +/* The following test prevents the test of converged intervals */ + if (width < *rtol * tmp) { +/* This interval has already converged and does not need refinement. */ +/* (Note that the gaps might change through refining the */ +/* eigenvalues, however, they can only get bigger.) */ +/* Remove it from the list. */ + iwork[k - 1] = -1; +/* Make sure that I1 always points to the first unconverged interval */ + if (i__ == i1 && i__ < i2) { + i1 = i__ + 1; + } + if (prev >= i1 && i__ <= i2) { + iwork[(prev << 1) - 1] = i__ + 1; + } + } else { +/* unconverged interval found */ + prev = i__; +/* Make sure that [LEFT,RIGHT] contains the desired eigenvalue */ + +/* Do while( CNT(LEFT).GT.I-1 ) */ + + fac = 1.f; +L20: + cnt = 0; + s = left; + dplus = d__[1] - s; + if (dplus < 0.f) { + ++cnt; + } + i__2 = *n; + for (j = 2; j <= i__2; ++j) { + dplus = d__[j] - s - e2[j - 1] / dplus; + if (dplus < 0.f) { + ++cnt; + } +/* L30: */ + } + if (cnt > i__ - 1) { + left -= werr[ii] * fac; + fac *= 2.f; + goto L20; + } + +/* Do while( CNT(RIGHT).LT.I ) */ + + fac = 1.f; +L50: + cnt = 0; + s = right; + dplus = d__[1] - s; + if (dplus < 0.f) { + ++cnt; + } + i__2 = *n; + for (j = 2; j <= i__2; ++j) { + dplus = d__[j] - s - e2[j - 1] / dplus; + if (dplus < 0.f) { + ++cnt; + } +/* L60: */ + } + if (cnt < i__) { + right += werr[ii] * fac; + fac *= 2.f; + goto L50; + } + ++nint; + iwork[k - 1] = i__ + 1; + iwork[k] = cnt; + } + work[k - 1] = left; + work[k] = right; +/* L75: */ + } + savi1 = i1; + +/* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals */ +/* and while (ITER.LT.MAXITR) */ + + iter = 0; +L80: + prev = i1 - 1; + i__ = i1; + olnint = nint; + i__1 = olnint; + for (p = 1; p <= i__1; ++p) { + k = i__ << 1; + ii = i__ - *offset; + next = iwork[k - 1]; + left = work[k - 1]; + right = work[k]; + mid = (left + right) * .5f; +/* semiwidth of interval */ + width = right - mid; +/* Computing MAX */ + r__1 = abs(left), r__2 = abs(right); + tmp = f2cmax(r__1,r__2); + if (width < *rtol * tmp || iter == maxitr) { +/* reduce number of unconverged intervals */ + --nint; +/* Mark interval as converged. */ + iwork[k - 1] = 0; + if (i1 == i__) { + i1 = next; + } else { +/* Prev holds the last unconverged interval previously examined */ + if (prev >= i1) { + iwork[(prev << 1) - 1] = next; + } + } + i__ = next; + goto L100; + } + prev = i__; + +/* Perform one bisection step */ + + cnt = 0; + s = mid; + dplus = d__[1] - s; + if (dplus < 0.f) { + ++cnt; + } + i__2 = *n; + for (j = 2; j <= i__2; ++j) { + dplus = d__[j] - s - e2[j - 1] / dplus; + if (dplus < 0.f) { + ++cnt; + } +/* L90: */ + } + if (cnt <= i__ - 1) { + work[k - 1] = mid; + } else { + work[k] = mid; + } + i__ = next; +L100: + ; + } + ++iter; +/* do another loop if there are still unconverged intervals */ +/* However, in the last iteration, all intervals are accepted */ +/* since this is the best we can do. */ + if (nint > 0 && iter <= maxitr) { + goto L80; + } + + +/* At this point, all the intervals have converged */ + i__1 = *ilast; + for (i__ = savi1; i__ <= i__1; ++i__) { + k = i__ << 1; + ii = i__ - *offset; +/* All intervals marked by '0' have been refined. */ + if (iwork[k - 1] == 0) { + w[ii] = (work[k - 1] + work[k]) * .5f; + werr[ii] = work[k] - w[ii]; + } +/* L110: */ + } + + return 0; + +/* End of SLARRJ */ + +} /* slarrj_ */ + diff --git a/lapack-netlib/SRC/slarrk.c b/lapack-netlib/SRC/slarrk.c new file mode 100644 index 000000000..6c74dc5f7 --- /dev/null +++ b/lapack-netlib/SRC/slarrk.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 SLARRK computes one eigenvalue of a symmetric tridiagonal matrix T to suitable accuracy. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARRK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARRK( N, IW, GL, GU, */ +/* D, E2, PIVMIN, RELTOL, W, WERR, INFO) */ + +/* INTEGER INFO, IW, N */ +/* REAL PIVMIN, RELTOL, GL, GU, W, WERR */ +/* REAL D( * ), E2( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARRK computes one eigenvalue of a symmetric tridiagonal */ +/* > matrix T to suitable accuracy. This is an auxiliary code to be */ +/* > called from SSTEMR. */ +/* > */ +/* > To avoid overflow, the matrix must be scaled so that its */ +/* > largest element is no greater than overflow**(1/2) * underflow**(1/4) in absolute value, and for greatest + */ +/* > accuracy, it should not be much smaller than that. */ +/* > */ +/* > See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */ +/* > Matrix", Report CS41, Computer Science Dept., Stanford */ +/* > University, July 21, 1966. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the tridiagonal matrix T. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IW */ +/* > \verbatim */ +/* > IW is INTEGER */ +/* > The index of the eigenvalues to be returned. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GL */ +/* > \verbatim */ +/* > GL is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GU */ +/* > \verbatim */ +/* > GU is REAL */ +/* > An upper and a lower bound on the eigenvalue. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The n diagonal elements of the tridiagonal matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E2 */ +/* > \verbatim */ +/* > E2 is REAL array, dimension (N-1) */ +/* > The (n-1) squared off-diagonal elements of the tridiagonal matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PIVMIN */ +/* > \verbatim */ +/* > PIVMIN is REAL */ +/* > The minimum pivot allowed in the Sturm sequence for T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RELTOL */ +/* > \verbatim */ +/* > RELTOL is REAL */ +/* > The minimum relative width of an interval. When an interval */ +/* > is narrower than RELTOL times the larger (in */ +/* > magnitude) endpoint, then it is considered to be */ +/* > sufficiently small, i.e., converged. Note: this should */ +/* > always be at least radix*machine epsilon. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WERR */ +/* > \verbatim */ +/* > WERR is REAL */ +/* > The error bound on the corresponding eigenvalue approximation */ +/* > in W. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Eigenvalue converged */ +/* > = -1: Eigenvalue did NOT converge */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > FUDGE REAL , default = 2 */ +/* > A "fudge factor" to widen the Gershgorin intervals. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slarrk_(integer *n, integer *iw, real *gl, real *gu, + real *d__, real *e2, real *pivmin, real *reltol, real *w, real *werr, + integer *info) +{ + /* System generated locals */ + integer i__1; + real r__1, r__2; + + /* Local variables */ + real left; + integer i__; + real atoli, right; + integer itmax; + real rtoli, tnorm; + integer it; + extern real slamch_(char *); + integer negcnt; + real mid, eps, tmp1, tmp2; + + +/* -- LAPACK auxiliary routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + --e2; + --d__; + + /* Function Body */ + if (*n <= 0) { + *info = 0; + return 0; + } + +/* Get machine constants */ + eps = slamch_("P"); +/* Computing MAX */ + r__1 = abs(*gl), r__2 = abs(*gu); + tnorm = f2cmax(r__1,r__2); + rtoli = *reltol; + atoli = *pivmin * 4.f; + itmax = (integer) ((log(tnorm + *pivmin) - log(*pivmin)) / log(2.f)) + 2; + *info = -1; + left = *gl - tnorm * 2.f * eps * *n - *pivmin * 4.f; + right = *gu + tnorm * 2.f * eps * *n + *pivmin * 4.f; + it = 0; +L10: + +/* Check if interval converged or maximum number of iterations reached */ + + tmp1 = (r__1 = right - left, abs(r__1)); +/* Computing MAX */ + r__1 = abs(right), r__2 = abs(left); + tmp2 = f2cmax(r__1,r__2); +/* Computing MAX */ + r__1 = f2cmax(atoli,*pivmin), r__2 = rtoli * tmp2; + if (tmp1 < f2cmax(r__1,r__2)) { + *info = 0; + goto L30; + } + if (it > itmax) { + goto L30; + } + +/* Count number of negative pivots for mid-point */ + + ++it; + mid = (left + right) * .5f; + negcnt = 0; + tmp1 = d__[1] - mid; + if (abs(tmp1) < *pivmin) { + tmp1 = -(*pivmin); + } + if (tmp1 <= 0.f) { + ++negcnt; + } + + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + tmp1 = d__[i__] - e2[i__ - 1] / tmp1 - mid; + if (abs(tmp1) < *pivmin) { + tmp1 = -(*pivmin); + } + if (tmp1 <= 0.f) { + ++negcnt; + } +/* L20: */ + } + if (negcnt >= *iw) { + right = mid; + } else { + left = mid; + } + goto L10; +L30: + +/* Converged or maximum number of iterations reached */ + + *w = (left + right) * .5f; + *werr = (r__1 = right - left, abs(r__1)) * .5f; + return 0; + +/* End of SLARRK */ + +} /* slarrk_ */ + diff --git a/lapack-netlib/SRC/slarrr.c b/lapack-netlib/SRC/slarrr.c new file mode 100644 index 000000000..86779335f --- /dev/null +++ b/lapack-netlib/SRC/slarrr.c @@ -0,0 +1,600 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLARRR performs tests to decide whether the symmetric tridiagonal matrix T warrants expensive c +omputations which guarantee high relative accuracy in the eigenvalues. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARRR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARRR( N, D, E, INFO ) */ + +/* INTEGER N, INFO */ +/* REAL D( * ), E( * ) */ + + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Perform tests to decide whether the symmetric tridiagonal matrix T */ +/* > warrants expensive computations which guarantee high relative accuracy */ +/* > in the eigenvalues. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The N diagonal elements of the tridiagonal matrix T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (N) */ +/* > On entry, the first (N-1) entries contain the subdiagonal */ +/* > elements of the tridiagonal matrix T; E(N) is set to ZERO. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > INFO = 0(default) : the matrix warrants computations preserving */ +/* > relative accuracy. */ +/* > INFO = 1 : the matrix warrants computations guaranteeing */ +/* > only absolute accuracy. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Beresford Parlett, University of California, Berkeley, USA \n */ +/* > Jim Demmel, University of California, Berkeley, USA \n */ +/* > Inderjit Dhillon, University of Texas, Austin, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ +/* > Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ +/* Subroutine */ int slarrr_(integer *n, real *d__, real *e, integer *info) +{ + /* System generated locals */ + integer i__1; + real r__1; + + /* Local variables */ + real rmin; + integer i__; + real offdig; + extern real slamch_(char *); + real safmin; + logical yesrel; + real smlnum, offdig2, eps, tmp, tmp2; + + +/* -- LAPACK auxiliary routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + --e; + --d__; + + /* Function Body */ + if (*n <= 0) { + *info = 0; + return 0; + } + +/* As a default, do NOT go for relative-accuracy preserving computations. */ + *info = 1; + safmin = slamch_("Safe minimum"); + eps = slamch_("Precision"); + smlnum = safmin / eps; + rmin = sqrt(smlnum); +/* Tests for relative accuracy */ + +/* Test for scaled diagonal dominance */ +/* Scale the diagonal entries to one and check whether the sum of the */ +/* off-diagonals is less than one */ + +/* The sdd relative error bounds have a 1/(1- 2*x) factor in them, */ +/* x = f2cmax(OFFDIG + OFFDIG2), so when x is close to 1/2, no relative */ +/* accuracy is promised. In the notation of the code fragment below, */ +/* 1/(1 - (OFFDIG + OFFDIG2)) is the condition number. */ +/* We don't think it is worth going into "sdd mode" unless the relative */ +/* condition number is reasonable, not 1/macheps. */ +/* The threshold should be compatible with other thresholds used in the */ +/* code. We set OFFDIG + OFFDIG2 <= .999 =: RELCOND, it corresponds */ +/* to losing at most 3 decimal digits: 1 / (1 - (OFFDIG + OFFDIG2)) <= 1000 */ +/* instead of the current OFFDIG + OFFDIG2 < 1 */ + + yesrel = TRUE_; + offdig = 0.f; + tmp = sqrt((abs(d__[1]))); + if (tmp < rmin) { + yesrel = FALSE_; + } + if (! yesrel) { + goto L11; + } + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + tmp2 = sqrt((r__1 = d__[i__], abs(r__1))); + if (tmp2 < rmin) { + yesrel = FALSE_; + } + if (! yesrel) { + goto L11; + } + offdig2 = (r__1 = e[i__ - 1], abs(r__1)) / (tmp * tmp2); + if (offdig + offdig2 >= .999f) { + yesrel = FALSE_; + } + if (! yesrel) { + goto L11; + } + tmp = tmp2; + offdig = offdig2; +/* L10: */ + } +L11: + if (yesrel) { + *info = 0; + return 0; + } else { + } + + +/* *** MORE TO BE IMPLEMENTED *** */ + + +/* Test if the lower bidiagonal matrix L from T = L D L^T */ +/* (zero shift facto) is well conditioned */ + + +/* Test if the upper bidiagonal matrix U from T = U D U^T */ +/* (zero shift facto) is well conditioned. */ +/* In this case, the matrix needs to be flipped and, at the end */ +/* of the eigenvector computation, the flip needs to be applied */ +/* to the computed eigenvectors (and the support) */ + + + return 0; + +/* END OF SLARRR */ + +} /* slarrr_ */ + diff --git a/lapack-netlib/SRC/slarrv.c b/lapack-netlib/SRC/slarrv.c new file mode 100644 index 000000000..fff394e2a --- /dev/null +++ b/lapack-netlib/SRC/slarrv.c @@ -0,0 +1,1486 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLARRV computes the eigenvectors of the tridiagonal matrix T = L D LT given L, D and the eigenv +alues of L D LT. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARRV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARRV( N, VL, VU, D, L, PIVMIN, */ +/* ISPLIT, M, DOL, DOU, MINRGP, */ +/* RTOL1, RTOL2, W, WERR, WGAP, */ +/* IBLOCK, INDEXW, GERS, Z, LDZ, ISUPPZ, */ +/* WORK, IWORK, INFO ) */ + +/* INTEGER DOL, DOU, INFO, LDZ, M, N */ +/* REAL MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU */ +/* INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ), */ +/* $ ISUPPZ( * ), IWORK( * ) */ +/* REAL D( * ), GERS( * ), L( * ), W( * ), WERR( * ), */ +/* $ WGAP( * ), WORK( * ) */ +/* REAL Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARRV computes the eigenvectors of the tridiagonal matrix */ +/* > T = L D L**T given L, D and APPROXIMATIONS to the eigenvalues of L D L**T. */ +/* > The input eigenvalues should have been computed by SLARRE. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VL */ +/* > \verbatim */ +/* > VL is REAL */ +/* > Lower bound of the interval that contains the desired */ +/* > eigenvalues. VL < VU. Needed to compute gaps on the left or right */ +/* > end of the extremal eigenvalues in the desired RANGE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VU */ +/* > \verbatim */ +/* > VU is REAL */ +/* > Upper bound of the interval that contains the desired */ +/* > eigenvalues. VL < VU. */ +/* > Note: VU is currently not used by this implementation of SLARRV, VU is */ +/* > passed to SLARRV because it could be used compute gaps on the right end */ +/* > of the extremal eigenvalues. However, with not much initial accuracy in */ +/* > LAMBDA and VU, the formula can lead to an overestimation of the right gap */ +/* > and thus to inadequately early RQI 'convergence'. This is currently */ +/* > prevented this by forcing a small right gap. And so it turns out that VU */ +/* > is currently not used by this implementation of SLARRV. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry, the N diagonal elements of the diagonal matrix D. */ +/* > On exit, D may be overwritten. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] L */ +/* > \verbatim */ +/* > L is REAL array, dimension (N) */ +/* > On entry, the (N-1) subdiagonal elements of the unit */ +/* > bidiagonal matrix L are in elements 1 to N-1 of L */ +/* > (if the matrix is not split.) At the end of each block */ +/* > is stored the corresponding shift as given by SLARRE. */ +/* > On exit, L is overwritten. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PIVMIN */ +/* > \verbatim */ +/* > PIVMIN is REAL */ +/* > The minimum pivot allowed in the Sturm sequence. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ISPLIT */ +/* > \verbatim */ +/* > ISPLIT is INTEGER array, dimension (N) */ +/* > The splitting points, at which T breaks up into blocks. */ +/* > The first block consists of rows/columns 1 to */ +/* > ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */ +/* > through ISPLIT( 2 ), etc. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The total number of input eigenvalues. 0 <= M <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DOL */ +/* > \verbatim */ +/* > DOL is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DOU */ +/* > \verbatim */ +/* > DOU is INTEGER */ +/* > If the user wants to compute only selected eigenvectors from all */ +/* > the eigenvalues supplied, he can specify an index range DOL:DOU. */ +/* > Or else the setting DOL=1, DOU=M should be applied. */ +/* > Note that DOL and DOU refer to the order in which the eigenvalues */ +/* > are stored in W. */ +/* > If the user wants to compute only selected eigenpairs, then */ +/* > the columns DOL-1 to DOU+1 of the eigenvector space Z contain the */ +/* > computed eigenvectors. All other columns of Z are set to zero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MINRGP */ +/* > \verbatim */ +/* > MINRGP is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RTOL1 */ +/* > \verbatim */ +/* > RTOL1 is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RTOL2 */ +/* > \verbatim */ +/* > RTOL2 is REAL */ +/* > Parameters for bisection. */ +/* > An interval [LEFT,RIGHT] has converged if */ +/* > RIGHT-LEFT < MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] W */ +/* > \verbatim */ +/* > W is REAL array, dimension (N) */ +/* > The first M elements of W contain the APPROXIMATE eigenvalues for */ +/* > which eigenvectors are to be computed. The eigenvalues */ +/* > should be grouped by split-off block and ordered from */ +/* > smallest to largest within the block ( The output array */ +/* > W from SLARRE is expected here ). Furthermore, they are with */ +/* > respect to the shift of the corresponding root representation */ +/* > for their block. On exit, W holds the eigenvalues of the */ +/* > UNshifted matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] WERR */ +/* > \verbatim */ +/* > WERR is REAL array, dimension (N) */ +/* > The first M elements contain the semiwidth of the uncertainty */ +/* > interval of the corresponding eigenvalue in W */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] WGAP */ +/* > \verbatim */ +/* > WGAP is REAL array, dimension (N) */ +/* > The separation from the right neighbor eigenvalue in W. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IBLOCK */ +/* > \verbatim */ +/* > IBLOCK is INTEGER array, dimension (N) */ +/* > The indices of the blocks (submatrices) associated with the */ +/* > corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue */ +/* > W(i) belongs to the first block from the top, =2 if W(i) */ +/* > belongs to the second block, etc. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INDEXW */ +/* > \verbatim */ +/* > INDEXW is INTEGER array, dimension (N) */ +/* > The indices of the eigenvalues within each block (submatrix); */ +/* > for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the */ +/* > i-th eigenvalue W(i) is the 10-th eigenvalue in the second block. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] GERS */ +/* > \verbatim */ +/* > GERS is REAL array, dimension (2*N) */ +/* > The N Gerschgorin intervals (the i-th Gerschgorin interval */ +/* > is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should */ +/* > be computed from the original UNshifted matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension (LDZ, f2cmax(1,M) ) */ +/* > If INFO = 0, the first M columns of Z contain the */ +/* > orthonormal eigenvectors of the matrix T */ +/* > corresponding to the input eigenvalues, with the i-th */ +/* > column of Z holding the eigenvector associated with W(i). */ +/* > Note: the user must ensure that at least f2cmax(1,M) columns are */ +/* > supplied in the array Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1, and if */ +/* > JOBZ = 'V', LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ISUPPZ */ +/* > \verbatim */ +/* > ISUPPZ is INTEGER array, dimension ( 2*f2cmax(1,M) ) */ +/* > The support of the eigenvectors in Z, i.e., the indices */ +/* > indicating the nonzero elements in Z. The I-th eigenvector */ +/* > is nonzero only in elements ISUPPZ( 2*I-1 ) through */ +/* > ISUPPZ( 2*I ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (12*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (7*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > */ +/* > > 0: A problem occurred in SLARRV. */ +/* > < 0: One of the called subroutines signaled an internal problem. */ +/* > Needs inspection of the corresponding parameter IINFO */ +/* > for further information. */ +/* > */ +/* > =-1: Problem in SLARRB when refining a child's eigenvalues. */ +/* > =-2: Problem in SLARRF when computing the RRR of a child. */ +/* > When a child is inside a tight cluster, it can be difficult */ +/* > to find an RRR. A partial remedy from the user's point of */ +/* > view is to make the parameter MINRGP smaller and recompile. */ +/* > However, as the orthogonality of the computed vectors is */ +/* > proportional to 1/MINRGP, the user should be aware that */ +/* > he might be trading in precision when he decreases MINRGP. */ +/* > =-3: Problem in SLARRB when refining a single eigenvalue */ +/* > after the Rayleigh correction was rejected. */ +/* > = 5: The Rayleigh Quotient Iteration failed to converge to */ +/* > full accuracy in MAXITR steps. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Beresford Parlett, University of California, Berkeley, USA \n */ +/* > Jim Demmel, University of California, Berkeley, USA \n */ +/* > Inderjit Dhillon, University of Texas, Austin, USA \n */ +/* > Osni Marques, LBNL/NERSC, USA \n */ +/* > Christof Voemel, University of California, Berkeley, USA */ + +/* ===================================================================== */ +/* Subroutine */ int slarrv_(integer *n, real *vl, real *vu, real *d__, real * + l, real *pivmin, integer *isplit, integer *m, integer *dol, integer * + dou, real *minrgp, real *rtol1, real *rtol2, real *w, real *werr, + real *wgap, integer *iblock, integer *indexw, real *gers, real *z__, + integer *ldz, integer *isuppz, real *work, integer *iwork, integer * + info) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2; + logical L__1; + + /* Local variables */ + integer iend, jblk; + real lgap; + integer done; + real rgap, left; + integer wend, iter; + real bstw; + integer minwsize, itmp1, i__, j, k, p, q, indld; + real fudge; + integer idone; + real sigma; + integer iinfo, iindr; + real resid; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + logical eskip; + real right; + integer nclus, zfrom; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + real rqtol; + integer iindc1, iindc2, miniwsize; + extern /* Subroutine */ int slar1v_(integer *, integer *, integer *, real + *, real *, real *, real *, real *, real *, real *, real *, + logical *, integer *, real *, real *, integer *, integer *, real * + , real *, real *, real *); + logical stp2ii; + real lambda; + integer ii; + real gl; + integer im, in; + real gu; + integer ibegin, indeig; + logical needbs; + integer indlld; + real sgndef, mingma; + extern real slamch_(char *); + integer oldien, oldncl, wbegin, negcnt; + real spdiam; + integer oldcls; + real savgap; + integer ndepth; + real ssigma; + logical usedbs; + integer iindwk, offset; + real gaptol; + extern /* Subroutine */ int slarrb_(integer *, real *, real *, integer *, + integer *, real *, real *, integer *, real *, real *, real *, + real *, integer *, real *, real *, integer *, integer *), slarrf_( + integer *, real *, real *, real *, integer *, integer *, real *, + real *, real *, real *, real *, real *, real *, real *, real *, + real *, real *, integer *); + integer newcls, oldfst, indwrk, windex, oldlst; + logical usedrq; + integer newfst, newftt, parity, windmn, isupmn, newlst, windpl, zusedl, + newsiz, zusedu, zusedw; + real bstres, nrminv; + logical tryrqc; + integer isupmx; + real rqcorr; + extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *, + real *, real *, integer *); + real gap, eps, tau, tol, tmp; + integer zto; + real ztz; + + +/* -- LAPACK auxiliary routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + /* Parameter adjustments */ + --d__; + --l; + --isplit; + --w; + --werr; + --wgap; + --iblock; + --indexw; + --gers; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --isuppz; + --work; + --iwork; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n <= 0 || *m <= 0) { + return 0; + } + +/* The first N entries of WORK are reserved for the eigenvalues */ + indld = *n + 1; + indlld = (*n << 1) + 1; + indwrk = *n * 3 + 1; + minwsize = *n * 12; + i__1 = minwsize; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.f; +/* L5: */ + } +/* IWORK(IINDR+1:IINDR+N) hold the twist indices R for the */ +/* factorization used to compute the FP vector */ + iindr = 0; +/* IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current */ +/* layer and the one above. */ + iindc1 = *n; + iindc2 = *n << 1; + iindwk = *n * 3 + 1; + miniwsize = *n * 7; + i__1 = miniwsize; + for (i__ = 1; i__ <= i__1; ++i__) { + iwork[i__] = 0; +/* L10: */ + } + zusedl = 1; + if (*dol > 1) { +/* Set lower bound for use of Z */ + zusedl = *dol - 1; + } + zusedu = *m; + if (*dou < *m) { +/* Set lower bound for use of Z */ + zusedu = *dou + 1; + } +/* The width of the part of Z that is used */ + zusedw = zusedu - zusedl + 1; + slaset_("Full", n, &zusedw, &c_b5, &c_b5, &z__[zusedl * z_dim1 + 1], ldz); + eps = slamch_("Precision"); + rqtol = eps * 2.f; + +/* Set expert flags for standard code. */ + tryrqc = TRUE_; + if (*dol == 1 && *dou == *m) { + } else { +/* Only selected eigenpairs are computed. Since the other evalues */ +/* are not refined by RQ iteration, bisection has to compute to full */ +/* accuracy. */ + *rtol1 = eps * 4.f; + *rtol2 = eps * 4.f; + } +/* The entries WBEGIN:WEND in W, WERR, WGAP correspond to the */ +/* desired eigenvalues. The support of the nonzero eigenvector */ +/* entries is contained in the interval IBEGIN:IEND. */ +/* Remark that if k eigenpairs are desired, then the eigenvectors */ +/* are stored in k contiguous columns of Z. */ +/* DONE is the number of eigenvectors already computed */ + done = 0; + ibegin = 1; + wbegin = 1; + i__1 = iblock[*m]; + for (jblk = 1; jblk <= i__1; ++jblk) { + iend = isplit[jblk]; + sigma = l[iend]; +/* Find the eigenvectors of the submatrix indexed IBEGIN */ +/* through IEND. */ + wend = wbegin - 1; +L15: + if (wend < *m) { + if (iblock[wend + 1] == jblk) { + ++wend; + goto L15; + } + } + if (wend < wbegin) { + ibegin = iend + 1; + goto L170; + } else if (wend < *dol || wbegin > *dou) { + ibegin = iend + 1; + wbegin = wend + 1; + goto L170; + } +/* Find local spectral diameter of the block */ + gl = gers[(ibegin << 1) - 1]; + gu = gers[ibegin * 2]; + i__2 = iend; + for (i__ = ibegin + 1; i__ <= i__2; ++i__) { +/* Computing MIN */ + r__1 = gers[(i__ << 1) - 1]; + gl = f2cmin(r__1,gl); +/* Computing MAX */ + r__1 = gers[i__ * 2]; + gu = f2cmax(r__1,gu); +/* L20: */ + } + spdiam = gu - gl; +/* OLDIEN is the last index of the previous block */ + oldien = ibegin - 1; +/* Calculate the size of the current block */ + in = iend - ibegin + 1; +/* The number of eigenvalues in the current block */ + im = wend - wbegin + 1; +/* This is for a 1x1 block */ + if (ibegin == iend) { + ++done; + z__[ibegin + wbegin * z_dim1] = 1.f; + isuppz[(wbegin << 1) - 1] = ibegin; + isuppz[wbegin * 2] = ibegin; + w[wbegin] += sigma; + work[wbegin] = w[wbegin]; + ibegin = iend + 1; + ++wbegin; + goto L170; + } +/* The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND) */ +/* Note that these can be approximations, in this case, the corresp. */ +/* entries of WERR give the size of the uncertainty interval. */ +/* The eigenvalue approximations will be refined when necessary as */ +/* high relative accuracy is required for the computation of the */ +/* corresponding eigenvectors. */ + scopy_(&im, &w[wbegin], &c__1, &work[wbegin], &c__1); +/* We store in W the eigenvalue approximations w.r.t. the original */ +/* matrix T. */ + i__2 = im; + for (i__ = 1; i__ <= i__2; ++i__) { + w[wbegin + i__ - 1] += sigma; +/* L30: */ + } +/* NDEPTH is the current depth of the representation tree */ + ndepth = 0; +/* PARITY is either 1 or 0 */ + parity = 1; +/* NCLUS is the number of clusters for the next level of the */ +/* representation tree, we start with NCLUS = 1 for the root */ + nclus = 1; + iwork[iindc1 + 1] = 1; + iwork[iindc1 + 2] = im; +/* IDONE is the number of eigenvectors already computed in the current */ +/* block */ + idone = 0; +/* loop while( IDONE.LT.IM ) */ +/* generate the representation tree for the current block and */ +/* compute the eigenvectors */ +L40: + if (idone < im) { +/* This is a crude protection against infinitely deep trees */ + if (ndepth > *m) { + *info = -2; + return 0; + } +/* breadth first processing of the current level of the representation */ +/* tree: OLDNCL = number of clusters on current level */ + oldncl = nclus; +/* reset NCLUS to count the number of child clusters */ + nclus = 0; + + parity = 1 - parity; + if (parity == 0) { + oldcls = iindc1; + newcls = iindc2; + } else { + oldcls = iindc2; + newcls = iindc1; + } +/* Process the clusters on the current level */ + i__2 = oldncl; + for (i__ = 1; i__ <= i__2; ++i__) { + j = oldcls + (i__ << 1); +/* OLDFST, OLDLST = first, last index of current cluster. */ +/* cluster indices start with 1 and are relative */ +/* to WBEGIN when accessing W, WGAP, WERR, Z */ + oldfst = iwork[j - 1]; + oldlst = iwork[j]; + if (ndepth > 0) { +/* Retrieve relatively robust representation (RRR) of cluster */ +/* that has been computed at the previous level */ +/* The RRR is stored in Z and overwritten once the eigenvectors */ +/* have been computed or when the cluster is refined */ + if (*dol == 1 && *dou == *m) { +/* Get representation from location of the leftmost evalue */ +/* of the cluster */ + j = wbegin + oldfst - 1; + } else { + if (wbegin + oldfst - 1 < *dol) { +/* Get representation from the left end of Z array */ + j = *dol - 1; + } else if (wbegin + oldfst - 1 > *dou) { +/* Get representation from the right end of Z array */ + j = *dou; + } else { + j = wbegin + oldfst - 1; + } + } + scopy_(&in, &z__[ibegin + j * z_dim1], &c__1, &d__[ibegin] + , &c__1); + i__3 = in - 1; + scopy_(&i__3, &z__[ibegin + (j + 1) * z_dim1], &c__1, &l[ + ibegin], &c__1); + sigma = z__[iend + (j + 1) * z_dim1]; +/* Set the corresponding entries in Z to zero */ + slaset_("Full", &in, &c__2, &c_b5, &c_b5, &z__[ibegin + j + * z_dim1], ldz); + } +/* Compute DL and DLL of current RRR */ + i__3 = iend - 1; + for (j = ibegin; j <= i__3; ++j) { + tmp = d__[j] * l[j]; + work[indld - 1 + j] = tmp; + work[indlld - 1 + j] = tmp * l[j]; +/* L50: */ + } + if (ndepth > 0) { +/* P and Q are index of the first and last eigenvalue to compute */ +/* within the current block */ + p = indexw[wbegin - 1 + oldfst]; + q = indexw[wbegin - 1 + oldlst]; +/* Offset for the arrays WORK, WGAP and WERR, i.e., the P-OFFSET */ +/* through the Q-OFFSET elements of these arrays are to be used. */ +/* OFFSET = P-OLDFST */ + offset = indexw[wbegin] - 1; +/* perform limited bisection (if necessary) to get approximate */ +/* eigenvalues to the precision needed. */ + slarrb_(&in, &d__[ibegin], &work[indlld + ibegin - 1], &p, + &q, rtol1, rtol2, &offset, &work[wbegin], &wgap[ + wbegin], &werr[wbegin], &work[indwrk], &iwork[ + iindwk], pivmin, &spdiam, &in, &iinfo); + if (iinfo != 0) { + *info = -1; + return 0; + } +/* We also recompute the extremal gaps. W holds all eigenvalues */ +/* of the unshifted matrix and must be used for computation */ +/* of WGAP, the entries of WORK might stem from RRRs with */ +/* different shifts. The gaps from WBEGIN-1+OLDFST to */ +/* WBEGIN-1+OLDLST are correctly computed in SLARRB. */ +/* However, we only allow the gaps to become greater since */ +/* this is what should happen when we decrease WERR */ + if (oldfst > 1) { +/* Computing MAX */ + r__1 = wgap[wbegin + oldfst - 2], r__2 = w[wbegin + + oldfst - 1] - werr[wbegin + oldfst - 1] - w[ + wbegin + oldfst - 2] - werr[wbegin + oldfst - + 2]; + wgap[wbegin + oldfst - 2] = f2cmax(r__1,r__2); + } + if (wbegin + oldlst - 1 < wend) { +/* Computing MAX */ + r__1 = wgap[wbegin + oldlst - 1], r__2 = w[wbegin + + oldlst] - werr[wbegin + oldlst] - w[wbegin + + oldlst - 1] - werr[wbegin + oldlst - 1]; + wgap[wbegin + oldlst - 1] = f2cmax(r__1,r__2); + } +/* Each time the eigenvalues in WORK get refined, we store */ +/* the newly found approximation with all shifts applied in W */ + i__3 = oldlst; + for (j = oldfst; j <= i__3; ++j) { + w[wbegin + j - 1] = work[wbegin + j - 1] + sigma; +/* L53: */ + } + } +/* Process the current node. */ + newfst = oldfst; + i__3 = oldlst; + for (j = oldfst; j <= i__3; ++j) { + if (j == oldlst) { +/* we are at the right end of the cluster, this is also the */ +/* boundary of the child cluster */ + newlst = j; + } else if (wgap[wbegin + j - 1] >= *minrgp * (r__1 = work[ + wbegin + j - 1], abs(r__1))) { +/* the right relative gap is big enough, the child cluster */ +/* (NEWFST,..,NEWLST) is well separated from the following */ + newlst = j; + } else { +/* inside a child cluster, the relative gap is not */ +/* big enough. */ + goto L140; + } +/* Compute size of child cluster found */ + newsiz = newlst - newfst + 1; +/* NEWFTT is the place in Z where the new RRR or the computed */ +/* eigenvector is to be stored */ + if (*dol == 1 && *dou == *m) { +/* Store representation at location of the leftmost evalue */ +/* of the cluster */ + newftt = wbegin + newfst - 1; + } else { + if (wbegin + newfst - 1 < *dol) { +/* Store representation at the left end of Z array */ + newftt = *dol - 1; + } else if (wbegin + newfst - 1 > *dou) { +/* Store representation at the right end of Z array */ + newftt = *dou; + } else { + newftt = wbegin + newfst - 1; + } + } + if (newsiz > 1) { + +/* Current child is not a singleton but a cluster. */ +/* Compute and store new representation of child. */ + + +/* Compute left and right cluster gap. */ + +/* LGAP and RGAP are not computed from WORK because */ +/* the eigenvalue approximations may stem from RRRs */ +/* different shifts. However, W hold all eigenvalues */ +/* of the unshifted matrix. Still, the entries in WGAP */ +/* have to be computed from WORK since the entries */ +/* in W might be of the same order so that gaps are not */ +/* exhibited correctly for very close eigenvalues. */ + if (newfst == 1) { +/* Computing MAX */ + r__1 = 0.f, r__2 = w[wbegin] - werr[wbegin] - *vl; + lgap = f2cmax(r__1,r__2); + } else { + lgap = wgap[wbegin + newfst - 2]; + } + rgap = wgap[wbegin + newlst - 1]; + +/* Compute left- and rightmost eigenvalue of child */ +/* to high precision in order to shift as close */ +/* as possible and obtain as large relative gaps */ +/* as possible */ + + for (k = 1; k <= 2; ++k) { + if (k == 1) { + p = indexw[wbegin - 1 + newfst]; + } else { + p = indexw[wbegin - 1 + newlst]; + } + offset = indexw[wbegin] - 1; + slarrb_(&in, &d__[ibegin], &work[indlld + ibegin + - 1], &p, &p, &rqtol, &rqtol, &offset, & + work[wbegin], &wgap[wbegin], &werr[wbegin] + , &work[indwrk], &iwork[iindwk], pivmin, & + spdiam, &in, &iinfo); +/* L55: */ + } + + if (wbegin + newlst - 1 < *dol || wbegin + newfst - 1 + > *dou) { +/* if the cluster contains no desired eigenvalues */ +/* skip the computation of that branch of the rep. tree */ + +/* We could skip before the refinement of the extremal */ +/* eigenvalues of the child, but then the representation */ +/* tree could be different from the one when nothing is */ +/* skipped. For this reason we skip at this place. */ + idone = idone + newlst - newfst + 1; + goto L139; + } + +/* Compute RRR of child cluster. */ +/* Note that the new RRR is stored in Z */ + +/* SLARRF needs LWORK = 2*N */ + slarrf_(&in, &d__[ibegin], &l[ibegin], &work[indld + + ibegin - 1], &newfst, &newlst, &work[wbegin], + &wgap[wbegin], &werr[wbegin], &spdiam, &lgap, + &rgap, pivmin, &tau, &z__[ibegin + newftt * + z_dim1], &z__[ibegin + (newftt + 1) * z_dim1], + &work[indwrk], &iinfo); + if (iinfo == 0) { +/* a new RRR for the cluster was found by SLARRF */ +/* update shift and store it */ + ssigma = sigma + tau; + z__[iend + (newftt + 1) * z_dim1] = ssigma; +/* WORK() are the midpoints and WERR() the semi-width */ +/* Note that the entries in W are unchanged. */ + i__4 = newlst; + for (k = newfst; k <= i__4; ++k) { + fudge = eps * 3.f * (r__1 = work[wbegin + k - + 1], abs(r__1)); + work[wbegin + k - 1] -= tau; + fudge += eps * 4.f * (r__1 = work[wbegin + k + - 1], abs(r__1)); +/* Fudge errors */ + werr[wbegin + k - 1] += fudge; +/* Gaps are not fudged. Provided that WERR is small */ +/* when eigenvalues are close, a zero gap indicates */ +/* that a new representation is needed for resolving */ +/* the cluster. A fudge could lead to a wrong decision */ +/* of judging eigenvalues 'separated' which in */ +/* reality are not. This could have a negative impact */ +/* on the orthogonality of the computed eigenvectors. */ +/* L116: */ + } + ++nclus; + k = newcls + (nclus << 1); + iwork[k - 1] = newfst; + iwork[k] = newlst; + } else { + *info = -2; + return 0; + } + } else { + +/* Compute eigenvector of singleton */ + + iter = 0; + + tol = log((real) in) * 4.f * eps; + + k = newfst; + windex = wbegin + k - 1; +/* Computing MAX */ + i__4 = windex - 1; + windmn = f2cmax(i__4,1); +/* Computing MIN */ + i__4 = windex + 1; + windpl = f2cmin(i__4,*m); + lambda = work[windex]; + ++done; +/* Check if eigenvector computation is to be skipped */ + if (windex < *dol || windex > *dou) { + eskip = TRUE_; + goto L125; + } else { + eskip = FALSE_; + } + left = work[windex] - werr[windex]; + right = work[windex] + werr[windex]; + indeig = indexw[windex]; +/* Note that since we compute the eigenpairs for a child, */ +/* all eigenvalue approximations are w.r.t the same shift. */ +/* In this case, the entries in WORK should be used for */ +/* computing the gaps since they exhibit even very small */ +/* differences in the eigenvalues, as opposed to the */ +/* entries in W which might "look" the same. */ + if (k == 1) { +/* In the case RANGE='I' and with not much initial */ +/* accuracy in LAMBDA and VL, the formula */ +/* LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA ) */ +/* can lead to an overestimation of the left gap and */ +/* thus to inadequately early RQI 'convergence'. */ +/* Prevent this by forcing a small left gap. */ +/* Computing MAX */ + r__1 = abs(left), r__2 = abs(right); + lgap = eps * f2cmax(r__1,r__2); + } else { + lgap = wgap[windmn]; + } + if (k == im) { +/* In the case RANGE='I' and with not much initial */ +/* accuracy in LAMBDA and VU, the formula */ +/* can lead to an overestimation of the right gap and */ +/* thus to inadequately early RQI 'convergence'. */ +/* Prevent this by forcing a small right gap. */ +/* Computing MAX */ + r__1 = abs(left), r__2 = abs(right); + rgap = eps * f2cmax(r__1,r__2); + } else { + rgap = wgap[windex]; + } + gap = f2cmin(lgap,rgap); + if (k == 1 || k == im) { +/* The eigenvector support can become wrong */ +/* because significant entries could be cut off due to a */ +/* large GAPTOL parameter in LAR1V. Prevent this. */ + gaptol = 0.f; + } else { + gaptol = gap * eps; + } + isupmn = in; + isupmx = 1; +/* Update WGAP so that it holds the minimum gap */ +/* to the left or the right. This is crucial in the */ +/* case where bisection is used to ensure that the */ +/* eigenvalue is refined up to the required precision. */ +/* The correct value is restored afterwards. */ + savgap = wgap[windex]; + wgap[windex] = gap; +/* We want to use the Rayleigh Quotient Correction */ +/* as often as possible since it converges quadratically */ +/* when we are close enough to the desired eigenvalue. */ +/* However, the Rayleigh Quotient can have the wrong sign */ +/* and lead us away from the desired eigenvalue. In this */ +/* case, the best we can do is to use bisection. */ + usedbs = FALSE_; + usedrq = FALSE_; +/* Bisection is initially turned off unless it is forced */ + needbs = ! tryrqc; +L120: +/* Check if bisection should be used to refine eigenvalue */ + if (needbs) { +/* Take the bisection as new iterate */ + usedbs = TRUE_; + itmp1 = iwork[iindr + windex]; + offset = indexw[wbegin] - 1; + r__1 = eps * 2.f; + slarrb_(&in, &d__[ibegin], &work[indlld + ibegin + - 1], &indeig, &indeig, &c_b5, &r__1, & + offset, &work[wbegin], &wgap[wbegin], & + werr[wbegin], &work[indwrk], &iwork[ + iindwk], pivmin, &spdiam, &itmp1, &iinfo); + if (iinfo != 0) { + *info = -3; + return 0; + } + lambda = work[windex]; +/* Reset twist index from inaccurate LAMBDA to */ +/* force computation of true MINGMA */ + iwork[iindr + windex] = 0; + } +/* Given LAMBDA, compute the eigenvector. */ + L__1 = ! usedbs; + slar1v_(&in, &c__1, &in, &lambda, &d__[ibegin], &l[ + ibegin], &work[indld + ibegin - 1], &work[ + indlld + ibegin - 1], pivmin, &gaptol, &z__[ + ibegin + windex * z_dim1], &L__1, &negcnt, & + ztz, &mingma, &iwork[iindr + windex], &isuppz[ + (windex << 1) - 1], &nrminv, &resid, &rqcorr, + &work[indwrk]); + if (iter == 0) { + bstres = resid; + bstw = lambda; + } else if (resid < bstres) { + bstres = resid; + bstw = lambda; + } +/* Computing MIN */ + i__4 = isupmn, i__5 = isuppz[(windex << 1) - 1]; + isupmn = f2cmin(i__4,i__5); +/* Computing MAX */ + i__4 = isupmx, i__5 = isuppz[windex * 2]; + isupmx = f2cmax(i__4,i__5); + ++iter; +/* sin alpha <= |resid|/gap */ +/* Note that both the residual and the gap are */ +/* proportional to the matrix, so ||T|| doesn't play */ +/* a role in the quotient */ + +/* Convergence test for Rayleigh-Quotient iteration */ +/* (omitted when Bisection has been used) */ + + if (resid > tol * gap && abs(rqcorr) > rqtol * abs( + lambda) && ! usedbs) { +/* We need to check that the RQCORR update doesn't */ +/* move the eigenvalue away from the desired one and */ +/* towards a neighbor. -> protection with bisection */ + if (indeig <= negcnt) { +/* The wanted eigenvalue lies to the left */ + sgndef = -1.f; + } else { +/* The wanted eigenvalue lies to the right */ + sgndef = 1.f; + } +/* We only use the RQCORR if it improves the */ +/* the iterate reasonably. */ + if (rqcorr * sgndef >= 0.f && lambda + rqcorr <= + right && lambda + rqcorr >= left) { + usedrq = TRUE_; +/* Store new midpoint of bisection interval in WORK */ + if (sgndef == 1.f) { +/* The current LAMBDA is on the left of the true */ +/* eigenvalue */ + left = lambda; +/* We prefer to assume that the error estimate */ +/* is correct. We could make the interval not */ +/* as a bracket but to be modified if the RQCORR */ +/* chooses to. In this case, the RIGHT side should */ +/* be modified as follows: */ +/* RIGHT = MAX(RIGHT, LAMBDA + RQCORR) */ + } else { +/* The current LAMBDA is on the right of the true */ +/* eigenvalue */ + right = lambda; +/* See comment about assuming the error estimate is */ +/* correct above. */ +/* LEFT = MIN(LEFT, LAMBDA + RQCORR) */ + } + work[windex] = (right + left) * .5f; +/* Take RQCORR since it has the correct sign and */ +/* improves the iterate reasonably */ + lambda += rqcorr; +/* Update width of error interval */ + werr[windex] = (right - left) * .5f; + } else { + needbs = TRUE_; + } + if (right - left < rqtol * abs(lambda)) { +/* The eigenvalue is computed to bisection accuracy */ +/* compute eigenvector and stop */ + usedbs = TRUE_; + goto L120; + } else if (iter < 10) { + goto L120; + } else if (iter == 10) { + needbs = TRUE_; + goto L120; + } else { + *info = 5; + return 0; + } + } else { + stp2ii = FALSE_; + if (usedrq && usedbs && bstres <= resid) { + lambda = bstw; + stp2ii = TRUE_; + } + if (stp2ii) { +/* improve error angle by second step */ + L__1 = ! usedbs; + slar1v_(&in, &c__1, &in, &lambda, &d__[ibegin] + , &l[ibegin], &work[indld + ibegin - + 1], &work[indlld + ibegin - 1], + pivmin, &gaptol, &z__[ibegin + windex + * z_dim1], &L__1, &negcnt, &ztz, & + mingma, &iwork[iindr + windex], & + isuppz[(windex << 1) - 1], &nrminv, & + resid, &rqcorr, &work[indwrk]); + } + work[windex] = lambda; + } + +/* Compute FP-vector support w.r.t. whole matrix */ + + isuppz[(windex << 1) - 1] += oldien; + isuppz[windex * 2] += oldien; + zfrom = isuppz[(windex << 1) - 1]; + zto = isuppz[windex * 2]; + isupmn += oldien; + isupmx += oldien; +/* Ensure vector is ok if support in the RQI has changed */ + if (isupmn < zfrom) { + i__4 = zfrom - 1; + for (ii = isupmn; ii <= i__4; ++ii) { + z__[ii + windex * z_dim1] = 0.f; +/* L122: */ + } + } + if (isupmx > zto) { + i__4 = isupmx; + for (ii = zto + 1; ii <= i__4; ++ii) { + z__[ii + windex * z_dim1] = 0.f; +/* L123: */ + } + } + i__4 = zto - zfrom + 1; + sscal_(&i__4, &nrminv, &z__[zfrom + windex * z_dim1], + &c__1); +L125: +/* Update W */ + w[windex] = lambda + sigma; +/* Recompute the gaps on the left and right */ +/* But only allow them to become larger and not */ +/* smaller (which can only happen through "bad" */ +/* cancellation and doesn't reflect the theory */ +/* where the initial gaps are underestimated due */ +/* to WERR being too crude.) */ + if (! eskip) { + if (k > 1) { +/* Computing MAX */ + r__1 = wgap[windmn], r__2 = w[windex] - werr[ + windex] - w[windmn] - werr[windmn]; + wgap[windmn] = f2cmax(r__1,r__2); + } + if (windex < wend) { +/* Computing MAX */ + r__1 = savgap, r__2 = w[windpl] - werr[windpl] + - w[windex] - werr[windex]; + wgap[windex] = f2cmax(r__1,r__2); + } + } + ++idone; + } +/* here ends the code for the current child */ + +L139: +/* Proceed to any remaining child nodes */ + newfst = j + 1; +L140: + ; + } +/* L150: */ + } + ++ndepth; + goto L40; + } + ibegin = iend + 1; + wbegin = wend + 1; +L170: + ; + } + + return 0; + +/* End of SLARRV */ + +} /* slarrv_ */ + diff --git a/lapack-netlib/SRC/slarscl2.c b/lapack-netlib/SRC/slarscl2.c new file mode 100644 index 000000000..38b8c885f --- /dev/null +++ b/lapack-netlib/SRC/slarscl2.c @@ -0,0 +1,513 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLARSCL2 performs reciprocal diagonal scaling on a vector. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARSCL2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARSCL2 ( M, N, D, X, LDX ) */ + +/* INTEGER M, N, LDX */ +/* REAL D( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARSCL2 performs a reciprocal diagonal scaling on an vector: */ +/* > x <-- inv(D) * x */ +/* > where the diagonal matrix D is stored as a vector. */ +/* > */ +/* > Eventually to be replaced by BLAS_sge_diag_scale in the new BLAS */ +/* > standard. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of D and X. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of X. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, length M */ +/* > Diagonal matrix D, stored as a vector of length M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (LDX,N) */ +/* > On entry, the vector X to be scaled by D. */ +/* > On exit, the scaled vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the vector X. LDX >= M. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int slarscl2_(integer *m, integer *n, real *d__, real *x, + integer *ldx) +{ + /* System generated locals */ + integer x_dim1, x_offset, i__1, i__2; + + /* Local variables */ + integer i__, j; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --d__; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + + /* Function Body */ + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + x[i__ + j * x_dim1] /= d__[i__]; + } + } + return 0; +} /* slarscl2_ */ + diff --git a/lapack-netlib/SRC/slartg.c b/lapack-netlib/SRC/slartg.c new file mode 100644 index 000000000..c285be59f --- /dev/null +++ b/lapack-netlib/SRC/slartg.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 SLARTG generates a plane rotation with real cosine and real sine. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARTG + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARTG( F, G, CS, SN, R ) */ + +/* REAL CS, F, G, R, SN */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARTG generate a plane rotation so that */ +/* > */ +/* > [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. */ +/* > [ -SN CS ] [ G ] [ 0 ] */ +/* > */ +/* > This is a slower, more accurate version of the BLAS1 routine SROTG, */ +/* > with the following other differences: */ +/* > F and G are unchanged on return. */ +/* > If G=0, then CS=1 and SN=0. */ +/* > If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any */ +/* > floating point operations (saves work in SBDSQR when */ +/* > there are zeros on the diagonal). */ +/* > */ +/* > If F exceeds G in magnitude, CS will be positive. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] F */ +/* > \verbatim */ +/* > F is REAL */ +/* > The first component of vector to be rotated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] G */ +/* > \verbatim */ +/* > G is REAL */ +/* > The second component of vector to be rotated. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CS */ +/* > \verbatim */ +/* > CS is REAL */ +/* > The cosine of the rotation. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SN */ +/* > \verbatim */ +/* > SN is REAL */ +/* > The sine of the rotation. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] R */ +/* > \verbatim */ +/* > R is REAL */ +/* > The nonzero component of the rotated vector. */ +/* > */ +/* > This version has a few statements commented out for thread safety */ +/* > (machine parameters are computed on each entry). 10 feb 03, SJH. */ +/* > \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 slartg_(real *f, real *g, real *cs, real *sn, real *r__) +{ + /* System generated locals */ + integer i__1; + real r__1, r__2; + + /* Local variables */ + integer i__; + real scale, f1; + integer count; + real g1, safmn2, safmx2; + extern real slamch_(char *); + real safmin, eps; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + +/* LOGICAL FIRST */ +/* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 */ +/* DATA FIRST / .TRUE. / */ + +/* IF( FIRST ) THEN */ + safmin = slamch_("S"); + eps = slamch_("E"); + r__1 = slamch_("B"); + i__1 = (integer) (log(safmin / eps) / log(slamch_("B")) / 2.f); + safmn2 = pow_ri(&r__1, &i__1); + safmx2 = 1.f / safmn2; +/* FIRST = .FALSE. */ +/* END IF */ + if (*g == 0.f) { + *cs = 1.f; + *sn = 0.f; + *r__ = *f; + } else if (*f == 0.f) { + *cs = 0.f; + *sn = 1.f; + *r__ = *g; + } else { + f1 = *f; + g1 = *g; +/* Computing MAX */ + r__1 = abs(f1), r__2 = abs(g1); + scale = f2cmax(r__1,r__2); + if (scale >= safmx2) { + count = 0; +L10: + ++count; + f1 *= safmn2; + g1 *= safmn2; +/* Computing MAX */ + r__1 = abs(f1), r__2 = abs(g1); + scale = f2cmax(r__1,r__2); + if (scale >= safmx2 && count < 20) { + goto L10; + } +/* Computing 2nd power */ + r__1 = f1; +/* Computing 2nd power */ + r__2 = g1; + *r__ = sqrt(r__1 * r__1 + r__2 * r__2); + *cs = f1 / *r__; + *sn = g1 / *r__; + i__1 = count; + for (i__ = 1; i__ <= i__1; ++i__) { + *r__ *= safmx2; +/* L20: */ + } + } else if (scale <= safmn2) { + count = 0; +L30: + ++count; + f1 *= safmx2; + g1 *= safmx2; +/* Computing MAX */ + r__1 = abs(f1), r__2 = abs(g1); + scale = f2cmax(r__1,r__2); + if (scale <= safmn2) { + goto L30; + } +/* Computing 2nd power */ + r__1 = f1; +/* Computing 2nd power */ + r__2 = g1; + *r__ = sqrt(r__1 * r__1 + r__2 * r__2); + *cs = f1 / *r__; + *sn = g1 / *r__; + i__1 = count; + for (i__ = 1; i__ <= i__1; ++i__) { + *r__ *= safmn2; +/* L40: */ + } + } else { +/* Computing 2nd power */ + r__1 = f1; +/* Computing 2nd power */ + r__2 = g1; + *r__ = sqrt(r__1 * r__1 + r__2 * r__2); + *cs = f1 / *r__; + *sn = g1 / *r__; + } + if (abs(*f) > abs(*g) && *cs < 0.f) { + *cs = -(*cs); + *sn = -(*sn); + *r__ = -(*r__); + } + } + return 0; + +/* End of SLARTG */ + +} /* slartg_ */ + diff --git a/lapack-netlib/SRC/slartgp.c b/lapack-netlib/SRC/slartgp.c new file mode 100644 index 000000000..4b449da86 --- /dev/null +++ b/lapack-netlib/SRC/slartgp.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 SLARTGP generates a plane rotation so that the diagonal is nonnegative. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARTGP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARTGP( F, G, CS, SN, R ) */ + +/* REAL CS, F, G, R, SN */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARTGP generates a plane rotation so that */ +/* > */ +/* > [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1. */ +/* > [ -SN CS ] [ G ] [ 0 ] */ +/* > */ +/* > This is a slower, more accurate version of the Level 1 BLAS routine SROTG, */ +/* > with the following other differences: */ +/* > F and G are unchanged on return. */ +/* > If G=0, then CS=(+/-)1 and SN=0. */ +/* > If F=0 and (G .ne. 0), then CS=0 and SN=(+/-)1. */ +/* > */ +/* > The sign is chosen so that R >= 0. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] F */ +/* > \verbatim */ +/* > F is REAL */ +/* > The first component of vector to be rotated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] G */ +/* > \verbatim */ +/* > G is REAL */ +/* > The second component of vector to be rotated. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CS */ +/* > \verbatim */ +/* > CS is REAL */ +/* > The cosine of the rotation. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SN */ +/* > \verbatim */ +/* > SN is REAL */ +/* > The sine of the rotation. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] R */ +/* > \verbatim */ +/* > R is REAL */ +/* > The nonzero component of the rotated vector. */ +/* > */ +/* > This version has a few statements commented out for thread safety */ +/* > (machine parameters are computed on each entry). 10 feb 03, SJH. */ +/* > \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 slartgp_(real *f, real *g, real *cs, real *sn, real *r__) +{ + /* System generated locals */ + integer i__1; + real r__1, r__2; + + /* Local variables */ + integer i__; + real scale, f1; + integer count; + real g1, safmn2, safmx2; + extern real slamch_(char *); + real safmin, eps; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + +/* LOGICAL FIRST */ +/* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2 */ +/* DATA FIRST / .TRUE. / */ + +/* IF( FIRST ) THEN */ + safmin = slamch_("S"); + eps = slamch_("E"); + r__1 = slamch_("B"); + i__1 = (integer) (log(safmin / eps) / log(slamch_("B")) / 2.f); + safmn2 = pow_ri(&r__1, &i__1); + safmx2 = 1.f / safmn2; +/* FIRST = .FALSE. */ +/* END IF */ + if (*g == 0.f) { + *cs = r_sign(&c_b6, f); + *sn = 0.f; + *r__ = abs(*f); + } else if (*f == 0.f) { + *cs = 0.f; + *sn = r_sign(&c_b6, g); + *r__ = abs(*g); + } else { + f1 = *f; + g1 = *g; +/* Computing MAX */ + r__1 = abs(f1), r__2 = abs(g1); + scale = f2cmax(r__1,r__2); + if (scale >= safmx2) { + count = 0; +L10: + ++count; + f1 *= safmn2; + g1 *= safmn2; +/* Computing MAX */ + r__1 = abs(f1), r__2 = abs(g1); + scale = f2cmax(r__1,r__2); + if (scale >= safmx2 && count < 20) { + goto L10; + } +/* Computing 2nd power */ + r__1 = f1; +/* Computing 2nd power */ + r__2 = g1; + *r__ = sqrt(r__1 * r__1 + r__2 * r__2); + *cs = f1 / *r__; + *sn = g1 / *r__; + i__1 = count; + for (i__ = 1; i__ <= i__1; ++i__) { + *r__ *= safmx2; +/* L20: */ + } + } else if (scale <= safmn2) { + count = 0; +L30: + ++count; + f1 *= safmx2; + g1 *= safmx2; +/* Computing MAX */ + r__1 = abs(f1), r__2 = abs(g1); + scale = f2cmax(r__1,r__2); + if (scale <= safmn2) { + goto L30; + } +/* Computing 2nd power */ + r__1 = f1; +/* Computing 2nd power */ + r__2 = g1; + *r__ = sqrt(r__1 * r__1 + r__2 * r__2); + *cs = f1 / *r__; + *sn = g1 / *r__; + i__1 = count; + for (i__ = 1; i__ <= i__1; ++i__) { + *r__ *= safmn2; +/* L40: */ + } + } else { +/* Computing 2nd power */ + r__1 = f1; +/* Computing 2nd power */ + r__2 = g1; + *r__ = sqrt(r__1 * r__1 + r__2 * r__2); + *cs = f1 / *r__; + *sn = g1 / *r__; + } + if (*r__ < 0.f) { + *cs = -(*cs); + *sn = -(*sn); + *r__ = -(*r__); + } + } + return 0; + +/* End of SLARTG */ + +} /* slartgp_ */ + diff --git a/lapack-netlib/SRC/slartgs.c b/lapack-netlib/SRC/slartgs.c new file mode 100644 index 000000000..014329bde --- /dev/null +++ b/lapack-netlib/SRC/slartgs.c @@ -0,0 +1,541 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLARTGS generates a plane rotation designed to introduce a bulge in implicit QR iteration for t +he bidiagonal SVD problem. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARTGS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARTGS( X, Y, SIGMA, CS, SN ) */ + +/* REAL CS, SIGMA, SN, X, Y */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARTGS generates a plane rotation designed to introduce a bulge in */ +/* > Golub-Reinsch-style implicit QR iteration for the bidiagonal SVD */ +/* > problem. X and Y are the top-row entries, and SIGMA is the shift. */ +/* > The computed CS and SN define a plane rotation satisfying */ +/* > */ +/* > [ CS SN ] . [ X^2 - SIGMA ] = [ R ], */ +/* > [ -SN CS ] [ X * Y ] [ 0 ] */ +/* > */ +/* > with R nonnegative. If X^2 - SIGMA and X * Y are 0, then the */ +/* > rotation is by PI/2. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] X */ +/* > \verbatim */ +/* > X is REAL */ +/* > The (1,1) entry of an upper bidiagonal matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Y */ +/* > \verbatim */ +/* > Y is REAL */ +/* > The (1,2) entry of an upper bidiagonal matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SIGMA */ +/* > \verbatim */ +/* > SIGMA is REAL */ +/* > The shift. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CS */ +/* > \verbatim */ +/* > CS is REAL */ +/* > The cosine of the rotation. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SN */ +/* > \verbatim */ +/* > SN is REAL */ +/* > The sine of the rotation. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup auxOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int slartgs_(real *x, real *y, real *sigma, real *cs, real * + sn) +{ + real r__, s, w, z__; + extern real slamch_(char *); + real thresh; + extern /* Subroutine */ int slartgp_(real *, real *, real *, real *, real + *); + + +/* -- 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 */ + + +/* =================================================================== */ + + + thresh = slamch_("E"); + +/* Compute the first column of B**T*B - SIGMA^2*I, up to a scale */ +/* factor. */ + + if (*sigma == 0.f && abs(*x) < thresh || abs(*x) == *sigma && *y == 0.f) { + z__ = 0.f; + w = 0.f; + } else if (*sigma == 0.f) { + if (*x >= 0.f) { + z__ = *x; + w = *y; + } else { + z__ = -(*x); + w = -(*y); + } + } else if (abs(*x) < thresh) { + z__ = -(*sigma) * *sigma; + w = 0.f; + } else { + if (*x >= 0.f) { + s = 1.f; + } else { + s = -1.f; + } + z__ = s * (abs(*x) - *sigma) * (s + *sigma / *x); + w = s * *y; + } + +/* Generate the rotation. */ +/* CALL SLARTGP( Z, W, CS, SN, R ) might seem more natural; */ +/* reordering the arguments ensures that if Z = 0 then the rotation */ +/* is by PI/2. */ + + slartgp_(&w, &z__, sn, cs, &r__); + + return 0; + +/* End SLARTGS */ + +} /* slartgs_ */ + diff --git a/lapack-netlib/SRC/slartv.c b/lapack-netlib/SRC/slartv.c new file mode 100644 index 000000000..b4b68cb9e --- /dev/null +++ b/lapack-netlib/SRC/slartv.c @@ -0,0 +1,543 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLARTV applies a vector of plane rotations with real cosines and real sines to the elements of +a pair of vectors. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARTV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARTV( N, X, INCX, Y, INCY, C, S, INCC ) */ + +/* INTEGER INCC, INCX, INCY, N */ +/* REAL C( * ), S( * ), X( * ), Y( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARTV applies a vector of real plane rotations to elements of the */ +/* > real vectors x and y. For i = 1,2,...,n */ +/* > */ +/* > ( x(i) ) := ( c(i) s(i) ) ( x(i) ) */ +/* > ( y(i) ) ( -s(i) c(i) ) ( y(i) ) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of plane rotations to be applied. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is REAL array, */ +/* > dimension (1+(N-1)*INCX) */ +/* > The vector x. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The increment between elements of X. INCX > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is REAL array, */ +/* > dimension (1+(N-1)*INCY) */ +/* > The vector y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCY */ +/* > \verbatim */ +/* > INCY is INTEGER */ +/* > The increment between elements of Y. INCY > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (1+(N-1)*INCC) */ +/* > The cosines of the plane rotations. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (1+(N-1)*INCC) */ +/* > The sines of the plane rotations. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCC */ +/* > \verbatim */ +/* > INCC is INTEGER */ +/* > The increment between elements of C and S. INCC > 0. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slartv_(integer *n, real *x, integer *incx, real *y, + integer *incy, real *c__, real *s, integer *incc) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, ic, ix, iy; + real xi, yi; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --s; + --c__; + --y; + --x; + + /* Function Body */ + ix = 1; + iy = 1; + ic = 1; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + xi = x[ix]; + yi = y[iy]; + x[ix] = c__[ic] * xi + s[ic] * yi; + y[iy] = c__[ic] * yi - s[ic] * xi; + ix += *incx; + iy += *incy; + ic += *incc; +/* L10: */ + } + return 0; + +/* End of SLARTV */ + +} /* slartv_ */ + diff --git a/lapack-netlib/SRC/slaruv.c b/lapack-netlib/SRC/slaruv.c new file mode 100644 index 000000000..98dc7d5dd --- /dev/null +++ b/lapack-netlib/SRC/slaruv.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 SLARUV returns a vector of n random real numbers from a uniform distribution. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARUV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARUV( ISEED, N, X ) */ + +/* INTEGER N */ +/* INTEGER ISEED( 4 ) */ +/* REAL X( N ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARUV returns a vector of n random real numbers from a uniform (0,1) */ +/* > distribution (n <= 128). */ +/* > */ +/* > This is an auxiliary routine called by SLARNV and CLARNV. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in,out] ISEED */ +/* > \verbatim */ +/* > ISEED is INTEGER array, dimension (4) */ +/* > On entry, the seed of the random number generator; the array */ +/* > elements must be between 0 and 4095, and ISEED(4) must be */ +/* > odd. */ +/* > On exit, the seed is updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of random numbers to be generated. N <= 128. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (N) */ +/* > The generated random numbers. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This routine uses a multiplicative congruential method with modulus */ +/* > 2**48 and multiplier 33952834046453 (see G.S.Fishman, */ +/* > 'Multiplicative congruential random number generators with modulus */ +/* > 2**b: an exhaustive analysis for b = 32 and a partial analysis for */ +/* > b = 48', Math. Comp. 189, pp 331-344, 1990). */ +/* > */ +/* > 48-bit integers are stored in 4 integer array elements with 12 bits */ +/* > per element. Hence the routine is portable across machines with */ +/* > integers of 32 bits or more. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slaruv_(integer *iseed, integer *n, real *x) +{ + /* Initialized data */ + + static integer mm[512] /* was [128][4] */ = { 494,2637,255,2008,1253, + 3344,4084,1739,3143,3468,688,1657,1238,3166,1292,3422,1270,2016, + 154,2862,697,1706,491,931,1444,444,3577,3944,2184,1661,3482,657, + 3023,3618,1267,1828,164,3798,3087,2400,2870,3876,1905,1593,1797, + 1234,3460,328,2861,1950,617,2070,3331,769,1558,2412,2800,189,287, + 2045,1227,2838,209,2770,3654,3993,192,2253,3491,2889,2857,2094, + 1818,688,1407,634,3231,815,3524,1914,516,164,303,2144,3480,119, + 3357,837,2826,2332,2089,3780,1700,3712,150,2000,3375,1621,3090, + 3765,1149,3146,33,3082,2741,359,3316,1749,185,2784,2202,2199,1364, + 1244,2020,3160,2785,2772,1217,1822,1245,2252,3904,2774,997,2573, + 1148,545,322,789,1440,752,2859,123,1848,643,2405,2638,2344,46, + 3814,913,3649,339,3808,822,2832,3078,3633,2970,637,2249,2081,4019, + 1478,242,481,2075,4058,622,3376,812,234,641,4005,1122,3135,2640, + 2302,40,1832,2247,2034,2637,1287,1691,496,1597,2394,2584,1843,336, + 1472,2407,433,2096,1761,2810,566,442,41,1238,1086,603,840,3168, + 1499,1084,3438,2408,1589,2391,288,26,512,1456,171,1677,2657,2270, + 2587,2961,1970,1817,676,1410,3723,2803,3185,184,663,499,3784,1631, + 1925,3912,1398,1349,1441,2224,2411,1907,3192,2786,382,37,759,2948, + 1862,3802,2423,2051,2295,1332,1832,2405,3638,3661,327,3660,716, + 1842,3987,1368,1848,2366,2508,3754,1766,3572,2893,307,1297,3966, + 758,2598,3406,2922,1038,2934,2091,2451,1580,1958,2055,1507,1078, + 3273,17,854,2916,3971,2889,3831,2621,1541,893,736,3992,787,2125, + 2364,2460,257,1574,3912,1216,3248,3401,2124,2762,149,2245,166,466, + 4018,1399,190,2879,153,2320,18,712,2159,2318,2091,3443,1510,449, + 1956,2201,3137,3399,1321,2271,3667,2703,629,2365,2431,1113,3922, + 2554,184,2099,3228,4012,1921,3452,3901,572,3309,3171,817,3039, + 1696,1256,3715,2077,3019,1497,1101,717,51,981,1978,1813,3881,76, + 3846,3694,1682,124,1660,3997,479,1141,886,3514,1301,3604,1888, + 1836,1990,2058,692,1194,20,3285,2046,2107,3508,3525,3801,2549, + 1145,2253,305,3301,1065,3133,2913,3285,1241,1197,3729,2501,1673, + 541,2753,949,2361,1165,4081,2725,3305,3069,3617,3733,409,2157, + 1361,3973,1865,2525,1409,3445,3577,77,3761,2149,1449,3005,225,85, + 3673,3117,3089,1349,2057,413,65,1845,697,3085,3441,1573,3689,2941, + 929,533,2841,4077,721,2821,2249,2397,2817,245,1913,1997,3121,997, + 1833,2877,1633,981,2009,941,2449,197,2441,285,1473,2741,3129,909, + 2801,421,4073,2813,2337,1429,1177,1901,81,1669,2633,2269,129,1141, + 249,3917,2481,3941,2217,2749,3041,1877,345,2861,1809,3141,2825, + 157,2881,3637,1465,2829,2161,3365,361,2685,3745,2325,3609,3821, + 3537,517,3017,2141,1537 }; + + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer i__, i1, i2, i3, i4, it1, it2, it3, it4; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + /* Parameter adjustments */ + --iseed; + --x; + + /* Function Body */ + + i1 = iseed[1]; + i2 = iseed[2]; + i3 = iseed[3]; + i4 = iseed[4]; + + i__1 = f2cmin(*n,128); + for (i__ = 1; i__ <= i__1; ++i__) { + +L20: + +/* Multiply the seed by i-th power of the multiplier modulo 2**48 */ + + it4 = i4 * mm[i__ + 383]; + it3 = it4 / 4096; + it4 -= it3 << 12; + it3 = it3 + i3 * mm[i__ + 383] + i4 * mm[i__ + 255]; + it2 = it3 / 4096; + it3 -= it2 << 12; + it2 = it2 + i2 * mm[i__ + 383] + i3 * mm[i__ + 255] + i4 * mm[i__ + + 127]; + it1 = it2 / 4096; + it2 -= it1 << 12; + it1 = it1 + i1 * mm[i__ + 383] + i2 * mm[i__ + 255] + i3 * mm[i__ + + 127] + i4 * mm[i__ - 1]; + it1 %= 4096; + +/* Convert 48-bit integer to a real number in the interval (0,1) */ + + x[i__] = ((real) it1 + ((real) it2 + ((real) it3 + (real) it4 * + 2.44140625e-4f) * 2.44140625e-4f) * 2.44140625e-4f) * + 2.44140625e-4f; + + if (x[i__] == 1.f) { +/* If a real number has n bits of precision, and the first */ +/* n bits of the 48-bit integer above happen to be all 1 (which */ +/* will occur about once every 2**n calls), then X( I ) will */ +/* be rounded to exactly 1.0. In IEEE single precision arithmetic, */ +/* this will happen relatively often since n = 24. */ +/* Since X( I ) is not supposed to return exactly 0.0 or 1.0, */ +/* the statistically correct thing to do in this situation is */ +/* simply to iterate again. */ +/* N.B. the case X( I ) = 0.0 should not be possible. */ + i1 += 2; + i2 += 2; + i3 += 2; + i4 += 2; + goto L20; + } + +/* L10: */ + } + +/* Return final value of seed */ + + iseed[1] = it1; + iseed[2] = it2; + iseed[3] = it3; + iseed[4] = it4; + return 0; + +/* End of SLARUV */ + +} /* slaruv_ */ + diff --git a/lapack-netlib/SRC/slarz.c b/lapack-netlib/SRC/slarz.c new file mode 100644 index 000000000..e430de0fa --- /dev/null +++ b/lapack-netlib/SRC/slarz.c @@ -0,0 +1,636 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLARZ applies an elementary reflector (as returned by stzrzf) to a general matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARZ + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK ) */ + +/* CHARACTER SIDE */ +/* INTEGER INCV, L, LDC, M, N */ +/* REAL TAU */ +/* REAL C( LDC, * ), V( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARZ applies a real elementary reflector H to a real M-by-N */ +/* > matrix C, from either the left or the right. H is represented in the */ +/* > form */ +/* > */ +/* > H = I - tau * v * v**T */ +/* > */ +/* > where tau is a real scalar and v is a real vector. */ +/* > */ +/* > If tau = 0, then H is taken to be the unit matrix. */ +/* > */ +/* > */ +/* > H is a product of k elementary reflectors as returned by STZRZF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': form H * C */ +/* > = 'R': form C * H */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The number of entries of the vector V containing */ +/* > the meaningful part of the Householder vectors. */ +/* > If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is REAL array, dimension (1+(L-1)*abs(INCV)) */ +/* > The vector v in the representation of H as returned by */ +/* > STZRZF. V is not used if TAU = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCV */ +/* > \verbatim */ +/* > INCV is INTEGER */ +/* > The increment between elements of v. INCV <> 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is REAL */ +/* > The value tau in the representation of H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (LDC,N) */ +/* > On entry, the M-by-N matrix C. */ +/* > On exit, C is overwritten by the matrix H * C if SIDE = 'L', */ +/* > or C * H if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension */ +/* > (N) if SIDE = 'L' */ +/* > or (M) if SIDE = 'R' */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slarz_(char *side, integer *m, integer *n, integer *l, + real *v, integer *incv, real *tau, real *c__, integer *ldc, real * + work) +{ + /* System generated locals */ + integer c_dim1, c_offset; + real r__1; + + /* Local variables */ + extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, + integer *, real *, integer *, real *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *), scopy_(integer *, real *, integer *, real *, integer *), + saxpy_(integer *, real *, real *, integer *, real *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --v; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + if (lsame_(side, "L")) { + +/* Form H * C */ + + if (*tau != 0.f) { + +/* w( 1:n ) = C( 1, 1:n ) */ + + scopy_(n, &c__[c_offset], ldc, &work[1], &c__1); + +/* w( 1:n ) = w( 1:n ) + C( m-l+1:m, 1:n )**T * v( 1:l ) */ + + sgemv_("Transpose", l, n, &c_b5, &c__[*m - *l + 1 + c_dim1], ldc, + &v[1], incv, &c_b5, &work[1], &c__1); + +/* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n ) */ + + r__1 = -(*tau); + saxpy_(n, &r__1, &work[1], &c__1, &c__[c_offset], ldc); + +/* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... */ +/* tau * v( 1:l ) * w( 1:n )**T */ + + r__1 = -(*tau); + sger_(l, n, &r__1, &v[1], incv, &work[1], &c__1, &c__[*m - *l + 1 + + c_dim1], ldc); + } + + } else { + +/* Form C * H */ + + if (*tau != 0.f) { + +/* w( 1:m ) = C( 1:m, 1 ) */ + + scopy_(m, &c__[c_offset], &c__1, &work[1], &c__1); + +/* w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l ) */ + + sgemv_("No transpose", m, l, &c_b5, &c__[(*n - *l + 1) * c_dim1 + + 1], ldc, &v[1], incv, &c_b5, &work[1], &c__1); + +/* C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m ) */ + + r__1 = -(*tau); + saxpy_(m, &r__1, &work[1], &c__1, &c__[c_offset], &c__1); + +/* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... */ +/* tau * w( 1:m ) * v( 1:l )**T */ + + r__1 = -(*tau); + sger_(m, l, &r__1, &work[1], &c__1, &v[1], incv, &c__[(*n - *l + + 1) * c_dim1 + 1], ldc); + + } + + } + + return 0; + +/* End of SLARZ */ + +} /* slarz_ */ + diff --git a/lapack-netlib/SRC/slarzb.c b/lapack-netlib/SRC/slarzb.c new file mode 100644 index 000000000..f2cc4a0c1 --- /dev/null +++ b/lapack-netlib/SRC/slarzb.c @@ -0,0 +1,749 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLARZB applies a block reflector or its transpose to a general matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARZB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V, */ +/* LDV, T, LDT, C, LDC, WORK, LDWORK ) */ + +/* CHARACTER DIRECT, SIDE, STOREV, TRANS */ +/* INTEGER K, L, LDC, LDT, LDV, LDWORK, M, N */ +/* REAL C( LDC, * ), T( LDT, * ), V( LDV, * ), */ +/* $ WORK( LDWORK, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARZB applies a real block reflector H or its transpose H**T to */ +/* > a real distributed M-by-N C from the left or the right. */ +/* > */ +/* > Currently, only STOREV = 'R' and DIRECT = 'B' are supported. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply H or H**T from the Left */ +/* > = 'R': apply H or H**T from the Right */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': apply H (No transpose) */ +/* > = 'C': apply H**T (Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIRECT */ +/* > \verbatim */ +/* > DIRECT is CHARACTER*1 */ +/* > Indicates how H is formed from a product of elementary */ +/* > reflectors */ +/* > = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet) */ +/* > = 'B': H = H(k) . . . H(2) H(1) (Backward) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] STOREV */ +/* > \verbatim */ +/* > STOREV is CHARACTER*1 */ +/* > Indicates how the vectors which define the elementary */ +/* > reflectors are stored: */ +/* > = 'C': Columnwise (not supported yet) */ +/* > = 'R': Rowwise */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The order of the matrix T (= the number of elementary */ +/* > reflectors whose product defines the block reflector). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The number of columns of the matrix V containing the */ +/* > meaningful part of the Householder reflectors. */ +/* > If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is REAL array, dimension (LDV,NV). */ +/* > If STOREV = 'C', NV = K; if STOREV = 'R', NV = L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. */ +/* > If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is 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] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (LDC,N) */ +/* > On entry, the M-by-N matrix C. */ +/* > On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T. */ +/* > \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 REAL array, dimension (LDWORK,K) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDWORK */ +/* > \verbatim */ +/* > LDWORK is INTEGER */ +/* > The leading dimension of the array WORK. */ +/* > If SIDE = 'L', LDWORK >= f2cmax(1,N); */ +/* > if SIDE = 'R', LDWORK >= f2cmax(1,M). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slarzb_(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 *c__, integer *ldc, real * + work, integer *ldwork) +{ + /* System generated locals */ + integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, + work_offset, i__1, i__2; + + /* Local variables */ + integer info, i__, j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *), scopy_(integer *, real *, + integer *, real *, integer *), strmm_(char *, char *, char *, + char *, integer *, integer *, real *, real *, integer *, real *, + integer *), xerbla_(char *, integer *, ftnlen); + char transt[1]; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + work_dim1 = *ldwork; + work_offset = 1 + work_dim1 * 1; + work -= work_offset; + + /* Function Body */ + if (*m <= 0 || *n <= 0) { + return 0; + } + +/* Check for currently supported options */ + + info = 0; + if (! lsame_(direct, "B")) { + info = -3; + } else if (! lsame_(storev, "R")) { + info = -4; + } + if (info != 0) { + i__1 = -info; + xerbla_("SLARZB", &i__1, (ftnlen)6); + return 0; + } + + if (lsame_(trans, "N")) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + + if (lsame_(side, "L")) { + +/* Form H * C or H**T * C */ + +/* W( 1:n, 1:k ) = C( 1:k, 1:n )**T */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + scopy_(n, &c__[j + c_dim1], ldc, &work[j * work_dim1 + 1], &c__1); +/* L10: */ + } + +/* W( 1:n, 1:k ) = W( 1:n, 1:k ) + ... */ +/* C( m-l+1:m, 1:n )**T * V( 1:k, 1:l )**T */ + + if (*l > 0) { + sgemm_("Transpose", "Transpose", n, k, l, &c_b13, &c__[*m - *l + + 1 + c_dim1], ldc, &v[v_offset], ldv, &c_b13, &work[ + work_offset], ldwork); + } + +/* W( 1:n, 1:k ) = W( 1:n, 1:k ) * T**T or W( 1:m, 1:k ) * T */ + + strmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b13, &t[ + t_offset], ldt, &work[work_offset], ldwork); + +/* C( 1:k, 1:n ) = C( 1:k, 1:n ) - W( 1:n, 1:k )**T */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] -= work[j + i__ * work_dim1]; +/* L20: */ + } +/* L30: */ + } + +/* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ... */ +/* V( 1:k, 1:l )**T * W( 1:n, 1:k )**T */ + + if (*l > 0) { + sgemm_("Transpose", "Transpose", l, n, k, &c_b23, &v[v_offset], + ldv, &work[work_offset], ldwork, &c_b13, &c__[*m - *l + 1 + + c_dim1], ldc); + } + + } else if (lsame_(side, "R")) { + +/* Form C * H or C * H**T */ + +/* W( 1:m, 1:k ) = C( 1:m, 1:k ) */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + scopy_(m, &c__[j * c_dim1 + 1], &c__1, &work[j * work_dim1 + 1], & + c__1); +/* L40: */ + } + +/* W( 1:m, 1:k ) = W( 1:m, 1:k ) + ... */ +/* C( 1:m, n-l+1:n ) * V( 1:k, 1:l )**T */ + + if (*l > 0) { + sgemm_("No transpose", "Transpose", m, k, l, &c_b13, &c__[(*n - * + l + 1) * c_dim1 + 1], ldc, &v[v_offset], ldv, &c_b13, & + work[work_offset], ldwork); + } + +/* W( 1:m, 1:k ) = W( 1:m, 1:k ) * T or W( 1:m, 1:k ) * T**T */ + + strmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b13, &t[t_offset] + , ldt, &work[work_offset], ldwork); + +/* C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k ) */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1]; +/* L50: */ + } +/* L60: */ + } + +/* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ... */ +/* W( 1:m, 1:k ) * V( 1:k, 1:l ) */ + + if (*l > 0) { + sgemm_("No transpose", "No transpose", m, l, k, &c_b23, &work[ + work_offset], ldwork, &v[v_offset], ldv, &c_b13, &c__[(*n + - *l + 1) * c_dim1 + 1], ldc); + } + + } + + return 0; + +/* End of SLARZB */ + +} /* slarzb_ */ + diff --git a/lapack-netlib/SRC/slarzt.c b/lapack-netlib/SRC/slarzt.c new file mode 100644 index 000000000..d5ea836a7 --- /dev/null +++ b/lapack-netlib/SRC/slarzt.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 SLARZT forms the triangular factor T of a block reflector H = I - vtvH. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLARZT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) */ + +/* CHARACTER DIRECT, STOREV */ +/* INTEGER K, LDT, LDV, N */ +/* REAL T( LDT, * ), TAU( * ), V( LDV, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLARZT forms the triangular factor T of a real block reflector */ +/* > H of order > n, which is defined as a product of k elementary */ +/* > reflectors. */ +/* > */ +/* > If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */ +/* > */ +/* > If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */ +/* > */ +/* > If STOREV = 'C', the vector which defines the elementary reflector */ +/* > H(i) is stored in the i-th column of the array V, and */ +/* > */ +/* > H = I - V * T * V**T */ +/* > */ +/* > If STOREV = 'R', the vector which defines the elementary reflector */ +/* > H(i) is stored in the i-th row of the array V, and */ +/* > */ +/* > H = I - V**T * T * V */ +/* > */ +/* > Currently, only STOREV = 'R' and DIRECT = 'B' are supported. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] DIRECT */ +/* > \verbatim */ +/* > DIRECT is CHARACTER*1 */ +/* > Specifies the order in which the elementary reflectors are */ +/* > multiplied to form the block reflector: */ +/* > = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet) */ +/* > = 'B': H = H(k) . . . H(2) H(1) (Backward) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] STOREV */ +/* > \verbatim */ +/* > STOREV is CHARACTER*1 */ +/* > Specifies how the vectors which define the elementary */ +/* > reflectors are stored (see also Further Details): */ +/* > = 'C': columnwise (not supported yet) */ +/* > = 'R': rowwise */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the block reflector H. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The order of the triangular factor T (= the number of */ +/* > elementary reflectors). K >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] V */ +/* > \verbatim */ +/* > V is REAL array, dimension */ +/* > (LDV,K) if STOREV = 'C' */ +/* > (LDV,N) if STOREV = 'R' */ +/* > The matrix V. See further details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. */ +/* > If STOREV = 'C', LDV >= f2cmax(1,N); if STOREV = 'R', LDV >= K. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is REAL array, dimension (K) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is REAL array, dimension (LDT,K) */ +/* > The k by k triangular factor T of the block reflector. */ +/* > If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */ +/* > lower triangular. The rest of the array is not used. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= K. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The shape of the matrix V and the storage of the vectors which define */ +/* > the H(i) is best illustrated by the following example with n = 5 and */ +/* > k = 3. The elements equal to 1 are not stored; the corresponding */ +/* > array elements are modified but restored on exit. The rest of the */ +/* > array is not used. */ +/* > */ +/* > DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': */ +/* > */ +/* > ______V_____ */ +/* > ( v1 v2 v3 ) / \ */ +/* > ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 ) */ +/* > V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 ) */ +/* > ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 ) */ +/* > ( v1 v2 v3 ) */ +/* > . . . */ +/* > . . . */ +/* > 1 . . */ +/* > 1 . */ +/* > 1 */ +/* > */ +/* > DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R': */ +/* > */ +/* > ______V_____ */ +/* > 1 / \ */ +/* > . 1 ( 1 . . . . v1 v1 v1 v1 v1 ) */ +/* > . . 1 ( . 1 . . . v2 v2 v2 v2 v2 ) */ +/* > . . . ( . . 1 . . v3 v3 v3 v3 v3 ) */ +/* > . . . */ +/* > ( v1 v2 v3 ) */ +/* > ( v1 v2 v3 ) */ +/* > V = ( v1 v2 v3 ) */ +/* > ( v1 v2 v3 ) */ +/* > ( v1 v2 v3 ) */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slarzt_(char *direct, char *storev, integer *n, integer * + k, real *v, integer *ldv, real *tau, real *t, integer *ldt) +{ + /* System generated locals */ + integer t_dim1, t_offset, v_dim1, v_offset, i__1; + real r__1; + + /* Local variables */ + integer info, i__, j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *), strmv_(char *, char *, char *, integer *, real *, + integer *, real *, integer *), 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 */ + + +/* ===================================================================== */ + + +/* Check for currently supported options */ + + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + --tau; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + + /* Function Body */ + info = 0; + if (! lsame_(direct, "B")) { + info = -1; + } else if (! lsame_(storev, "R")) { + info = -2; + } + if (info != 0) { + i__1 = -info; + xerbla_("SLARZT", &i__1, (ftnlen)6); + return 0; + } + + for (i__ = *k; i__ >= 1; --i__) { + if (tau[i__] == 0.f) { + +/* H(i) = I */ + + i__1 = *k; + for (j = i__; j <= i__1; ++j) { + t[j + i__ * t_dim1] = 0.f; +/* L10: */ + } + } else { + +/* general case */ + + if (i__ < *k) { + +/* T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)**T */ + + i__1 = *k - i__; + r__1 = -tau[i__]; + sgemv_("No transpose", &i__1, n, &r__1, &v[i__ + 1 + v_dim1], + ldv, &v[i__ + v_dim1], ldv, &c_b8, &t[i__ + 1 + i__ * + t_dim1], &c__1); + +/* T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i) */ + + i__1 = *k - i__; + strmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ + 1 + + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ * t_dim1] + , &c__1); + } + t[i__ + i__ * t_dim1] = tau[i__]; + } +/* L20: */ + } + return 0; + +/* End of SLARZT */ + +} /* slarzt_ */ + diff --git a/lapack-netlib/SRC/slas2.c b/lapack-netlib/SRC/slas2.c new file mode 100644 index 000000000..b8e00b2f0 --- /dev/null +++ b/lapack-netlib/SRC/slas2.c @@ -0,0 +1,570 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLAS2 computes singular values of a 2-by-2 triangular matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAS2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAS2( F, G, H, SSMIN, SSMAX ) */ + +/* REAL F, G, H, SSMAX, SSMIN */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAS2 computes the singular values of the 2-by-2 matrix */ +/* > [ F G ] */ +/* > [ 0 H ]. */ +/* > On return, SSMIN is the smaller singular value and SSMAX is the */ +/* > larger singular value. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] F */ +/* > \verbatim */ +/* > F is REAL */ +/* > The (1,1) element of the 2-by-2 matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] G */ +/* > \verbatim */ +/* > G is REAL */ +/* > The (1,2) element of the 2-by-2 matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] H */ +/* > \verbatim */ +/* > H is REAL */ +/* > The (2,2) element of the 2-by-2 matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SSMIN */ +/* > \verbatim */ +/* > SSMIN is REAL */ +/* > The smaller singular value. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SSMAX */ +/* > \verbatim */ +/* > SSMAX is REAL */ +/* > The larger singular value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Barring over/underflow, all output quantities are correct to within */ +/* > a few units in the last place (ulps), even in the absence of a guard */ +/* > digit in addition/subtraction. */ +/* > */ +/* > In IEEE arithmetic, the code works correctly if one matrix element is */ +/* > infinite. */ +/* > */ +/* > Overflow will not occur unless the largest singular value itself */ +/* > overflows, or is within a few ulps of overflow. (On machines with */ +/* > partial overflow, like the Cray, overflow may occur if the largest */ +/* > singular value is within a factor of 2 of overflow.) */ +/* > */ +/* > Underflow is harmless if underflow is gradual. Otherwise, results */ +/* > may correspond to a matrix modified by perturbations of size near */ +/* > the underflow threshold. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slas2_(real *f, real *g, real *h__, real *ssmin, real * + ssmax) +{ + /* System generated locals */ + real r__1, r__2; + + /* Local variables */ + real fhmn, fhmx, c__, fa, ga, ha, as, at, au; + + +/* -- 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 */ + + +/* ==================================================================== */ + + + fa = abs(*f); + ga = abs(*g); + ha = abs(*h__); + fhmn = f2cmin(fa,ha); + fhmx = f2cmax(fa,ha); + if (fhmn == 0.f) { + *ssmin = 0.f; + if (fhmx == 0.f) { + *ssmax = ga; + } else { +/* Computing 2nd power */ + r__1 = f2cmin(fhmx,ga) / f2cmax(fhmx,ga); + *ssmax = f2cmax(fhmx,ga) * sqrt(r__1 * r__1 + 1.f); + } + } else { + if (ga < fhmx) { + as = fhmn / fhmx + 1.f; + at = (fhmx - fhmn) / fhmx; +/* Computing 2nd power */ + r__1 = ga / fhmx; + au = r__1 * r__1; + c__ = 2.f / (sqrt(as * as + au) + sqrt(at * at + au)); + *ssmin = fhmn * c__; + *ssmax = fhmx / c__; + } else { + au = fhmx / ga; + if (au == 0.f) { + +/* Avoid possible harmful underflow if exponent range */ +/* asymmetric (true SSMIN may not underflow even if */ +/* AU underflows) */ + + *ssmin = fhmn * fhmx / ga; + *ssmax = ga; + } else { + as = fhmn / fhmx + 1.f; + at = (fhmx - fhmn) / fhmx; +/* Computing 2nd power */ + r__1 = as * au; +/* Computing 2nd power */ + r__2 = at * au; + c__ = 1.f / (sqrt(r__1 * r__1 + 1.f) + sqrt(r__2 * r__2 + 1.f) + ); + *ssmin = fhmn * c__ * au; + *ssmin += *ssmin; + *ssmax = ga / (c__ + c__); + } + } + } + return 0; + +/* End of SLAS2 */ + +} /* slas2_ */ + diff --git a/lapack-netlib/SRC/slascl.c b/lapack-netlib/SRC/slascl.c new file mode 100644 index 000000000..897c50c30 --- /dev/null +++ b/lapack-netlib/SRC/slascl.c @@ -0,0 +1,797 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASCL + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO ) */ + +/* CHARACTER TYPE */ +/* INTEGER INFO, KL, KU, LDA, M, N */ +/* REAL CFROM, CTO */ +/* REAL A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASCL multiplies the M by N real matrix A by the real scalar */ +/* > CTO/CFROM. This is done without over/underflow as long as the final */ +/* > result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that */ +/* > A may be full, upper triangular, lower triangular, upper Hessenberg, */ +/* > or banded. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TYPE */ +/* > \verbatim */ +/* > TYPE is CHARACTER*1 */ +/* > TYPE indices the storage type of the input matrix. */ +/* > = 'G': A is a full matrix. */ +/* > = 'L': A is a lower triangular matrix. */ +/* > = 'U': A is an upper triangular matrix. */ +/* > = 'H': A is an upper Hessenberg matrix. */ +/* > = 'B': A is a symmetric band matrix with lower bandwidth KL */ +/* > and upper bandwidth KU and with the only the lower */ +/* > half stored. */ +/* > = 'Q': A is a symmetric band matrix with lower bandwidth KL */ +/* > and upper bandwidth KU and with the only the upper */ +/* > half stored. */ +/* > = 'Z': A is a band matrix with lower bandwidth KL and upper */ +/* > bandwidth KU. See SGBTRF for storage details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The lower bandwidth of A. Referenced only if TYPE = 'B', */ +/* > 'Q' or 'Z'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The upper bandwidth of A. Referenced only if TYPE = 'B', */ +/* > 'Q' or 'Z'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CFROM */ +/* > \verbatim */ +/* > CFROM is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CTO */ +/* > \verbatim */ +/* > CTO is REAL */ +/* > */ +/* > The matrix A is multiplied by CTO/CFROM. A(I,J) is computed */ +/* > without over/underflow if the final result CTO*A(I,J)/CFROM */ +/* > can be represented without over/underflow. CFROM must be */ +/* > nonzero. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > The matrix to be multiplied by CTO/CFROM. See TYPE for the */ +/* > storage type. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > If TYPE = 'G', 'L', 'U', 'H', LDA >= f2cmax(1,M); */ +/* > TYPE = 'B', LDA >= KL+1; */ +/* > TYPE = 'Q', LDA >= KU+1; */ +/* > TYPE = 'Z', LDA >= 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > 0 - successful exit */ +/* > <0 - if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slascl_(char *type__, integer *kl, integer *ku, real * + cfrom, real *cto, integer *m, integer *n, real *a, integer *lda, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + + /* Local variables */ + logical done; + real ctoc; + integer i__, j; + extern logical lsame_(char *, char *); + integer itype, k1, k2, k3, k4; + real cfrom1; + extern real slamch_(char *); + real cfromc; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real bignum; + extern logical sisnan_(real *); + real smlnum, mul, cto1; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + *info = 0; + + if (lsame_(type__, "G")) { + itype = 0; + } else if (lsame_(type__, "L")) { + itype = 1; + } else if (lsame_(type__, "U")) { + itype = 2; + } else if (lsame_(type__, "H")) { + itype = 3; + } else if (lsame_(type__, "B")) { + itype = 4; + } else if (lsame_(type__, "Q")) { + itype = 5; + } else if (lsame_(type__, "Z")) { + itype = 6; + } else { + itype = -1; + } + + if (itype == -1) { + *info = -1; + } else if (*cfrom == 0.f || sisnan_(cfrom)) { + *info = -4; + } else if (sisnan_(cto)) { + *info = -5; + } else if (*m < 0) { + *info = -6; + } else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) { + *info = -7; + } else if (itype <= 3 && *lda < f2cmax(1,*m)) { + *info = -9; + } else if (itype >= 4) { +/* Computing MAX */ + i__1 = *m - 1; + if (*kl < 0 || *kl > f2cmax(i__1,0)) { + *info = -2; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = *n - 1; + if (*ku < 0 || *ku > f2cmax(i__1,0) || (itype == 4 || itype == 5) && + *kl != *ku) { + *info = -3; + } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < * + ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) { + *info = -9; + } + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLASCL", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *m == 0) { + return 0; + } + +/* Get machine parameters */ + + smlnum = slamch_("S"); + bignum = 1.f / smlnum; + + cfromc = *cfrom; + ctoc = *cto; + +L10: + cfrom1 = cfromc * smlnum; + if (cfrom1 == cfromc) { +/* CFROMC is an inf. Multiply by a correctly signed zero for */ +/* finite CTOC, or a NaN if CTOC is infinite. */ + mul = ctoc / cfromc; + done = TRUE_; + cto1 = ctoc; + } else { + cto1 = ctoc / bignum; + if (cto1 == ctoc) { +/* CTOC is either 0 or an inf. In both cases, CTOC itself */ +/* serves as the correct multiplication factor. */ + mul = ctoc; + done = TRUE_; + cfromc = 1.f; + } else if (abs(cfrom1) > abs(ctoc) && ctoc != 0.f) { + mul = smlnum; + done = FALSE_; + cfromc = cfrom1; + } else if (abs(cto1) > abs(cfromc)) { + mul = bignum; + done = FALSE_; + ctoc = cto1; + } else { + mul = ctoc / cfromc; + done = TRUE_; + } + } + + if (itype == 0) { + +/* Full matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; +/* L20: */ + } +/* L30: */ + } + + } else if (itype == 1) { + +/* Lower triangular matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; +/* L40: */ + } +/* L50: */ + } + + } else if (itype == 2) { + +/* Upper triangular matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = f2cmin(j,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; +/* L60: */ + } +/* L70: */ + } + + } else if (itype == 3) { + +/* Upper Hessenberg matrix */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = j + 1; + i__2 = f2cmin(i__3,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; +/* L80: */ + } +/* L90: */ + } + + } else if (itype == 4) { + +/* Lower half of a symmetric band matrix */ + + k3 = *kl + 1; + k4 = *n + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = k3, i__4 = k4 - j; + i__2 = f2cmin(i__3,i__4); + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; +/* L100: */ + } +/* L110: */ + } + + } else if (itype == 5) { + +/* Upper half of a symmetric band matrix */ + + k1 = *ku + 2; + k3 = *ku + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = k1 - j; + i__3 = k3; + for (i__ = f2cmax(i__2,1); i__ <= i__3; ++i__) { + a[i__ + j * a_dim1] *= mul; +/* L120: */ + } +/* L130: */ + } + + } else if (itype == 6) { + +/* Band matrix */ + + k1 = *kl + *ku + 2; + k2 = *kl + 1; + k3 = (*kl << 1) + *ku + 1; + k4 = *kl + *ku + 1 + *m; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__3 = k1 - j; +/* Computing MIN */ + i__4 = k3, i__5 = k4 - j; + i__2 = f2cmin(i__4,i__5); + for (i__ = f2cmax(i__3,k2); i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] *= mul; +/* L140: */ + } +/* L150: */ + } + + } + + if (! done) { + goto L10; + } + + return 0; + +/* End of SLASCL */ + +} /* slascl_ */ + diff --git a/lapack-netlib/SRC/slascl2.c b/lapack-netlib/SRC/slascl2.c new file mode 100644 index 000000000..4e6aa377e --- /dev/null +++ b/lapack-netlib/SRC/slascl2.c @@ -0,0 +1,513 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLASCL2 performs diagonal scaling on a vector. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASCL2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASCL2 ( M, N, D, X, LDX ) */ + +/* INTEGER M, N, LDX */ +/* REAL D( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASCL2 performs a diagonal scaling on a vector: */ +/* > x <-- D * x */ +/* > where the diagonal matrix D is stored as a vector. */ +/* > */ +/* > Eventually to be replaced by BLAS_sge_diag_scale in the new BLAS */ +/* > standard. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of D and X. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of X. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, length M */ +/* > Diagonal matrix D, stored as a vector of length M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (LDX,N) */ +/* > On entry, the vector X to be scaled by D. */ +/* > On exit, the scaled vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the vector X. LDX >= M. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int slascl2_(integer *m, integer *n, real *d__, real *x, + integer *ldx) +{ + /* System generated locals */ + integer x_dim1, x_offset, i__1, i__2; + + /* Local variables */ + integer i__, j; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --d__; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + + /* Function Body */ + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + x[i__ + j * x_dim1] *= d__[i__]; + } + } + return 0; +} /* slascl2_ */ + diff --git a/lapack-netlib/SRC/slasd0.c b/lapack-netlib/SRC/slasd0.c new file mode 100644 index 000000000..714ee720c --- /dev/null +++ b/lapack-netlib/SRC/slasd0.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 SLASD0 computes the singular values of a real upper bidiagonal n-by-m matrix B with diagonal d +and off-diagonal e. Used by sbdsdc. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASD0 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK, */ +/* WORK, INFO ) */ + +/* INTEGER INFO, LDU, LDVT, N, SMLSIZ, SQRE */ +/* INTEGER IWORK( * ) */ +/* REAL D( * ), E( * ), U( LDU, * ), VT( LDVT, * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Using a divide and conquer approach, SLASD0 computes the singular */ +/* > value decomposition (SVD) of a real upper bidiagonal N-by-M */ +/* > matrix B with diagonal D and offdiagonal E, where M = N + SQRE. */ +/* > The algorithm computes orthogonal matrices U and VT such that */ +/* > B = U * S * VT. The singular values S are overwritten on D. */ +/* > */ +/* > A related subroutine, SLASDA, computes only the singular values, */ +/* > and optionally, the singular vectors in compact form. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > On entry, the row dimension of the upper bidiagonal matrix. */ +/* > This is also the dimension of the main diagonal array D. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SQRE */ +/* > \verbatim */ +/* > SQRE is INTEGER */ +/* > Specifies the column dimension of the bidiagonal matrix. */ +/* > = 0: The bidiagonal matrix has column dimension M = N; */ +/* > = 1: The bidiagonal matrix has column dimension M = N+1; */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry D contains the main diagonal of the bidiagonal */ +/* > matrix. */ +/* > On exit D, if INFO = 0, contains its singular values. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (M-1) */ +/* > Contains the subdiagonal entries of the bidiagonal matrix. */ +/* > On exit, E has been destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] U */ +/* > \verbatim */ +/* > U is REAL array, dimension (LDU, N) */ +/* > On exit, U contains the left singular vectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > On entry, leading dimension of U. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VT */ +/* > \verbatim */ +/* > VT is REAL array, dimension (LDVT, M) */ +/* > On exit, VT**T contains the right singular vectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVT */ +/* > \verbatim */ +/* > LDVT is INTEGER */ +/* > On entry, leading dimension of VT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SMLSIZ */ +/* > \verbatim */ +/* > SMLSIZ is INTEGER */ +/* > On entry, maximum size of the subproblems at the */ +/* > bottom of the computation tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (8*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (3*M**2+2*M) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: if INFO = 1, a singular value did not converge */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ming Gu and Huan Ren, Computer Science Division, University of */ +/* > California at Berkeley, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slasd0_(integer *n, integer *sqre, real *d__, real *e, + real *u, integer *ldu, real *vt, integer *ldvt, integer *smlsiz, + integer *iwork, real *work, integer *info) +{ + /* System generated locals */ + integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2; + + /* Local variables */ + real beta; + integer idxq, nlvl, i__, j, m; + real alpha; + integer inode, ndiml, idxqc, ndimr, itemp, sqrei, i1; + extern /* Subroutine */ int slasd1_(integer *, integer *, integer *, real + *, real *, real *, real *, integer *, real *, integer *, integer * + , integer *, real *, integer *); + integer ic, lf, nd, ll, nl, nr; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slasdq_( + char *, integer *, integer *, integer *, integer *, integer *, + real *, real *, real *, integer *, real *, integer *, real *, + integer *, real *, integer *), slasdt_(integer *, integer + *, integer *, integer *, integer *, integer *, integer *); + integer im1, ncc, nlf, nrf, iwk, lvl, ndb1, nlp1, nrp1; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + vt_dim1 = *ldvt; + vt_offset = 1 + vt_dim1 * 1; + vt -= vt_offset; + --iwork; + --work; + + /* Function Body */ + *info = 0; + + if (*n < 0) { + *info = -1; + } else if (*sqre < 0 || *sqre > 1) { + *info = -2; + } + + m = *n + *sqre; + + if (*ldu < *n) { + *info = -6; + } else if (*ldvt < m) { + *info = -8; + } else if (*smlsiz < 3) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLASD0", &i__1, (ftnlen)6); + return 0; + } + +/* If the input matrix is too small, call SLASDQ to find the SVD. */ + + if (*n <= *smlsiz) { + slasdq_("U", sqre, n, &m, n, &c__0, &d__[1], &e[1], &vt[vt_offset], + ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[1], info); + return 0; + } + +/* Set up the computation tree. */ + + inode = 1; + ndiml = inode + *n; + ndimr = ndiml + *n; + idxq = ndimr + *n; + iwk = idxq + *n; + slasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], + smlsiz); + +/* For the nodes on bottom level of the tree, solve */ +/* their subproblems by SLASDQ. */ + + ndb1 = (nd + 1) / 2; + ncc = 0; + i__1 = nd; + for (i__ = ndb1; i__ <= i__1; ++i__) { + +/* IC : center row of each node */ +/* NL : number of rows of left subproblem */ +/* NR : number of rows of right subproblem */ +/* NLF: starting row of the left subproblem */ +/* NRF: starting row of the right subproblem */ + + i1 = i__ - 1; + ic = iwork[inode + i1]; + nl = iwork[ndiml + i1]; + nlp1 = nl + 1; + nr = iwork[ndimr + i1]; + nrp1 = nr + 1; + nlf = ic - nl; + nrf = ic + 1; + sqrei = 1; + slasdq_("U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], &vt[ + nlf + nlf * vt_dim1], ldvt, &u[nlf + nlf * u_dim1], ldu, &u[ + nlf + nlf * u_dim1], ldu, &work[1], info); + if (*info != 0) { + return 0; + } + itemp = idxq + nlf - 2; + i__2 = nl; + for (j = 1; j <= i__2; ++j) { + iwork[itemp + j] = j; +/* L10: */ + } + if (i__ == nd) { + sqrei = *sqre; + } else { + sqrei = 1; + } + nrp1 = nr + sqrei; + slasdq_("U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], &vt[ + nrf + nrf * vt_dim1], ldvt, &u[nrf + nrf * u_dim1], ldu, &u[ + nrf + nrf * u_dim1], ldu, &work[1], info); + if (*info != 0) { + return 0; + } + itemp = idxq + ic; + i__2 = nr; + for (j = 1; j <= i__2; ++j) { + iwork[itemp + j - 1] = j; +/* L20: */ + } +/* L30: */ + } + +/* Now conquer each subproblem bottom-up. */ + + for (lvl = nlvl; lvl >= 1; --lvl) { + +/* Find the first node LF and last node LL on the */ +/* current level LVL. */ + + if (lvl == 1) { + lf = 1; + ll = 1; + } else { + i__1 = lvl - 1; + lf = pow_ii(&c__2, &i__1); + ll = (lf << 1) - 1; + } + i__1 = ll; + for (i__ = lf; i__ <= i__1; ++i__) { + im1 = i__ - 1; + ic = iwork[inode + im1]; + nl = iwork[ndiml + im1]; + nr = iwork[ndimr + im1]; + nlf = ic - nl; + if (*sqre == 0 && i__ == ll) { + sqrei = *sqre; + } else { + sqrei = 1; + } + idxqc = idxq + nlf - 1; + alpha = d__[ic]; + beta = e[ic]; + slasd1_(&nl, &nr, &sqrei, &d__[nlf], &alpha, &beta, &u[nlf + nlf * + u_dim1], ldu, &vt[nlf + nlf * vt_dim1], ldvt, &iwork[ + idxqc], &iwork[iwk], &work[1], info); + +/* Report the possible convergence failure. */ + + if (*info != 0) { + return 0; + } +/* L40: */ + } +/* L50: */ + } + + return 0; + +/* End of SLASD0 */ + +} /* slasd0_ */ + diff --git a/lapack-netlib/SRC/slasd1.c b/lapack-netlib/SRC/slasd1.c new file mode 100644 index 000000000..c5ea21509 --- /dev/null +++ b/lapack-netlib/SRC/slasd1.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 SLASD1 computes the SVD of an upper bidiagonal matrix B of the specified size. Used by sbdsdc. +*/ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASD1 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT, */ +/* IDXQ, IWORK, WORK, INFO ) */ + +/* INTEGER INFO, LDU, LDVT, NL, NR, SQRE */ +/* REAL ALPHA, BETA */ +/* INTEGER IDXQ( * ), IWORK( * ) */ +/* REAL D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B, */ +/* > where N = NL + NR + 1 and M = N + SQRE. SLASD1 is called from SLASD0. */ +/* > */ +/* > A related subroutine SLASD7 handles the case in which the singular */ +/* > values (and the singular vectors in factored form) are desired. */ +/* > */ +/* > SLASD1 computes the SVD as follows: */ +/* > */ +/* > ( D1(in) 0 0 0 ) */ +/* > B = U(in) * ( Z1**T a Z2**T b ) * VT(in) */ +/* > ( 0 0 D2(in) 0 ) */ +/* > */ +/* > = U(out) * ( D(out) 0) * VT(out) */ +/* > */ +/* > where Z**T = (Z1**T a Z2**T b) = u**T VT**T, and u is a vector of dimension M */ +/* > with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros */ +/* > elsewhere; and the entry b is empty if SQRE = 0. */ +/* > */ +/* > The left singular vectors of the original matrix are stored in U, and */ +/* > the transpose of the right singular vectors are stored in VT, and the */ +/* > singular values are in D. The algorithm consists of three stages: */ +/* > */ +/* > The first stage consists of deflating the size of the problem */ +/* > when there are multiple singular values or when there are zeros in */ +/* > the Z vector. For each such occurrence the dimension of the */ +/* > secular equation problem is reduced by one. This stage is */ +/* > performed by the routine SLASD2. */ +/* > */ +/* > The second stage consists of calculating the updated */ +/* > singular values. This is done by finding the square roots of the */ +/* > roots of the secular equation via the routine SLASD4 (as called */ +/* > by SLASD3). This routine also calculates the singular vectors of */ +/* > the current problem. */ +/* > */ +/* > The final stage consists of computing the updated singular vectors */ +/* > directly using the updated singular values. The singular vectors */ +/* > for the current problem are multiplied with the singular vectors */ +/* > from the overall problem. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NL */ +/* > \verbatim */ +/* > NL is INTEGER */ +/* > The row dimension of the upper block. NL >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NR */ +/* > \verbatim */ +/* > NR is INTEGER */ +/* > The row dimension of the lower block. NR >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SQRE */ +/* > \verbatim */ +/* > SQRE is INTEGER */ +/* > = 0: the lower block is an NR-by-NR square matrix. */ +/* > = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */ +/* > */ +/* > The bidiagonal matrix has row dimension N = NL + NR + 1, */ +/* > and column dimension M = N + SQRE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (NL+NR+1). */ +/* > N = NL+NR+1 */ +/* > On entry D(1:NL,1:NL) contains the singular values of the */ +/* > upper block; and D(NL+2:N) contains the singular values of */ +/* > the lower block. On exit D(1:N) contains the singular values */ +/* > of the modified matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ALPHA */ +/* > \verbatim */ +/* > ALPHA is REAL */ +/* > Contains the diagonal element associated with the added row. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] BETA */ +/* > \verbatim */ +/* > BETA is REAL */ +/* > Contains the off-diagonal element associated with the added */ +/* > row. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] U */ +/* > \verbatim */ +/* > U is REAL array, dimension (LDU,N) */ +/* > On entry U(1:NL, 1:NL) contains the left singular vectors of */ +/* > the upper block; U(NL+2:N, NL+2:N) contains the left singular */ +/* > vectors of the lower block. On exit U contains the left */ +/* > singular vectors of the bidiagonal matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > The leading dimension of the array U. LDU >= f2cmax( 1, N ). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VT */ +/* > \verbatim */ +/* > VT is REAL array, dimension (LDVT,M) */ +/* > where M = N + SQRE. */ +/* > On entry VT(1:NL+1, 1:NL+1)**T contains the right singular */ +/* > vectors of the upper block; VT(NL+2:M, NL+2:M)**T contains */ +/* > the right singular vectors of the lower block. On exit */ +/* > VT**T contains the right singular vectors of the */ +/* > bidiagonal matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVT */ +/* > \verbatim */ +/* > LDVT is INTEGER */ +/* > The leading dimension of the array VT. LDVT >= f2cmax( 1, M ). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] IDXQ */ +/* > \verbatim */ +/* > IDXQ is INTEGER array, dimension (N) */ +/* > This contains the permutation which will reintegrate the */ +/* > subproblem just solved back into sorted order, i.e. */ +/* > D( IDXQ( I = 1, N ) ) will be in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (4*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (3*M**2+2*M) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: if INFO = 1, a singular value did not converge */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ming Gu and Huan Ren, Computer Science Division, University of */ +/* > California at Berkeley, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slasd1_(integer *nl, integer *nr, integer *sqre, real * + d__, real *alpha, real *beta, real *u, integer *ldu, real *vt, + integer *ldvt, integer *idxq, integer *iwork, real *work, integer * + info) +{ + /* System generated locals */ + integer u_dim1, u_offset, vt_dim1, vt_offset, i__1; + real r__1, r__2; + + /* Local variables */ + integer idxc, idxp, ldvt2, i__, k, m, n, n1, n2; + extern /* Subroutine */ int slasd2_(integer *, integer *, integer *, + integer *, real *, real *, real *, real *, real *, integer *, + real *, integer *, real *, real *, integer *, real *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *), + slasd3_(integer *, integer *, integer *, integer *, real *, real + *, integer *, real *, real *, integer *, real *, integer *, real * + , integer *, real *, integer *, integer *, integer *, real *, + integer *); + integer iq, iz, isigma; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slascl_( + char *, integer *, integer *, real *, real *, integer *, integer * + , real *, integer *, integer *), slamrg_(integer *, + integer *, real *, integer *, integer *, integer *); + real orgnrm; + integer coltyp, iu2, ldq, idx, ldu2, ivt2; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + vt_dim1 = *ldvt; + vt_offset = 1 + vt_dim1 * 1; + vt -= vt_offset; + --idxq; + --iwork; + --work; + + /* Function Body */ + *info = 0; + + if (*nl < 1) { + *info = -1; + } else if (*nr < 1) { + *info = -2; + } else if (*sqre < 0 || *sqre > 1) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLASD1", &i__1, (ftnlen)6); + return 0; + } + + n = *nl + *nr + 1; + m = n + *sqre; + +/* The following values are for bookkeeping purposes only. They are */ +/* integer pointers which indicate the portion of the workspace */ +/* used by a particular array in SLASD2 and SLASD3. */ + + ldu2 = n; + ldvt2 = m; + + iz = 1; + isigma = iz + m; + iu2 = isigma + n; + ivt2 = iu2 + ldu2 * n; + iq = ivt2 + ldvt2 * m; + + idx = 1; + idxc = idx + n; + coltyp = idxc + n; + idxp = coltyp + n; + +/* Scale. */ + +/* Computing MAX */ + r__1 = abs(*alpha), r__2 = abs(*beta); + orgnrm = f2cmax(r__1,r__2); + d__[*nl + 1] = 0.f; + i__1 = n; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((r__1 = d__[i__], abs(r__1)) > orgnrm) { + orgnrm = (r__1 = d__[i__], abs(r__1)); + } +/* L10: */ + } + slascl_("G", &c__0, &c__0, &orgnrm, &c_b7, &n, &c__1, &d__[1], &n, info); + *alpha /= orgnrm; + *beta /= orgnrm; + +/* Deflate singular values. */ + + slasd2_(nl, nr, sqre, &k, &d__[1], &work[iz], alpha, beta, &u[u_offset], + ldu, &vt[vt_offset], ldvt, &work[isigma], &work[iu2], &ldu2, & + work[ivt2], &ldvt2, &iwork[idxp], &iwork[idx], &iwork[idxc], & + idxq[1], &iwork[coltyp], info); + +/* Solve Secular Equation and update singular vectors. */ + + ldq = k; + slasd3_(nl, nr, sqre, &k, &d__[1], &work[iq], &ldq, &work[isigma], &u[ + u_offset], ldu, &work[iu2], &ldu2, &vt[vt_offset], ldvt, &work[ + ivt2], &ldvt2, &iwork[idxc], &iwork[coltyp], &work[iz], info); + +/* Report the possible convergence failure. */ + + if (*info != 0) { + return 0; + } + +/* Unscale. */ + + slascl_("G", &c__0, &c__0, &c_b7, &orgnrm, &n, &c__1, &d__[1], &n, info); + +/* Prepare the IDXQ sorting permutation. */ + + n1 = k; + n2 = n - k; + slamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &idxq[1]); + + return 0; + +/* End of SLASD1 */ + +} /* slasd1_ */ + diff --git a/lapack-netlib/SRC/slasd2.c b/lapack-netlib/SRC/slasd2.c new file mode 100644 index 000000000..cb53e7d89 --- /dev/null +++ b/lapack-netlib/SRC/slasd2.c @@ -0,0 +1,1087 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLASD2 merges the two sets of singular values together into a single sorted set. Used by sbdsdc +. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASD2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASD2( NL, NR, SQRE, K, D, Z, ALPHA, BETA, U, LDU, VT, */ +/* LDVT, DSIGMA, U2, LDU2, VT2, LDVT2, IDXP, IDX, */ +/* IDXC, IDXQ, COLTYP, INFO ) */ + +/* INTEGER INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE */ +/* REAL ALPHA, BETA */ +/* INTEGER COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ), */ +/* $ IDXQ( * ) */ +/* REAL D( * ), DSIGMA( * ), U( LDU, * ), */ +/* $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), */ +/* $ Z( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASD2 merges the two sets of singular values together into a single */ +/* > sorted set. Then it tries to deflate the size of the problem. */ +/* > There are two ways in which deflation can occur: when two or more */ +/* > singular values are close together or if there is a tiny entry in the */ +/* > Z vector. For each such occurrence the order of the related secular */ +/* > equation problem is reduced by one. */ +/* > */ +/* > SLASD2 is called from SLASD1. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NL */ +/* > \verbatim */ +/* > NL is INTEGER */ +/* > The row dimension of the upper block. NL >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NR */ +/* > \verbatim */ +/* > NR is INTEGER */ +/* > The row dimension of the lower block. NR >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SQRE */ +/* > \verbatim */ +/* > SQRE is INTEGER */ +/* > = 0: the lower block is an NR-by-NR square matrix. */ +/* > = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */ +/* > */ +/* > The bidiagonal matrix has N = NL + NR + 1 rows and */ +/* > M = N + SQRE >= N columns. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > Contains the dimension of the non-deflated matrix, */ +/* > This is the order of the related secular equation. 1 <= K <=N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry D contains the singular values of the two submatrices */ +/* > to be combined. On exit D contains the trailing (N-K) updated */ +/* > singular values (those which were deflated) sorted into */ +/* > increasing order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension (N) */ +/* > On exit Z contains the updating row vector in the secular */ +/* > equation. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is REAL */ +/* > Contains the diagonal element associated with the added row. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BETA */ +/* > \verbatim */ +/* > BETA is REAL */ +/* > Contains the off-diagonal element associated with the added */ +/* > row. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] U */ +/* > \verbatim */ +/* > U is REAL array, dimension (LDU,N) */ +/* > On entry U contains the left singular vectors of two */ +/* > submatrices in the two square blocks with corners at (1,1), */ +/* > (NL, NL), and (NL+2, NL+2), (N,N). */ +/* > On exit U contains the trailing (N-K) updated left singular */ +/* > vectors (those which were deflated) in its last N-K columns. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > The leading dimension of the array U. LDU >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VT */ +/* > \verbatim */ +/* > VT is REAL array, dimension (LDVT,M) */ +/* > On entry VT**T contains the right singular vectors of two */ +/* > submatrices in the two square blocks with corners at (1,1), */ +/* > (NL+1, NL+1), and (NL+2, NL+2), (M,M). */ +/* > On exit VT**T contains the trailing (N-K) updated right singular */ +/* > vectors (those which were deflated) in its last N-K columns. */ +/* > In case SQRE =1, the last row of VT spans the right null */ +/* > space. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVT */ +/* > \verbatim */ +/* > LDVT is INTEGER */ +/* > The leading dimension of the array VT. LDVT >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DSIGMA */ +/* > \verbatim */ +/* > DSIGMA is REAL array, dimension (N) */ +/* > Contains a copy of the diagonal elements (K-1 singular values */ +/* > and one zero) in the secular equation. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] U2 */ +/* > \verbatim */ +/* > U2 is REAL array, dimension (LDU2,N) */ +/* > Contains a copy of the first K-1 left singular vectors which */ +/* > will be used by SLASD3 in a matrix multiply (SGEMM) to solve */ +/* > for the new left singular vectors. U2 is arranged into four */ +/* > blocks. The first block contains a column with 1 at NL+1 and */ +/* > zero everywhere else; the second block contains non-zero */ +/* > entries only at and above NL; the third contains non-zero */ +/* > entries only below NL+1; and the fourth is dense. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU2 */ +/* > \verbatim */ +/* > LDU2 is INTEGER */ +/* > The leading dimension of the array U2. LDU2 >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VT2 */ +/* > \verbatim */ +/* > VT2 is REAL array, dimension (LDVT2,N) */ +/* > VT2**T contains a copy of the first K right singular vectors */ +/* > which will be used by SLASD3 in a matrix multiply (SGEMM) to */ +/* > solve for the new right singular vectors. VT2 is arranged into */ +/* > three blocks. The first block contains a row that corresponds */ +/* > to the special 0 diagonal element in SIGMA; the second block */ +/* > contains non-zeros only at and before NL +1; the third block */ +/* > contains non-zeros only at and after NL +2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVT2 */ +/* > \verbatim */ +/* > LDVT2 is INTEGER */ +/* > The leading dimension of the array VT2. LDVT2 >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IDXP */ +/* > \verbatim */ +/* > IDXP is INTEGER array, dimension (N) */ +/* > This will contain the permutation used to place deflated */ +/* > values of D at the end of the array. On output IDXP(2:K) */ +/* > points to the nondeflated D-values and IDXP(K+1:N) */ +/* > points to the deflated singular values. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IDX */ +/* > \verbatim */ +/* > IDX is INTEGER array, dimension (N) */ +/* > This will contain the permutation used to sort the contents of */ +/* > D into ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IDXC */ +/* > \verbatim */ +/* > IDXC is INTEGER array, dimension (N) */ +/* > This will contain the permutation used to arrange the columns */ +/* > of the deflated U matrix into three groups: the first group */ +/* > contains non-zero entries only at and above NL, the second */ +/* > contains non-zero entries only below NL+2, and the third is */ +/* > dense. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] IDXQ */ +/* > \verbatim */ +/* > IDXQ is INTEGER array, dimension (N) */ +/* > This contains the permutation which separately sorts the two */ +/* > sub-problems in D into ascending order. Note that entries in */ +/* > the first hlaf of this permutation must first be moved one */ +/* > position backward; and entries in the second half */ +/* > must first have NL+1 added to their values. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] COLTYP */ +/* > \verbatim */ +/* > COLTYP is INTEGER array, dimension (N) */ +/* > As workspace, this will contain a label which will indicate */ +/* > which of the following types a column in the U2 matrix or a */ +/* > row in the VT2 matrix is: */ +/* > 1 : non-zero in the upper half only */ +/* > 2 : non-zero in the lower half only */ +/* > 3 : dense */ +/* > 4 : deflated */ +/* > */ +/* > On exit, it is an array of dimension 4, with COLTYP(I) being */ +/* > the dimension of the I-th type columns. */ +/* > \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 OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ming Gu and Huan Ren, Computer Science Division, University of */ +/* > California at Berkeley, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slasd2_(integer *nl, integer *nr, integer *sqre, integer + *k, real *d__, real *z__, real *alpha, real *beta, real *u, integer * + ldu, real *vt, integer *ldvt, real *dsigma, real *u2, integer *ldu2, + real *vt2, integer *ldvt2, integer *idxp, integer *idx, integer *idxc, + integer *idxq, integer *coltyp, integer *info) +{ + /* System generated locals */ + integer u_dim1, u_offset, u2_dim1, u2_offset, vt_dim1, vt_offset, + vt2_dim1, vt2_offset, i__1; + real r__1, r__2; + + /* Local variables */ + integer idxi, idxj, ctot[4]; + extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, + integer *, real *, real *); + real c__; + integer i__, j, m, n; + real s; + integer idxjp, jprev, k2; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + real z1; + extern real slapy2_(real *, real *); + integer ct, jp; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slamrg_( + integer *, integer *, real *, integer *, integer *, integer *); + real hlftol; + extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *, + integer *, real *, integer *), slaset_(char *, integer *, + integer *, real *, real *, real *, integer *); + real eps, tau, tol; + integer psm[4], nlp1, nlp2; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --z__; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + vt_dim1 = *ldvt; + vt_offset = 1 + vt_dim1 * 1; + vt -= vt_offset; + --dsigma; + u2_dim1 = *ldu2; + u2_offset = 1 + u2_dim1 * 1; + u2 -= u2_offset; + vt2_dim1 = *ldvt2; + vt2_offset = 1 + vt2_dim1 * 1; + vt2 -= vt2_offset; + --idxp; + --idx; + --idxc; + --idxq; + --coltyp; + + /* Function Body */ + *info = 0; + + if (*nl < 1) { + *info = -1; + } else if (*nr < 1) { + *info = -2; + } else if (*sqre != 1 && *sqre != 0) { + *info = -3; + } + + n = *nl + *nr + 1; + m = n + *sqre; + + if (*ldu < n) { + *info = -10; + } else if (*ldvt < m) { + *info = -12; + } else if (*ldu2 < n) { + *info = -15; + } else if (*ldvt2 < m) { + *info = -17; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLASD2", &i__1, (ftnlen)6); + return 0; + } + + nlp1 = *nl + 1; + nlp2 = *nl + 2; + +/* Generate the first part of the vector Z; and move the singular */ +/* values in the first part of D one position backward. */ + + z1 = *alpha * vt[nlp1 + nlp1 * vt_dim1]; + z__[1] = z1; + for (i__ = *nl; i__ >= 1; --i__) { + z__[i__ + 1] = *alpha * vt[i__ + nlp1 * vt_dim1]; + d__[i__ + 1] = d__[i__]; + idxq[i__ + 1] = idxq[i__] + 1; +/* L10: */ + } + +/* Generate the second part of the vector Z. */ + + i__1 = m; + for (i__ = nlp2; i__ <= i__1; ++i__) { + z__[i__] = *beta * vt[i__ + nlp2 * vt_dim1]; +/* L20: */ + } + +/* Initialize some reference arrays. */ + + i__1 = nlp1; + for (i__ = 2; i__ <= i__1; ++i__) { + coltyp[i__] = 1; +/* L30: */ + } + i__1 = n; + for (i__ = nlp2; i__ <= i__1; ++i__) { + coltyp[i__] = 2; +/* L40: */ + } + +/* Sort the singular values into increasing order */ + + i__1 = n; + for (i__ = nlp2; i__ <= i__1; ++i__) { + idxq[i__] += nlp1; +/* L50: */ + } + +/* DSIGMA, IDXC, IDXC, and the first column of U2 */ +/* are used as storage space. */ + + i__1 = n; + for (i__ = 2; i__ <= i__1; ++i__) { + dsigma[i__] = d__[idxq[i__]]; + u2[i__ + u2_dim1] = z__[idxq[i__]]; + idxc[i__] = coltyp[idxq[i__]]; +/* L60: */ + } + + slamrg_(nl, nr, &dsigma[2], &c__1, &c__1, &idx[2]); + + i__1 = n; + for (i__ = 2; i__ <= i__1; ++i__) { + idxi = idx[i__] + 1; + d__[i__] = dsigma[idxi]; + z__[i__] = u2[idxi + u2_dim1]; + coltyp[i__] = idxc[idxi]; +/* L70: */ + } + +/* Calculate the allowable deflation tolerance */ + + eps = slamch_("Epsilon"); +/* Computing MAX */ + r__1 = abs(*alpha), r__2 = abs(*beta); + tol = f2cmax(r__1,r__2); +/* Computing MAX */ + r__2 = (r__1 = d__[n], abs(r__1)); + tol = eps * 8.f * f2cmax(r__2,tol); + +/* There are 2 kinds of deflation -- first a value in the z-vector */ +/* is small, second two (or more) singular values are very close */ +/* together (their difference is small). */ + +/* If the value in the z-vector is small, we simply permute the */ +/* array so that the corresponding singular value is moved to the */ +/* end. */ + +/* If two values in the D-vector are close, we perform a two-sided */ +/* rotation designed to make one of the corresponding z-vector */ +/* entries zero, and then permute the array so that the deflated */ +/* singular value is moved to the end. */ + +/* If there are multiple singular values then the problem deflates. */ +/* Here the number of equal singular values are found. As each equal */ +/* singular value is found, an elementary reflector is computed to */ +/* rotate the corresponding singular subspace so that the */ +/* corresponding components of Z are zero in this new basis. */ + + *k = 1; + k2 = n + 1; + i__1 = n; + for (j = 2; j <= i__1; ++j) { + if ((r__1 = z__[j], abs(r__1)) <= tol) { + +/* Deflate due to small z component. */ + + --k2; + idxp[k2] = j; + coltyp[j] = 4; + if (j == n) { + goto L120; + } + } else { + jprev = j; + goto L90; + } +/* L80: */ + } +L90: + j = jprev; +L100: + ++j; + if (j > n) { + goto L110; + } + if ((r__1 = z__[j], abs(r__1)) <= tol) { + +/* Deflate due to small z component. */ + + --k2; + idxp[k2] = j; + coltyp[j] = 4; + } else { + +/* Check if singular values are close enough to allow deflation. */ + + if ((r__1 = d__[j] - d__[jprev], abs(r__1)) <= tol) { + +/* Deflation is possible. */ + + s = z__[jprev]; + c__ = z__[j]; + +/* Find sqrt(a**2+b**2) without overflow or */ +/* destructive underflow. */ + + tau = slapy2_(&c__, &s); + c__ /= tau; + s = -s / tau; + z__[j] = tau; + z__[jprev] = 0.f; + +/* Apply back the Givens rotation to the left and right */ +/* singular vector matrices. */ + + idxjp = idxq[idx[jprev] + 1]; + idxj = idxq[idx[j] + 1]; + if (idxjp <= nlp1) { + --idxjp; + } + if (idxj <= nlp1) { + --idxj; + } + srot_(&n, &u[idxjp * u_dim1 + 1], &c__1, &u[idxj * u_dim1 + 1], & + c__1, &c__, &s); + srot_(&m, &vt[idxjp + vt_dim1], ldvt, &vt[idxj + vt_dim1], ldvt, & + c__, &s); + if (coltyp[j] != coltyp[jprev]) { + coltyp[j] = 3; + } + coltyp[jprev] = 4; + --k2; + idxp[k2] = jprev; + jprev = j; + } else { + ++(*k); + u2[*k + u2_dim1] = z__[jprev]; + dsigma[*k] = d__[jprev]; + idxp[*k] = jprev; + jprev = j; + } + } + goto L100; +L110: + +/* Record the last singular value. */ + + ++(*k); + u2[*k + u2_dim1] = z__[jprev]; + dsigma[*k] = d__[jprev]; + idxp[*k] = jprev; + +L120: + +/* Count up the total number of the various types of columns, then */ +/* form a permutation which positions the four column types into */ +/* four groups of uniform structure (although one or more of these */ +/* groups may be empty). */ + + for (j = 1; j <= 4; ++j) { + ctot[j - 1] = 0; +/* L130: */ + } + i__1 = n; + for (j = 2; j <= i__1; ++j) { + ct = coltyp[j]; + ++ctot[ct - 1]; +/* L140: */ + } + +/* PSM(*) = Position in SubMatrix (of types 1 through 4) */ + + psm[0] = 2; + psm[1] = ctot[0] + 2; + psm[2] = psm[1] + ctot[1]; + psm[3] = psm[2] + ctot[2]; + +/* Fill out the IDXC array so that the permutation which it induces */ +/* will place all type-1 columns first, all type-2 columns next, */ +/* then all type-3's, and finally all type-4's, starting from the */ +/* second column. This applies similarly to the rows of VT. */ + + i__1 = n; + for (j = 2; j <= i__1; ++j) { + jp = idxp[j]; + ct = coltyp[jp]; + idxc[psm[ct - 1]] = j; + ++psm[ct - 1]; +/* L150: */ + } + +/* Sort the singular values and corresponding singular vectors into */ +/* DSIGMA, U2, and VT2 respectively. The singular values/vectors */ +/* which were not deflated go into the first K slots of DSIGMA, U2, */ +/* and VT2 respectively, while those which were deflated go into the */ +/* last N - K slots, except that the first column/row will be treated */ +/* separately. */ + + i__1 = n; + for (j = 2; j <= i__1; ++j) { + jp = idxp[j]; + dsigma[j] = d__[jp]; + idxj = idxq[idx[idxp[idxc[j]]] + 1]; + if (idxj <= nlp1) { + --idxj; + } + scopy_(&n, &u[idxj * u_dim1 + 1], &c__1, &u2[j * u2_dim1 + 1], &c__1); + scopy_(&m, &vt[idxj + vt_dim1], ldvt, &vt2[j + vt2_dim1], ldvt2); +/* L160: */ + } + +/* Determine DSIGMA(1), DSIGMA(2) and Z(1) */ + + dsigma[1] = 0.f; + hlftol = tol / 2.f; + if (abs(dsigma[2]) <= hlftol) { + dsigma[2] = hlftol; + } + if (m > n) { + z__[1] = slapy2_(&z1, &z__[m]); + if (z__[1] <= tol) { + c__ = 1.f; + s = 0.f; + z__[1] = tol; + } else { + c__ = z1 / z__[1]; + s = z__[m] / z__[1]; + } + } else { + if (abs(z1) <= tol) { + z__[1] = tol; + } else { + z__[1] = z1; + } + } + +/* Move the rest of the updating row to Z. */ + + i__1 = *k - 1; + scopy_(&i__1, &u2[u2_dim1 + 2], &c__1, &z__[2], &c__1); + +/* Determine the first column of U2, the first row of VT2 and the */ +/* last row of VT. */ + + slaset_("A", &n, &c__1, &c_b30, &c_b30, &u2[u2_offset], ldu2); + u2[nlp1 + u2_dim1] = 1.f; + if (m > n) { + i__1 = nlp1; + for (i__ = 1; i__ <= i__1; ++i__) { + vt[m + i__ * vt_dim1] = -s * vt[nlp1 + i__ * vt_dim1]; + vt2[i__ * vt2_dim1 + 1] = c__ * vt[nlp1 + i__ * vt_dim1]; +/* L170: */ + } + i__1 = m; + for (i__ = nlp2; i__ <= i__1; ++i__) { + vt2[i__ * vt2_dim1 + 1] = s * vt[m + i__ * vt_dim1]; + vt[m + i__ * vt_dim1] = c__ * vt[m + i__ * vt_dim1]; +/* L180: */ + } + } else { + scopy_(&m, &vt[nlp1 + vt_dim1], ldvt, &vt2[vt2_dim1 + 1], ldvt2); + } + if (m > n) { + scopy_(&m, &vt[m + vt_dim1], ldvt, &vt2[m + vt2_dim1], ldvt2); + } + +/* The deflated singular values and their corresponding vectors go */ +/* into the back of D, U, and V respectively. */ + + if (n > *k) { + i__1 = n - *k; + scopy_(&i__1, &dsigma[*k + 1], &c__1, &d__[*k + 1], &c__1); + i__1 = n - *k; + slacpy_("A", &n, &i__1, &u2[(*k + 1) * u2_dim1 + 1], ldu2, &u[(*k + 1) + * u_dim1 + 1], ldu); + i__1 = n - *k; + slacpy_("A", &i__1, &m, &vt2[*k + 1 + vt2_dim1], ldvt2, &vt[*k + 1 + + vt_dim1], ldvt); + } + +/* Copy CTOT into COLTYP for referencing in SLASD3. */ + + for (j = 1; j <= 4; ++j) { + coltyp[j] = ctot[j - 1]; +/* L190: */ + } + + return 0; + +/* End of SLASD2 */ + +} /* slasd2_ */ + diff --git a/lapack-netlib/SRC/slasd3.c b/lapack-netlib/SRC/slasd3.c new file mode 100644 index 000000000..6c726f8eb --- /dev/null +++ b/lapack-netlib/SRC/slasd3.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 SLASD3 finds all square roots of the roots of the secular equation, as defined by the values in + D and Z, and then updates the singular vectors by matrix multiplication. Used by sbdsdc. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASD3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2, */ +/* LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z, */ +/* INFO ) */ + +/* INTEGER INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR, */ +/* $ SQRE */ +/* INTEGER CTOT( * ), IDXC( * ) */ +/* REAL D( * ), DSIGMA( * ), Q( LDQ, * ), U( LDU, * ), */ +/* $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ), */ +/* $ Z( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASD3 finds all the square roots of the roots of the secular */ +/* > equation, as defined by the values in D and Z. It makes the */ +/* > appropriate calls to SLASD4 and then updates the singular */ +/* > vectors by matrix multiplication. */ +/* > */ +/* > This code makes very mild assumptions about floating point */ +/* > arithmetic. It will work on machines with a guard digit in */ +/* > add/subtract, or on those binary machines without guard digits */ +/* > which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2. */ +/* > It could conceivably fail on hexadecimal or decimal machines */ +/* > without guard digits, but we know of none. */ +/* > */ +/* > SLASD3 is called from SLASD1. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NL */ +/* > \verbatim */ +/* > NL is INTEGER */ +/* > The row dimension of the upper block. NL >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NR */ +/* > \verbatim */ +/* > NR is INTEGER */ +/* > The row dimension of the lower block. NR >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SQRE */ +/* > \verbatim */ +/* > SQRE is INTEGER */ +/* > = 0: the lower block is an NR-by-NR square matrix. */ +/* > = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */ +/* > */ +/* > The bidiagonal matrix has N = NL + NR + 1 rows and */ +/* > M = N + SQRE >= N columns. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The size of the secular equation, 1 =< K = < N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension(K) */ +/* > On exit the square roots of the roots of the secular equation, */ +/* > in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is REAL array, dimension (LDQ,K) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= K. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DSIGMA */ +/* > \verbatim */ +/* > DSIGMA is REAL array, dimension(K) */ +/* > The first K elements of this array contain the old roots */ +/* > of the deflated updating problem. These are the poles */ +/* > of the secular equation. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] U */ +/* > \verbatim */ +/* > U is REAL array, dimension (LDU, N) */ +/* > The last N - K columns of this matrix contain the deflated */ +/* > left singular vectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > The leading dimension of the array U. LDU >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] U2 */ +/* > \verbatim */ +/* > U2 is REAL array, dimension (LDU2, N) */ +/* > The first K columns of this matrix contain the non-deflated */ +/* > left singular vectors for the split problem. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU2 */ +/* > \verbatim */ +/* > LDU2 is INTEGER */ +/* > The leading dimension of the array U2. LDU2 >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VT */ +/* > \verbatim */ +/* > VT is REAL array, dimension (LDVT, M) */ +/* > The last M - K columns of VT**T contain the deflated */ +/* > right singular vectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVT */ +/* > \verbatim */ +/* > LDVT is INTEGER */ +/* > The leading dimension of the array VT. LDVT >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VT2 */ +/* > \verbatim */ +/* > VT2 is REAL array, dimension (LDVT2, N) */ +/* > The first K columns of VT2**T contain the non-deflated */ +/* > right singular vectors for the split problem. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVT2 */ +/* > \verbatim */ +/* > LDVT2 is INTEGER */ +/* > The leading dimension of the array VT2. LDVT2 >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IDXC */ +/* > \verbatim */ +/* > IDXC is INTEGER array, dimension (N) */ +/* > The permutation used to arrange the columns of U (and rows of */ +/* > VT) into three groups: the first group contains non-zero */ +/* > entries only at and above (or before) NL +1; the second */ +/* > contains non-zero entries only at and below (or after) NL+2; */ +/* > and the third is dense. The first column of U and the row of */ +/* > VT are treated separately, however. */ +/* > */ +/* > The rows of the singular vectors found by SLASD4 */ +/* > must be likewise permuted before the matrix multiplies can */ +/* > take place. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CTOT */ +/* > \verbatim */ +/* > CTOT is INTEGER array, dimension (4) */ +/* > A count of the total number of the various types of columns */ +/* > in U (or rows in VT), as described in IDXC. The fourth column */ +/* > type is any column which has been deflated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension (K) */ +/* > The first K elements of this array contain the components */ +/* > of the deflation-adjusted updating row vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: if INFO = 1, a singular value did not converge */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ming Gu and Huan Ren, Computer Science Division, University of */ +/* > California at Berkeley, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slasd3_(integer *nl, integer *nr, integer *sqre, integer + *k, real *d__, real *q, integer *ldq, real *dsigma, real *u, integer * + ldu, real *u2, integer *ldu2, real *vt, integer *ldvt, real *vt2, + integer *ldvt2, integer *idxc, integer *ctot, real *z__, integer * + info) +{ + /* System generated locals */ + integer q_dim1, q_offset, u_dim1, u_offset, u2_dim1, u2_offset, vt_dim1, + vt_offset, vt2_dim1, vt2_offset, i__1, i__2; + real r__1, r__2; + + /* Local variables */ + real temp; + extern real snrm2_(integer *, real *, integer *); + integer i__, j, m, n, ctemp; + extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *); + integer ktemp; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + extern real slamc3_(real *, real *); + extern /* Subroutine */ int slasd4_(integer *, integer *, real *, real *, + real *, real *, real *, real *, integer *); + integer jc; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slascl_( + char *, integer *, integer *, real *, real *, integer *, integer * + , real *, integer *, integer *), slacpy_(char *, integer * + , integer *, real *, integer *, real *, integer *); + real rho; + integer nlp1, nlp2, nrp1; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --dsigma; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + u2_dim1 = *ldu2; + u2_offset = 1 + u2_dim1 * 1; + u2 -= u2_offset; + vt_dim1 = *ldvt; + vt_offset = 1 + vt_dim1 * 1; + vt -= vt_offset; + vt2_dim1 = *ldvt2; + vt2_offset = 1 + vt2_dim1 * 1; + vt2 -= vt2_offset; + --idxc; + --ctot; + --z__; + + /* Function Body */ + *info = 0; + + if (*nl < 1) { + *info = -1; + } else if (*nr < 1) { + *info = -2; + } else if (*sqre != 1 && *sqre != 0) { + *info = -3; + } + + n = *nl + *nr + 1; + m = n + *sqre; + nlp1 = *nl + 1; + nlp2 = *nl + 2; + + if (*k < 1 || *k > n) { + *info = -4; + } else if (*ldq < *k) { + *info = -7; + } else if (*ldu < n) { + *info = -10; + } else if (*ldu2 < n) { + *info = -12; + } else if (*ldvt < m) { + *info = -14; + } else if (*ldvt2 < m) { + *info = -16; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLASD3", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*k == 1) { + d__[1] = abs(z__[1]); + scopy_(&m, &vt2[vt2_dim1 + 1], ldvt2, &vt[vt_dim1 + 1], ldvt); + if (z__[1] > 0.f) { + scopy_(&n, &u2[u2_dim1 + 1], &c__1, &u[u_dim1 + 1], &c__1); + } else { + i__1 = n; + for (i__ = 1; i__ <= i__1; ++i__) { + u[i__ + u_dim1] = -u2[i__ + u2_dim1]; +/* L10: */ + } + } + return 0; + } + +/* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can */ +/* be computed with high relative accuracy (barring over/underflow). */ +/* This is a problem on machines without a guard digit in */ +/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */ +/* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), */ +/* which on any of these machines zeros out the bottommost */ +/* bit of DSIGMA(I) if it is 1; this makes the subsequent */ +/* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation */ +/* occurs. On binary machines with a guard digit (almost all */ +/* machines) it does not change DSIGMA(I) at all. On hexadecimal */ +/* and decimal machines with a guard digit, it slightly */ +/* changes the bottommost bits of DSIGMA(I). It does not account */ +/* for hexadecimal or decimal machines without guard digits */ +/* (we know of none). We use a subroutine call to compute */ +/* 2*DSIGMA(I) to prevent optimizing compilers from eliminating */ +/* this code. */ + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + dsigma[i__] = slamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__]; +/* L20: */ + } + +/* Keep a copy of Z. */ + + scopy_(k, &z__[1], &c__1, &q[q_offset], &c__1); + +/* Normalize Z. */ + + rho = snrm2_(k, &z__[1], &c__1); + slascl_("G", &c__0, &c__0, &rho, &c_b13, k, &c__1, &z__[1], k, info); + rho *= rho; + +/* Find the new singular values. */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + slasd4_(k, &j, &dsigma[1], &z__[1], &u[j * u_dim1 + 1], &rho, &d__[j], + &vt[j * vt_dim1 + 1], info); + +/* If the zero finder fails, report the convergence failure. */ + + if (*info != 0) { + return 0; + } +/* L30: */ + } + +/* Compute updated Z. */ + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + z__[i__] = u[i__ + *k * u_dim1] * vt[i__ + *k * vt_dim1]; + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + z__[i__] *= u[i__ + j * u_dim1] * vt[i__ + j * vt_dim1] / (dsigma[ + i__] - dsigma[j]) / (dsigma[i__] + dsigma[j]); +/* L40: */ + } + i__2 = *k - 1; + for (j = i__; j <= i__2; ++j) { + z__[i__] *= u[i__ + j * u_dim1] * vt[i__ + j * vt_dim1] / (dsigma[ + i__] - dsigma[j + 1]) / (dsigma[i__] + dsigma[j + 1]); +/* L50: */ + } + r__2 = sqrt((r__1 = z__[i__], abs(r__1))); + z__[i__] = r_sign(&r__2, &q[i__ + q_dim1]); +/* L60: */ + } + +/* Compute left singular vectors of the modified diagonal matrix, */ +/* and store related information for the right singular vectors. */ + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + vt[i__ * vt_dim1 + 1] = z__[1] / u[i__ * u_dim1 + 1] / vt[i__ * + vt_dim1 + 1]; + u[i__ * u_dim1 + 1] = -1.f; + i__2 = *k; + for (j = 2; j <= i__2; ++j) { + vt[j + i__ * vt_dim1] = z__[j] / u[j + i__ * u_dim1] / vt[j + i__ + * vt_dim1]; + u[j + i__ * u_dim1] = dsigma[j] * vt[j + i__ * vt_dim1]; +/* L70: */ + } + temp = snrm2_(k, &u[i__ * u_dim1 + 1], &c__1); + q[i__ * q_dim1 + 1] = u[i__ * u_dim1 + 1] / temp; + i__2 = *k; + for (j = 2; j <= i__2; ++j) { + jc = idxc[j]; + q[j + i__ * q_dim1] = u[jc + i__ * u_dim1] / temp; +/* L80: */ + } +/* L90: */ + } + +/* Update the left singular vector matrix. */ + + if (*k == 2) { + sgemm_("N", "N", &n, k, k, &c_b13, &u2[u2_offset], ldu2, &q[q_offset], + ldq, &c_b26, &u[u_offset], ldu); + goto L100; + } + if (ctot[1] > 0) { + sgemm_("N", "N", nl, k, &ctot[1], &c_b13, &u2[(u2_dim1 << 1) + 1], + ldu2, &q[q_dim1 + 2], ldq, &c_b26, &u[u_dim1 + 1], ldu); + if (ctot[3] > 0) { + ktemp = ctot[1] + 2 + ctot[2]; + sgemm_("N", "N", nl, k, &ctot[3], &c_b13, &u2[ktemp * u2_dim1 + 1] + , ldu2, &q[ktemp + q_dim1], ldq, &c_b13, &u[u_dim1 + 1], + ldu); + } + } else if (ctot[3] > 0) { + ktemp = ctot[1] + 2 + ctot[2]; + sgemm_("N", "N", nl, k, &ctot[3], &c_b13, &u2[ktemp * u2_dim1 + 1], + ldu2, &q[ktemp + q_dim1], ldq, &c_b26, &u[u_dim1 + 1], ldu); + } else { + slacpy_("F", nl, k, &u2[u2_offset], ldu2, &u[u_offset], ldu); + } + scopy_(k, &q[q_dim1 + 1], ldq, &u[nlp1 + u_dim1], ldu); + ktemp = ctot[1] + 2; + ctemp = ctot[2] + ctot[3]; + sgemm_("N", "N", nr, k, &ctemp, &c_b13, &u2[nlp2 + ktemp * u2_dim1], ldu2, + &q[ktemp + q_dim1], ldq, &c_b26, &u[nlp2 + u_dim1], ldu); + +/* Generate the right singular vectors. */ + +L100: + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = snrm2_(k, &vt[i__ * vt_dim1 + 1], &c__1); + q[i__ + q_dim1] = vt[i__ * vt_dim1 + 1] / temp; + i__2 = *k; + for (j = 2; j <= i__2; ++j) { + jc = idxc[j]; + q[i__ + j * q_dim1] = vt[jc + i__ * vt_dim1] / temp; +/* L110: */ + } +/* L120: */ + } + +/* Update the right singular vector matrix. */ + + if (*k == 2) { + sgemm_("N", "N", k, &m, k, &c_b13, &q[q_offset], ldq, &vt2[vt2_offset] + , ldvt2, &c_b26, &vt[vt_offset], ldvt); + return 0; + } + ktemp = ctot[1] + 1; + sgemm_("N", "N", k, &nlp1, &ktemp, &c_b13, &q[q_dim1 + 1], ldq, &vt2[ + vt2_dim1 + 1], ldvt2, &c_b26, &vt[vt_dim1 + 1], ldvt); + ktemp = ctot[1] + 2 + ctot[2]; + if (ktemp <= *ldvt2) { + sgemm_("N", "N", k, &nlp1, &ctot[3], &c_b13, &q[ktemp * q_dim1 + 1], + ldq, &vt2[ktemp + vt2_dim1], ldvt2, &c_b13, &vt[vt_dim1 + 1], + ldvt); + } + + ktemp = ctot[1] + 1; + nrp1 = *nr + *sqre; + if (ktemp > 1) { + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + q[i__ + ktemp * q_dim1] = q[i__ + q_dim1]; +/* L130: */ + } + i__1 = m; + for (i__ = nlp2; i__ <= i__1; ++i__) { + vt2[ktemp + i__ * vt2_dim1] = vt2[i__ * vt2_dim1 + 1]; +/* L140: */ + } + } + ctemp = ctot[2] + 1 + ctot[3]; + sgemm_("N", "N", k, &nrp1, &ctemp, &c_b13, &q[ktemp * q_dim1 + 1], ldq, & + vt2[ktemp + nlp2 * vt2_dim1], ldvt2, &c_b26, &vt[nlp2 * vt_dim1 + + 1], ldvt); + + return 0; + +/* End of SLASD3 */ + +} /* slasd3_ */ + diff --git a/lapack-netlib/SRC/slasd4.c b/lapack-netlib/SRC/slasd4.c new file mode 100644 index 000000000..895c95f35 --- /dev/null +++ b/lapack-netlib/SRC/slasd4.c @@ -0,0 +1,1547 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLASD4 computes the square root of the i-th updated eigenvalue of a positive symmetric rank-one + modification to a positive diagonal matrix. Used by sbdsdc. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASD4 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO ) */ + +/* INTEGER I, INFO, N */ +/* REAL RHO, SIGMA */ +/* REAL D( * ), DELTA( * ), WORK( * ), Z( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This subroutine computes the square root of the I-th updated */ +/* > eigenvalue of a positive symmetric rank-one modification to */ +/* > a positive diagonal matrix whose entries are given as the squares */ +/* > of the corresponding entries in the array d, and that */ +/* > */ +/* > 0 <= D(i) < D(j) for i < j */ +/* > */ +/* > and that RHO > 0. This is arranged by the calling routine, and is */ +/* > no loss in generality. The rank-one modified system is thus */ +/* > */ +/* > diag( D ) * diag( D ) + RHO * Z * Z_transpose. */ +/* > */ +/* > where we assume the Euclidean norm of Z is 1. */ +/* > */ +/* > The method consists of approximating the rational functions in the */ +/* > secular equation by simpler interpolating rational functions. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The length of all arrays. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] I */ +/* > \verbatim */ +/* > I is INTEGER */ +/* > The index of the eigenvalue to be computed. 1 <= I <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension ( N ) */ +/* > The original eigenvalues. It is assumed that they are in */ +/* > order, 0 <= D(I) < D(J) for I < J. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension ( N ) */ +/* > The components of the updating vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DELTA */ +/* > \verbatim */ +/* > DELTA is REAL array, dimension ( N ) */ +/* > If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th */ +/* > component. If N = 1, then DELTA(1) = 1. The vector DELTA */ +/* > contains the information necessary to construct the */ +/* > (singular) eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RHO */ +/* > \verbatim */ +/* > RHO is REAL */ +/* > The scalar in the symmetric updating formula. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SIGMA */ +/* > \verbatim */ +/* > SIGMA is REAL */ +/* > The computed sigma_I, the I-th updated eigenvalue. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension ( N ) */ +/* > If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th */ +/* > component. If N = 1, then WORK( 1 ) = 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > > 0: if INFO = 1, the updating process failed. */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > Logical variable ORGATI (origin-at-i?) is used for distinguishing */ +/* > whether D(i) or D(i+1) is treated as the origin. */ +/* > */ +/* > ORGATI = .true. origin at i */ +/* > ORGATI = .false. origin at i+1 */ +/* > */ +/* > Logical variable SWTCH3 (switch-for-3-poles?) is for noting */ +/* > if we are working with THREE poles! */ +/* > */ +/* > MAXIT is the maximum number of iterations allowed for each */ +/* > eigenvalue. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ren-Cang Li, Computer Science Division, University of California */ +/* > at Berkeley, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slasd4_(integer *n, integer *i__, real *d__, real *z__, + real *delta, real *rho, real *sigma, real *work, integer *info) +{ + /* System generated locals */ + integer i__1; + real r__1; + + /* Local variables */ + real dphi, sglb, dpsi, sgub; + integer iter; + real temp, prew, temp1, temp2, a, b, c__; + integer j; + real w, dtiim, delsq, dtiip; + integer niter; + real dtisq; + logical swtch; + real dtnsq; + extern /* Subroutine */ int slaed6_(integer *, logical *, real *, real *, + real *, real *, real *, integer *); + real delsq2; + extern /* Subroutine */ int slasd5_(integer *, real *, real *, real *, + real *, real *, real *); + real dd[3], dtnsq1; + logical swtch3; + integer ii; + real dw; + extern real slamch_(char *); + real zz[3]; + logical orgati; + real erretm, dtipsq, rhoinv; + integer ip1; + real sq2, eta, phi, eps, tau, psi; + logical geomavg; + integer iim1, iip1; + real tau2; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Since this routine is called in an inner loop, we do no argument */ +/* checking. */ + +/* Quick return for N=1 and 2. */ + + /* Parameter adjustments */ + --work; + --delta; + --z__; + --d__; + + /* Function Body */ + *info = 0; + if (*n == 1) { + +/* Presumably, I=1 upon entry */ + + *sigma = sqrt(d__[1] * d__[1] + *rho * z__[1] * z__[1]); + delta[1] = 1.f; + work[1] = 1.f; + return 0; + } + if (*n == 2) { + slasd5_(i__, &d__[1], &z__[1], &delta[1], rho, sigma, &work[1]); + return 0; + } + +/* Compute machine epsilon */ + + eps = slamch_("Epsilon"); + rhoinv = 1.f / *rho; + tau2 = 0.f; + +/* The case I = N */ + + if (*i__ == *n) { + +/* Initialize some basic variables */ + + ii = *n - 1; + niter = 1; + +/* Calculate initial guess */ + + temp = *rho / 2.f; + +/* If ||Z||_2 is not one, then TEMP should be set to */ +/* RHO * ||Z||_2^2 / TWO */ + + temp1 = temp / (d__[*n] + sqrt(d__[*n] * d__[*n] + temp)); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] = d__[j] + d__[*n] + temp1; + delta[j] = d__[j] - d__[*n] - temp1; +/* L10: */ + } + + psi = 0.f; + i__1 = *n - 2; + for (j = 1; j <= i__1; ++j) { + psi += z__[j] * z__[j] / (delta[j] * work[j]); +/* L20: */ + } + + c__ = rhoinv + psi; + w = c__ + z__[ii] * z__[ii] / (delta[ii] * work[ii]) + z__[*n] * z__[* + n] / (delta[*n] * work[*n]); + + if (w <= 0.f) { + temp1 = sqrt(d__[*n] * d__[*n] + *rho); + temp = z__[*n - 1] * z__[*n - 1] / ((d__[*n - 1] + temp1) * (d__[* + n] - d__[*n - 1] + *rho / (d__[*n] + temp1))) + z__[*n] * + z__[*n] / *rho; + +/* The following TAU2 is to approximate */ +/* SIGMA_n^2 - D( N )*D( N ) */ + + if (c__ <= temp) { + tau = *rho; + } else { + delsq = (d__[*n] - d__[*n - 1]) * (d__[*n] + d__[*n - 1]); + a = -c__ * delsq + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[* + n]; + b = z__[*n] * z__[*n] * delsq; + if (a < 0.f) { + tau2 = b * 2.f / (sqrt(a * a + b * 4.f * c__) - a); + } else { + tau2 = (a + sqrt(a * a + b * 4.f * c__)) / (c__ * 2.f); + } + tau = tau2 / (d__[*n] + sqrt(d__[*n] * d__[*n] + tau2)); + } + +/* It can be proved that */ +/* D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU2 <= D(N)^2+RHO */ + + } else { + delsq = (d__[*n] - d__[*n - 1]) * (d__[*n] + d__[*n - 1]); + a = -c__ * delsq + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n]; + b = z__[*n] * z__[*n] * delsq; + +/* The following TAU2 is to approximate */ +/* SIGMA_n^2 - D( N )*D( N ) */ + + if (a < 0.f) { + tau2 = b * 2.f / (sqrt(a * a + b * 4.f * c__) - a); + } else { + tau2 = (a + sqrt(a * a + b * 4.f * c__)) / (c__ * 2.f); + } + tau = tau2 / (d__[*n] + sqrt(d__[*n] * d__[*n] + tau2)); + +/* It can be proved that */ +/* D(N)^2 < D(N)^2+TAU2 < SIGMA(N)^2 < D(N)^2+RHO/2 */ + + } + +/* The following TAU is to approximate SIGMA_n - D( N ) */ + +/* TAU = TAU2 / ( D( N )+SQRT( D( N )*D( N )+TAU2 ) ) */ + + *sigma = d__[*n] + tau; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] = d__[j] - d__[*n] - tau; + work[j] = d__[j] + d__[*n] + tau; +/* L30: */ + } + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.f; + psi = 0.f; + erretm = 0.f; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (delta[j] * work[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L40: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + temp = z__[*n] / (delta[*n] * work[*n]); + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv; +/* $ + ABS( TAU2 )*( DPSI+DPHI ) */ + + w = rhoinv + phi + psi; + +/* Test for convergence */ + + if (abs(w) <= eps * erretm) { + goto L240; + } + +/* Calculate the new step */ + + ++niter; + dtnsq1 = work[*n - 1] * delta[*n - 1]; + dtnsq = work[*n] * delta[*n]; + c__ = w - dtnsq1 * dpsi - dtnsq * dphi; + a = (dtnsq + dtnsq1) * w - dtnsq * dtnsq1 * (dpsi + dphi); + b = dtnsq * dtnsq1 * w; + if (c__ < 0.f) { + c__ = abs(c__); + } + if (c__ == 0.f) { + eta = *rho - *sigma * *sigma; + } else if (a >= 0.f) { + eta = (a + sqrt((r__1 = a * a - b * 4.f * c__, abs(r__1)))) / ( + c__ * 2.f); + } else { + eta = b * 2.f / (a - sqrt((r__1 = a * a - b * 4.f * c__, abs(r__1) + ))); + } + +/* Note, eta should be positive if w is negative, and */ +/* eta should be negative otherwise. However, */ +/* if for some reason caused by roundoff, eta*w > 0, */ +/* we simply use one Newton step instead. This way */ +/* will guarantee eta*w < 0. */ + + if (w * eta > 0.f) { + eta = -w / (dpsi + dphi); + } + temp = eta - dtnsq; + if (temp > *rho) { + eta = *rho + dtnsq; + } + + eta /= *sigma + sqrt(eta + *sigma * *sigma); + tau += eta; + *sigma += eta; + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; + work[j] += eta; +/* L50: */ + } + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.f; + psi = 0.f; + erretm = 0.f; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (work[j] * delta[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L60: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + tau2 = work[*n] * delta[*n]; + temp = z__[*n] / tau2; + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv; +/* $ + ABS( TAU2 )*( DPSI+DPHI ) */ + + w = rhoinv + phi + psi; + +/* Main loop to update the values of the array DELTA */ + + iter = niter + 1; + + for (niter = iter; niter <= 400; ++niter) { + +/* Test for convergence */ + + if (abs(w) <= eps * erretm) { + goto L240; + } + +/* Calculate the new step */ + + dtnsq1 = work[*n - 1] * delta[*n - 1]; + dtnsq = work[*n] * delta[*n]; + c__ = w - dtnsq1 * dpsi - dtnsq * dphi; + a = (dtnsq + dtnsq1) * w - dtnsq1 * dtnsq * (dpsi + dphi); + b = dtnsq1 * dtnsq * w; + if (a >= 0.f) { + eta = (a + sqrt((r__1 = a * a - b * 4.f * c__, abs(r__1)))) / + (c__ * 2.f); + } else { + eta = b * 2.f / (a - sqrt((r__1 = a * a - b * 4.f * c__, abs( + r__1)))); + } + +/* Note, eta should be positive if w is negative, and */ +/* eta should be negative otherwise. However, */ +/* if for some reason caused by roundoff, eta*w > 0, */ +/* we simply use one Newton step instead. This way */ +/* will guarantee eta*w < 0. */ + + if (w * eta > 0.f) { + eta = -w / (dpsi + dphi); + } + temp = eta - dtnsq; + if (temp <= 0.f) { + eta /= 2.f; + } + + eta /= *sigma + sqrt(eta + *sigma * *sigma); + tau += eta; + *sigma += eta; + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + delta[j] -= eta; + work[j] += eta; +/* L70: */ + } + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.f; + psi = 0.f; + erretm = 0.f; + i__1 = ii; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (work[j] * delta[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L80: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + tau2 = work[*n] * delta[*n]; + temp = z__[*n] / tau2; + phi = z__[*n] * temp; + dphi = temp * temp; + erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv; +/* $ + ABS( TAU2 )*( DPSI+DPHI ) */ + + w = rhoinv + phi + psi; +/* L90: */ + } + +/* Return with INFO = 1, NITER = MAXIT and not converged */ + + *info = 1; + goto L240; + +/* End for the case I = N */ + + } else { + +/* The case for I < N */ + + niter = 1; + ip1 = *i__ + 1; + +/* Calculate initial guess */ + + delsq = (d__[ip1] - d__[*i__]) * (d__[ip1] + d__[*i__]); + delsq2 = delsq / 2.f; + sq2 = sqrt((d__[*i__] * d__[*i__] + d__[ip1] * d__[ip1]) / 2.f); + temp = delsq2 / (d__[*i__] + sq2); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] = d__[j] + d__[*i__] + temp; + delta[j] = d__[j] - d__[*i__] - temp; +/* L100: */ + } + + psi = 0.f; + i__1 = *i__ - 1; + for (j = 1; j <= i__1; ++j) { + psi += z__[j] * z__[j] / (work[j] * delta[j]); +/* L110: */ + } + + phi = 0.f; + i__1 = *i__ + 2; + for (j = *n; j >= i__1; --j) { + phi += z__[j] * z__[j] / (work[j] * delta[j]); +/* L120: */ + } + c__ = rhoinv + psi + phi; + w = c__ + z__[*i__] * z__[*i__] / (work[*i__] * delta[*i__]) + z__[ + ip1] * z__[ip1] / (work[ip1] * delta[ip1]); + + geomavg = FALSE_; + if (w > 0.f) { + +/* d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2 */ + +/* We choose d(i) as origin. */ + + orgati = TRUE_; + ii = *i__; + sglb = 0.f; + sgub = delsq2 / (d__[*i__] + sq2); + a = c__ * delsq + z__[*i__] * z__[*i__] + z__[ip1] * z__[ip1]; + b = z__[*i__] * z__[*i__] * delsq; + if (a > 0.f) { + tau2 = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, abs( + r__1)))); + } else { + tau2 = (a - sqrt((r__1 = a * a - b * 4.f * c__, abs(r__1)))) / + (c__ * 2.f); + } + +/* TAU2 now is an estimation of SIGMA^2 - D( I )^2. The */ +/* following, however, is the corresponding estimation of */ +/* SIGMA - D( I ). */ + + tau = tau2 / (d__[*i__] + sqrt(d__[*i__] * d__[*i__] + tau2)); + temp = sqrt(eps); + if (d__[*i__] <= temp * d__[ip1] && (r__1 = z__[*i__], abs(r__1)) + <= temp && d__[*i__] > 0.f) { +/* Computing MIN */ + r__1 = d__[*i__] * 10.f; + tau = f2cmin(r__1,sgub); + geomavg = TRUE_; + } + } else { + +/* (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2 */ + +/* We choose d(i+1) as origin. */ + + orgati = FALSE_; + ii = ip1; + sglb = -delsq2 / (d__[ii] + sq2); + sgub = 0.f; + a = c__ * delsq - z__[*i__] * z__[*i__] - z__[ip1] * z__[ip1]; + b = z__[ip1] * z__[ip1] * delsq; + if (a < 0.f) { + tau2 = b * 2.f / (a - sqrt((r__1 = a * a + b * 4.f * c__, abs( + r__1)))); + } else { + tau2 = -(a + sqrt((r__1 = a * a + b * 4.f * c__, abs(r__1)))) + / (c__ * 2.f); + } + +/* TAU2 now is an estimation of SIGMA^2 - D( IP1 )^2. The */ +/* following, however, is the corresponding estimation of */ +/* SIGMA - D( IP1 ). */ + + tau = tau2 / (d__[ip1] + sqrt((r__1 = d__[ip1] * d__[ip1] + tau2, + abs(r__1)))); + } + + *sigma = d__[ii] + tau; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] = d__[j] + d__[ii] + tau; + delta[j] = d__[j] - d__[ii] - tau; +/* L130: */ + } + iim1 = ii - 1; + iip1 = ii + 1; + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.f; + psi = 0.f; + erretm = 0.f; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (work[j] * delta[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L150: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + dphi = 0.f; + phi = 0.f; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / (work[j] * delta[j]); + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; +/* L160: */ + } + + w = rhoinv + phi + psi; + +/* W is the value of the secular function with */ +/* its ii-th element removed. */ + + swtch3 = FALSE_; + if (orgati) { + if (w < 0.f) { + swtch3 = TRUE_; + } + } else { + if (w > 0.f) { + swtch3 = TRUE_; + } + } + if (ii == 1 || ii == *n) { + swtch3 = FALSE_; + } + + temp = z__[ii] / (work[ii] * delta[ii]); + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w += temp; + erretm = (phi - psi) * 8.f + erretm + rhoinv * 2.f + abs(temp) * 3.f; +/* $ + ABS( TAU2 )*DW */ + +/* Test for convergence */ + + if (abs(w) <= eps * erretm) { + goto L240; + } + + if (w <= 0.f) { + sglb = f2cmax(sglb,tau); + } else { + sgub = f2cmin(sgub,tau); + } + +/* Calculate the new step */ + + ++niter; + if (! swtch3) { + dtipsq = work[ip1] * delta[ip1]; + dtisq = work[*i__] * delta[*i__]; + if (orgati) { +/* Computing 2nd power */ + r__1 = z__[*i__] / dtisq; + c__ = w - dtipsq * dw + delsq * (r__1 * r__1); + } else { +/* Computing 2nd power */ + r__1 = z__[ip1] / dtipsq; + c__ = w - dtisq * dw - delsq * (r__1 * r__1); + } + a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; + b = dtipsq * dtisq * w; + if (c__ == 0.f) { + if (a == 0.f) { + if (orgati) { + a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * (dpsi + + dphi); + } else { + a = z__[ip1] * z__[ip1] + dtisq * dtisq * (dpsi + + dphi); + } + } + eta = b / a; + } else if (a <= 0.f) { + eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, abs(r__1)))) / + (c__ * 2.f); + } else { + eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, abs( + r__1)))); + } + } else { + +/* Interpolation using THREE most relevant poles */ + + dtiim = work[iim1] * delta[iim1]; + dtiip = work[iip1] * delta[iip1]; + temp = rhoinv + psi + phi; + if (orgati) { + temp1 = z__[iim1] / dtiim; + temp1 *= temp1; + c__ = temp - dtiip * (dpsi + dphi) - (d__[iim1] - d__[iip1]) * + (d__[iim1] + d__[iip1]) * temp1; + zz[0] = z__[iim1] * z__[iim1]; + if (dpsi < temp1) { + zz[2] = dtiip * dtiip * dphi; + } else { + zz[2] = dtiip * dtiip * (dpsi - temp1 + dphi); + } + } else { + temp1 = z__[iip1] / dtiip; + temp1 *= temp1; + c__ = temp - dtiim * (dpsi + dphi) - (d__[iip1] - d__[iim1]) * + (d__[iim1] + d__[iip1]) * temp1; + if (dphi < temp1) { + zz[0] = dtiim * dtiim * dpsi; + } else { + zz[0] = dtiim * dtiim * (dpsi + (dphi - temp1)); + } + zz[2] = z__[iip1] * z__[iip1]; + } + zz[1] = z__[ii] * z__[ii]; + dd[0] = dtiim; + dd[1] = delta[ii] * work[ii]; + dd[2] = dtiip; + slaed6_(&niter, &orgati, &c__, dd, zz, &w, &eta, info); + + if (*info != 0) { + +/* If INFO is not 0, i.e., SLAED6 failed, switch back */ +/* to 2 pole interpolation. */ + + swtch3 = FALSE_; + *info = 0; + dtipsq = work[ip1] * delta[ip1]; + dtisq = work[*i__] * delta[*i__]; + if (orgati) { +/* Computing 2nd power */ + r__1 = z__[*i__] / dtisq; + c__ = w - dtipsq * dw + delsq * (r__1 * r__1); + } else { +/* Computing 2nd power */ + r__1 = z__[ip1] / dtipsq; + c__ = w - dtisq * dw - delsq * (r__1 * r__1); + } + a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; + b = dtipsq * dtisq * w; + if (c__ == 0.f) { + if (a == 0.f) { + if (orgati) { + a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * ( + dpsi + dphi); + } else { + a = z__[ip1] * z__[ip1] + dtisq * dtisq * (dpsi + + dphi); + } + } + eta = b / a; + } else if (a <= 0.f) { + eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, abs(r__1))) + ) / (c__ * 2.f); + } else { + eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, + abs(r__1)))); + } + } + } + +/* Note, eta should be positive if w is negative, and */ +/* eta should be negative otherwise. However, */ +/* if for some reason caused by roundoff, eta*w > 0, */ +/* we simply use one Newton step instead. This way */ +/* will guarantee eta*w < 0. */ + + if (w * eta >= 0.f) { + eta = -w / dw; + } + + eta /= *sigma + sqrt(*sigma * *sigma + eta); + temp = tau + eta; + if (temp > sgub || temp < sglb) { + if (w < 0.f) { + eta = (sgub - tau) / 2.f; + } else { + eta = (sglb - tau) / 2.f; + } + if (geomavg) { + if (w < 0.f) { + if (tau > 0.f) { + eta = sqrt(sgub * tau) - tau; + } + } else { + if (sglb > 0.f) { + eta = sqrt(sglb * tau) - tau; + } + } + } + } + + prew = w; + + tau += eta; + *sigma += eta; + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] += eta; + delta[j] -= eta; +/* L170: */ + } + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.f; + psi = 0.f; + erretm = 0.f; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (work[j] * delta[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L180: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + dphi = 0.f; + phi = 0.f; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / (work[j] * delta[j]); + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; +/* L190: */ + } + + tau2 = work[ii] * delta[ii]; + temp = z__[ii] / tau2; + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w = rhoinv + phi + psi + temp; + erretm = (phi - psi) * 8.f + erretm + rhoinv * 2.f + abs(temp) * 3.f; +/* $ + ABS( TAU2 )*DW */ + + swtch = FALSE_; + if (orgati) { + if (-w > abs(prew) / 10.f) { + swtch = TRUE_; + } + } else { + if (w > abs(prew) / 10.f) { + swtch = TRUE_; + } + } + +/* Main loop to update the values of the array DELTA and WORK */ + + iter = niter + 1; + + for (niter = iter; niter <= 400; ++niter) { + +/* Test for convergence */ + + if (abs(w) <= eps * erretm) { +/* $ .OR. (SGUB-SGLB).LE.EIGHT*ABS(SGUB+SGLB) ) THEN */ + goto L240; + } + + if (w <= 0.f) { + sglb = f2cmax(sglb,tau); + } else { + sgub = f2cmin(sgub,tau); + } + +/* Calculate the new step */ + + if (! swtch3) { + dtipsq = work[ip1] * delta[ip1]; + dtisq = work[*i__] * delta[*i__]; + if (! swtch) { + if (orgati) { +/* Computing 2nd power */ + r__1 = z__[*i__] / dtisq; + c__ = w - dtipsq * dw + delsq * (r__1 * r__1); + } else { +/* Computing 2nd power */ + r__1 = z__[ip1] / dtipsq; + c__ = w - dtisq * dw - delsq * (r__1 * r__1); + } + } else { + temp = z__[ii] / (work[ii] * delta[ii]); + if (orgati) { + dpsi += temp * temp; + } else { + dphi += temp * temp; + } + c__ = w - dtisq * dpsi - dtipsq * dphi; + } + a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; + b = dtipsq * dtisq * w; + if (c__ == 0.f) { + if (a == 0.f) { + if (! swtch) { + if (orgati) { + a = z__[*i__] * z__[*i__] + dtipsq * dtipsq * + (dpsi + dphi); + } else { + a = z__[ip1] * z__[ip1] + dtisq * dtisq * ( + dpsi + dphi); + } + } else { + a = dtisq * dtisq * dpsi + dtipsq * dtipsq * dphi; + } + } + eta = b / a; + } else if (a <= 0.f) { + eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, abs(r__1))) + ) / (c__ * 2.f); + } else { + eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, + abs(r__1)))); + } + } else { + +/* Interpolation using THREE most relevant poles */ + + dtiim = work[iim1] * delta[iim1]; + dtiip = work[iip1] * delta[iip1]; + temp = rhoinv + psi + phi; + if (swtch) { + c__ = temp - dtiim * dpsi - dtiip * dphi; + zz[0] = dtiim * dtiim * dpsi; + zz[2] = dtiip * dtiip * dphi; + } else { + if (orgati) { + temp1 = z__[iim1] / dtiim; + temp1 *= temp1; + temp2 = (d__[iim1] - d__[iip1]) * (d__[iim1] + d__[ + iip1]) * temp1; + c__ = temp - dtiip * (dpsi + dphi) - temp2; + zz[0] = z__[iim1] * z__[iim1]; + if (dpsi < temp1) { + zz[2] = dtiip * dtiip * dphi; + } else { + zz[2] = dtiip * dtiip * (dpsi - temp1 + dphi); + } + } else { + temp1 = z__[iip1] / dtiip; + temp1 *= temp1; + temp2 = (d__[iip1] - d__[iim1]) * (d__[iim1] + d__[ + iip1]) * temp1; + c__ = temp - dtiim * (dpsi + dphi) - temp2; + if (dphi < temp1) { + zz[0] = dtiim * dtiim * dpsi; + } else { + zz[0] = dtiim * dtiim * (dpsi + (dphi - temp1)); + } + zz[2] = z__[iip1] * z__[iip1]; + } + } + dd[0] = dtiim; + dd[1] = delta[ii] * work[ii]; + dd[2] = dtiip; + slaed6_(&niter, &orgati, &c__, dd, zz, &w, &eta, info); + + if (*info != 0) { + +/* If INFO is not 0, i.e., SLAED6 failed, switch */ +/* back to two pole interpolation */ + + swtch3 = FALSE_; + *info = 0; + dtipsq = work[ip1] * delta[ip1]; + dtisq = work[*i__] * delta[*i__]; + if (! swtch) { + if (orgati) { +/* Computing 2nd power */ + r__1 = z__[*i__] / dtisq; + c__ = w - dtipsq * dw + delsq * (r__1 * r__1); + } else { +/* Computing 2nd power */ + r__1 = z__[ip1] / dtipsq; + c__ = w - dtisq * dw - delsq * (r__1 * r__1); + } + } else { + temp = z__[ii] / (work[ii] * delta[ii]); + if (orgati) { + dpsi += temp * temp; + } else { + dphi += temp * temp; + } + c__ = w - dtisq * dpsi - dtipsq * dphi; + } + a = (dtipsq + dtisq) * w - dtipsq * dtisq * dw; + b = dtipsq * dtisq * w; + if (c__ == 0.f) { + if (a == 0.f) { + if (! swtch) { + if (orgati) { + a = z__[*i__] * z__[*i__] + dtipsq * + dtipsq * (dpsi + dphi); + } else { + a = z__[ip1] * z__[ip1] + dtisq * dtisq * + (dpsi + dphi); + } + } else { + a = dtisq * dtisq * dpsi + dtipsq * dtipsq * + dphi; + } + } + eta = b / a; + } else if (a <= 0.f) { + eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, abs( + r__1)))) / (c__ * 2.f); + } else { + eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * + c__, abs(r__1)))); + } + } + } + +/* Note, eta should be positive if w is negative, and */ +/* eta should be negative otherwise. However, */ +/* if for some reason caused by roundoff, eta*w > 0, */ +/* we simply use one Newton step instead. This way */ +/* will guarantee eta*w < 0. */ + + if (w * eta >= 0.f) { + eta = -w / dw; + } + + eta /= *sigma + sqrt(*sigma * *sigma + eta); + temp = tau + eta; + if (temp > sgub || temp < sglb) { + if (w < 0.f) { + eta = (sgub - tau) / 2.f; + } else { + eta = (sglb - tau) / 2.f; + } + if (geomavg) { + if (w < 0.f) { + if (tau > 0.f) { + eta = sqrt(sgub * tau) - tau; + } + } else { + if (sglb > 0.f) { + eta = sqrt(sglb * tau) - tau; + } + } + } + } + + prew = w; + + tau += eta; + *sigma += eta; + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + work[j] += eta; + delta[j] -= eta; +/* L200: */ + } + +/* Evaluate PSI and the derivative DPSI */ + + dpsi = 0.f; + psi = 0.f; + erretm = 0.f; + i__1 = iim1; + for (j = 1; j <= i__1; ++j) { + temp = z__[j] / (work[j] * delta[j]); + psi += z__[j] * temp; + dpsi += temp * temp; + erretm += psi; +/* L210: */ + } + erretm = abs(erretm); + +/* Evaluate PHI and the derivative DPHI */ + + dphi = 0.f; + phi = 0.f; + i__1 = iip1; + for (j = *n; j >= i__1; --j) { + temp = z__[j] / (work[j] * delta[j]); + phi += z__[j] * temp; + dphi += temp * temp; + erretm += phi; +/* L220: */ + } + + tau2 = work[ii] * delta[ii]; + temp = z__[ii] / tau2; + dw = dpsi + dphi + temp * temp; + temp = z__[ii] * temp; + w = rhoinv + phi + psi + temp; + erretm = (phi - psi) * 8.f + erretm + rhoinv * 2.f + abs(temp) * + 3.f; +/* $ + ABS( TAU2 )*DW */ + + if (w * prew > 0.f && abs(w) > abs(prew) / 10.f) { + swtch = ! swtch; + } + +/* L230: */ + } + +/* Return with INFO = 1, NITER = MAXIT and not converged */ + + *info = 1; + + } + +L240: + return 0; + +/* End of SLASD4 */ + +} /* slasd4_ */ + diff --git a/lapack-netlib/SRC/slasd5.c b/lapack-netlib/SRC/slasd5.c new file mode 100644 index 000000000..01ee9dc03 --- /dev/null +++ b/lapack-netlib/SRC/slasd5.c @@ -0,0 +1,617 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLASD5 computes the square root of the i-th eigenvalue of a positive symmetric rank-one modific +ation of a 2-by-2 diagonal matrix. Used by sbdsdc. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASD5 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK ) */ + +/* INTEGER I */ +/* REAL DSIGMA, RHO */ +/* REAL D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This subroutine computes the square root of the I-th eigenvalue */ +/* > of a positive symmetric rank-one modification of a 2-by-2 diagonal */ +/* > matrix */ +/* > */ +/* > diag( D ) * diag( D ) + RHO * Z * transpose(Z) . */ +/* > */ +/* > The diagonal entries in the array D are assumed to satisfy */ +/* > */ +/* > 0 <= D(i) < D(j) for i < j . */ +/* > */ +/* > We also assume RHO > 0 and that the Euclidean norm of the vector */ +/* > Z is one. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] I */ +/* > \verbatim */ +/* > I is INTEGER */ +/* > The index of the eigenvalue to be computed. I = 1 or I = 2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (2) */ +/* > The original eigenvalues. We assume 0 <= D(1) < D(2). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension (2) */ +/* > The components of the updating vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DELTA */ +/* > \verbatim */ +/* > DELTA is REAL array, dimension (2) */ +/* > Contains (D(j) - sigma_I) in its j-th component. */ +/* > The vector DELTA contains the information necessary */ +/* > to construct the eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RHO */ +/* > \verbatim */ +/* > RHO is REAL */ +/* > The scalar in the symmetric updating formula. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DSIGMA */ +/* > \verbatim */ +/* > DSIGMA is REAL */ +/* > The computed sigma_I, the I-th updated eigenvalue. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (2) */ +/* > WORK contains (D(j) + sigma_I) in its j-th component. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ren-Cang Li, Computer Science Division, University of California */ +/* > at Berkeley, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slasd5_(integer *i__, real *d__, real *z__, real *delta, + real *rho, real *dsigma, real *work) +{ + /* System generated locals */ + real r__1; + + /* Local variables */ + real b, c__, w, delsq, del, tau; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --work; + --delta; + --z__; + --d__; + + /* Function Body */ + del = d__[2] - d__[1]; + delsq = del * (d__[2] + d__[1]); + if (*i__ == 1) { + w = *rho * 4.f * (z__[2] * z__[2] / (d__[1] + d__[2] * 3.f) - z__[1] * + z__[1] / (d__[1] * 3.f + d__[2])) / del + 1.f; + if (w > 0.f) { + b = delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[1] * z__[1] * delsq; + +/* B > ZERO, always */ + +/* The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 ) */ + + tau = c__ * 2.f / (b + sqrt((r__1 = b * b - c__ * 4.f, abs(r__1))) + ); + +/* The following TAU is DSIGMA - D( 1 ) */ + + tau /= d__[1] + sqrt(d__[1] * d__[1] + tau); + *dsigma = d__[1] + tau; + delta[1] = -tau; + delta[2] = del - tau; + work[1] = d__[1] * 2.f + tau; + work[2] = d__[1] + tau + d__[2]; +/* DELTA( 1 ) = -Z( 1 ) / TAU */ +/* DELTA( 2 ) = Z( 2 ) / ( DEL-TAU ) */ + } else { + b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[2] * z__[2] * delsq; + +/* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) */ + + if (b > 0.f) { + tau = c__ * -2.f / (b + sqrt(b * b + c__ * 4.f)); + } else { + tau = (b - sqrt(b * b + c__ * 4.f)) / 2.f; + } + +/* The following TAU is DSIGMA - D( 2 ) */ + + tau /= d__[2] + sqrt((r__1 = d__[2] * d__[2] + tau, abs(r__1))); + *dsigma = d__[2] + tau; + delta[1] = -(del + tau); + delta[2] = -tau; + work[1] = d__[1] + tau + d__[2]; + work[2] = d__[2] * 2.f + tau; +/* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) */ +/* DELTA( 2 ) = -Z( 2 ) / TAU */ + } +/* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) */ +/* DELTA( 1 ) = DELTA( 1 ) / TEMP */ +/* DELTA( 2 ) = DELTA( 2 ) / TEMP */ + } else { + +/* Now I=2 */ + + b = -delsq + *rho * (z__[1] * z__[1] + z__[2] * z__[2]); + c__ = *rho * z__[2] * z__[2] * delsq; + +/* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 ) */ + + if (b > 0.f) { + tau = (b + sqrt(b * b + c__ * 4.f)) / 2.f; + } else { + tau = c__ * 2.f / (-b + sqrt(b * b + c__ * 4.f)); + } + +/* The following TAU is DSIGMA - D( 2 ) */ + + tau /= d__[2] + sqrt(d__[2] * d__[2] + tau); + *dsigma = d__[2] + tau; + delta[1] = -(del + tau); + delta[2] = -tau; + work[1] = d__[1] + tau + d__[2]; + work[2] = d__[2] * 2.f + tau; +/* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU ) */ +/* DELTA( 2 ) = -Z( 2 ) / TAU */ +/* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) ) */ +/* DELTA( 1 ) = DELTA( 1 ) / TEMP */ +/* DELTA( 2 ) = DELTA( 2 ) / TEMP */ + } + return 0; + +/* End of SLASD5 */ + +} /* slasd5_ */ + diff --git a/lapack-netlib/SRC/slasd6.c b/lapack-netlib/SRC/slasd6.c new file mode 100644 index 000000000..23d3c989a --- /dev/null +++ b/lapack-netlib/SRC/slasd6.c @@ -0,0 +1,866 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLASD6 computes the SVD of an updated upper bidiagonal matrix obtained by merging two smaller o +nes by appending a row. Used by sbdsdc. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASD6 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASD6( ICOMPQ, NL, NR, SQRE, D, VF, VL, ALPHA, BETA, */ +/* IDXQ, PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, */ +/* LDGNUM, POLES, DIFL, DIFR, Z, K, C, S, WORK, */ +/* IWORK, INFO ) */ + +/* INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, */ +/* $ NR, SQRE */ +/* REAL ALPHA, BETA, C, S */ +/* INTEGER GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ), */ +/* $ PERM( * ) */ +/* REAL D( * ), DIFL( * ), DIFR( * ), */ +/* $ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ), */ +/* $ VF( * ), VL( * ), WORK( * ), Z( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASD6 computes the SVD of an updated upper bidiagonal matrix B */ +/* > obtained by merging two smaller ones by appending a row. This */ +/* > routine is used only for the problem which requires all singular */ +/* > values and optionally singular vector matrices in factored form. */ +/* > B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE. */ +/* > A related subroutine, SLASD1, handles the case in which all singular */ +/* > values and singular vectors of the bidiagonal matrix are desired. */ +/* > */ +/* > SLASD6 computes the SVD as follows: */ +/* > */ +/* > ( D1(in) 0 0 0 ) */ +/* > B = U(in) * ( Z1**T a Z2**T b ) * VT(in) */ +/* > ( 0 0 D2(in) 0 ) */ +/* > */ +/* > = U(out) * ( D(out) 0) * VT(out) */ +/* > */ +/* > where Z**T = (Z1**T a Z2**T b) = u**T VT**T, and u is a vector of dimension M */ +/* > with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros */ +/* > elsewhere; and the entry b is empty if SQRE = 0. */ +/* > */ +/* > The singular values of B can be computed using D1, D2, the first */ +/* > components of all the right singular vectors of the lower block, and */ +/* > the last components of all the right singular vectors of the upper */ +/* > block. These components are stored and updated in VF and VL, */ +/* > respectively, in SLASD6. Hence U and VT are not explicitly */ +/* > referenced. */ +/* > */ +/* > The singular values are stored in D. The algorithm consists of two */ +/* > stages: */ +/* > */ +/* > The first stage consists of deflating the size of the problem */ +/* > when there are multiple singular values or if there is a zero */ +/* > in the Z vector. For each such occurrence the dimension of the */ +/* > secular equation problem is reduced by one. This stage is */ +/* > performed by the routine SLASD7. */ +/* > */ +/* > The second stage consists of calculating the updated */ +/* > singular values. This is done by finding the roots of the */ +/* > secular equation via the routine SLASD4 (as called by SLASD8). */ +/* > This routine also updates VF and VL and computes the distances */ +/* > between the updated singular values and the old singular */ +/* > values. */ +/* > */ +/* > SLASD6 is called from SLASDA. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ICOMPQ */ +/* > \verbatim */ +/* > ICOMPQ is INTEGER */ +/* > Specifies whether singular vectors are to be computed in */ +/* > factored form: */ +/* > = 0: Compute singular values only. */ +/* > = 1: Compute singular vectors in factored form as well. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NL */ +/* > \verbatim */ +/* > NL is INTEGER */ +/* > The row dimension of the upper block. NL >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NR */ +/* > \verbatim */ +/* > NR is INTEGER */ +/* > The row dimension of the lower block. NR >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SQRE */ +/* > \verbatim */ +/* > SQRE is INTEGER */ +/* > = 0: the lower block is an NR-by-NR square matrix. */ +/* > = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */ +/* > */ +/* > The bidiagonal matrix has row dimension N = NL + NR + 1, */ +/* > and column dimension M = N + SQRE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (NL+NR+1). */ +/* > On entry D(1:NL,1:NL) contains the singular values of the */ +/* > upper block, and D(NL+2:N) contains the singular values */ +/* > of the lower block. On exit D(1:N) contains the singular */ +/* > values of the modified matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VF */ +/* > \verbatim */ +/* > VF is REAL array, dimension (M) */ +/* > On entry, VF(1:NL+1) contains the first components of all */ +/* > right singular vectors of the upper block; and VF(NL+2:M) */ +/* > contains the first components of all right singular vectors */ +/* > of the lower block. On exit, VF contains the first components */ +/* > of all right singular vectors of the bidiagonal matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VL */ +/* > \verbatim */ +/* > VL is REAL array, dimension (M) */ +/* > On entry, VL(1:NL+1) contains the last components of all */ +/* > right singular vectors of the upper block; and VL(NL+2:M) */ +/* > contains the last components of all right singular vectors of */ +/* > the lower block. On exit, VL contains the last components of */ +/* > all right singular vectors of the bidiagonal matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ALPHA */ +/* > \verbatim */ +/* > ALPHA is REAL */ +/* > Contains the diagonal element associated with the added row. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] BETA */ +/* > \verbatim */ +/* > BETA is REAL */ +/* > Contains the off-diagonal element associated with the added */ +/* > row. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] IDXQ */ +/* > \verbatim */ +/* > IDXQ is INTEGER array, dimension (N) */ +/* > This contains the permutation which will reintegrate the */ +/* > subproblem just solved back into sorted order, i.e. */ +/* > D( IDXQ( I = 1, N ) ) will be in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PERM */ +/* > \verbatim */ +/* > PERM is INTEGER array, dimension ( N ) */ +/* > The permutations (from deflation and sorting) to be applied */ +/* > to each block. Not referenced if ICOMPQ = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] GIVPTR */ +/* > \verbatim */ +/* > GIVPTR is INTEGER */ +/* > The number of Givens rotations which took place in this */ +/* > subproblem. Not referenced if ICOMPQ = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] GIVCOL */ +/* > \verbatim */ +/* > GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) */ +/* > Each pair of numbers indicates a pair of columns to take place */ +/* > in a Givens rotation. Not referenced if ICOMPQ = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDGCOL */ +/* > \verbatim */ +/* > LDGCOL is INTEGER */ +/* > leading dimension of GIVCOL, must be at least N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] GIVNUM */ +/* > \verbatim */ +/* > GIVNUM is REAL array, dimension ( LDGNUM, 2 ) */ +/* > Each number indicates the C or S value to be used in the */ +/* > corresponding Givens rotation. Not referenced if ICOMPQ = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDGNUM */ +/* > \verbatim */ +/* > LDGNUM is INTEGER */ +/* > The leading dimension of GIVNUM and POLES, must be at least N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] POLES */ +/* > \verbatim */ +/* > POLES is REAL array, dimension ( LDGNUM, 2 ) */ +/* > On exit, POLES(1,*) is an array containing the new singular */ +/* > values obtained from solving the secular equation, and */ +/* > POLES(2,*) is an array containing the poles in the secular */ +/* > equation. Not referenced if ICOMPQ = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DIFL */ +/* > \verbatim */ +/* > DIFL is REAL array, dimension ( N ) */ +/* > On exit, DIFL(I) is the distance between I-th updated */ +/* > (undeflated) singular value and the I-th (undeflated) old */ +/* > singular value. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DIFR */ +/* > \verbatim */ +/* > DIFR is REAL array, */ +/* > dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and */ +/* > dimension ( K ) if ICOMPQ = 0. */ +/* > On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not */ +/* > defined and will not be referenced. */ +/* > */ +/* > If ICOMPQ = 1, DIFR(1:K,2) is an array containing the */ +/* > normalizing factors for the right singular vector matrix. */ +/* > */ +/* > See SLASD8 for details on DIFL and DIFR. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension ( M ) */ +/* > The first elements of this array contain the components */ +/* > of the deflation-adjusted updating row vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > Contains the dimension of the non-deflated matrix, */ +/* > This is the order of the related secular equation. 1 <= K <=N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] C */ +/* > \verbatim */ +/* > C is REAL */ +/* > C contains garbage if SQRE =0 and the C-value of a Givens */ +/* > rotation related to the right null space if SQRE = 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is REAL */ +/* > S contains garbage if SQRE =0 and the S-value of a Givens */ +/* > rotation related to the right null space if SQRE = 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension ( 4 * M ) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension ( 3 * N ) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: if INFO = 1, a singular value did not converge */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ming Gu and Huan Ren, Computer Science Division, University of */ +/* > California at Berkeley, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slasd6_(integer *icompq, integer *nl, integer *nr, + integer *sqre, real *d__, real *vf, real *vl, real *alpha, real *beta, + integer *idxq, integer *perm, integer *givptr, integer *givcol, + integer *ldgcol, real *givnum, integer *ldgnum, real *poles, real * + difl, real *difr, real *z__, integer *k, real *c__, real *s, real * + work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, + poles_dim1, poles_offset, i__1; + real r__1, r__2; + + /* Local variables */ + integer idxc, idxp, ivfw, ivlw, i__, m, n; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + integer n1, n2; + extern /* Subroutine */ int slasd7_(integer *, integer *, integer *, + integer *, integer *, real *, real *, real *, real *, real *, + real *, real *, real *, real *, real *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, real *, + integer *, real *, real *, integer *), slasd8_(integer *, integer + *, real *, real *, real *, real *, real *, real *, integer *, + real *, real *, integer *); + integer iw, isigma; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slascl_( + char *, integer *, integer *, real *, real *, integer *, integer * + , real *, integer *, integer *), slamrg_(integer *, + integer *, real *, integer *, integer *, integer *); + real orgnrm; + integer idx; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --vf; + --vl; + --idxq; + --perm; + givcol_dim1 = *ldgcol; + givcol_offset = 1 + givcol_dim1 * 1; + givcol -= givcol_offset; + poles_dim1 = *ldgnum; + poles_offset = 1 + poles_dim1 * 1; + poles -= poles_offset; + givnum_dim1 = *ldgnum; + givnum_offset = 1 + givnum_dim1 * 1; + givnum -= givnum_offset; + --difl; + --difr; + --z__; + --work; + --iwork; + + /* Function Body */ + *info = 0; + n = *nl + *nr + 1; + m = n + *sqre; + + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*nl < 1) { + *info = -2; + } else if (*nr < 1) { + *info = -3; + } else if (*sqre < 0 || *sqre > 1) { + *info = -4; + } else if (*ldgcol < n) { + *info = -14; + } else if (*ldgnum < n) { + *info = -16; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLASD6", &i__1, (ftnlen)6); + return 0; + } + +/* The following values are for bookkeeping purposes only. They are */ +/* integer pointers which indicate the portion of the workspace */ +/* used by a particular array in SLASD7 and SLASD8. */ + + isigma = 1; + iw = isigma + n; + ivfw = iw + m; + ivlw = ivfw + m; + + idx = 1; + idxc = idx + n; + idxp = idxc + n; + +/* Scale. */ + +/* Computing MAX */ + r__1 = abs(*alpha), r__2 = abs(*beta); + orgnrm = f2cmax(r__1,r__2); + d__[*nl + 1] = 0.f; + i__1 = n; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((r__1 = d__[i__], abs(r__1)) > orgnrm) { + orgnrm = (r__1 = d__[i__], abs(r__1)); + } +/* L10: */ + } + slascl_("G", &c__0, &c__0, &orgnrm, &c_b7, &n, &c__1, &d__[1], &n, info); + *alpha /= orgnrm; + *beta /= orgnrm; + +/* Sort and Deflate singular values. */ + + slasd7_(icompq, nl, nr, sqre, k, &d__[1], &z__[1], &work[iw], &vf[1], & + work[ivfw], &vl[1], &work[ivlw], alpha, beta, &work[isigma], & + iwork[idx], &iwork[idxp], &idxq[1], &perm[1], givptr, &givcol[ + givcol_offset], ldgcol, &givnum[givnum_offset], ldgnum, c__, s, + info); + +/* Solve Secular Equation, compute DIFL, DIFR, and update VF, VL. */ + + slasd8_(icompq, k, &d__[1], &z__[1], &vf[1], &vl[1], &difl[1], &difr[1], + ldgnum, &work[isigma], &work[iw], info); + +/* Report the possible convergence failure. */ + + if (*info != 0) { + return 0; + } + +/* Save the poles if ICOMPQ = 1. */ + + if (*icompq == 1) { + scopy_(k, &d__[1], &c__1, &poles[poles_dim1 + 1], &c__1); + scopy_(k, &work[isigma], &c__1, &poles[(poles_dim1 << 1) + 1], &c__1); + } + +/* Unscale. */ + + slascl_("G", &c__0, &c__0, &c_b7, &orgnrm, &n, &c__1, &d__[1], &n, info); + +/* Prepare the IDXQ sorting permutation. */ + + n1 = *k; + n2 = n - *k; + slamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &idxq[1]); + + return 0; + +/* End of SLASD6 */ + +} /* slasd6_ */ + diff --git a/lapack-netlib/SRC/slasd7.c b/lapack-netlib/SRC/slasd7.c new file mode 100644 index 000000000..99517e2d5 --- /dev/null +++ b/lapack-netlib/SRC/slasd7.c @@ -0,0 +1,1011 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLASD7 merges the two sets of singular values together into a single sorted set. Then it tries +to deflate the size of the problem. Used by sbdsdc. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASD7 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, ZW, VF, VFW, VL, */ +/* VLW, ALPHA, BETA, DSIGMA, IDX, IDXP, IDXQ, */ +/* PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, */ +/* C, S, INFO ) */ + +/* INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL, */ +/* $ NR, SQRE */ +/* REAL ALPHA, BETA, C, S */ +/* INTEGER GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ), */ +/* $ IDXQ( * ), PERM( * ) */ +/* REAL D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ), */ +/* $ VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ), */ +/* $ ZW( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASD7 merges the two sets of singular values together into a single */ +/* > sorted set. Then it tries to deflate the size of the problem. There */ +/* > are two ways in which deflation can occur: when two or more singular */ +/* > values are close together or if there is a tiny entry in the Z */ +/* > vector. For each such occurrence the order of the related */ +/* > secular equation problem is reduced by one. */ +/* > */ +/* > SLASD7 is called from SLASD6. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ICOMPQ */ +/* > \verbatim */ +/* > ICOMPQ is INTEGER */ +/* > Specifies whether singular vectors are to be computed */ +/* > in compact form, as follows: */ +/* > = 0: Compute singular values only. */ +/* > = 1: Compute singular vectors of upper */ +/* > bidiagonal matrix in compact form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NL */ +/* > \verbatim */ +/* > NL is INTEGER */ +/* > The row dimension of the upper block. NL >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NR */ +/* > \verbatim */ +/* > NR is INTEGER */ +/* > The row dimension of the lower block. NR >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SQRE */ +/* > \verbatim */ +/* > SQRE is INTEGER */ +/* > = 0: the lower block is an NR-by-NR square matrix. */ +/* > = 1: the lower block is an NR-by-(NR+1) rectangular matrix. */ +/* > */ +/* > The bidiagonal matrix has */ +/* > N = NL + NR + 1 rows and */ +/* > M = N + SQRE >= N columns. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > Contains the dimension of the non-deflated matrix, this is */ +/* > the order of the related secular equation. 1 <= K <=N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension ( N ) */ +/* > On entry D contains the singular values of the two submatrices */ +/* > to be combined. On exit D contains the trailing (N-K) updated */ +/* > singular values (those which were deflated) sorted into */ +/* > increasing order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension ( M ) */ +/* > On exit Z contains the updating row vector in the secular */ +/* > equation. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ZW */ +/* > \verbatim */ +/* > ZW is REAL array, dimension ( M ) */ +/* > Workspace for Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VF */ +/* > \verbatim */ +/* > VF is REAL array, dimension ( M ) */ +/* > On entry, VF(1:NL+1) contains the first components of all */ +/* > right singular vectors of the upper block; and VF(NL+2:M) */ +/* > contains the first components of all right singular vectors */ +/* > of the lower block. On exit, VF contains the first components */ +/* > of all right singular vectors of the bidiagonal matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VFW */ +/* > \verbatim */ +/* > VFW is REAL array, dimension ( M ) */ +/* > Workspace for VF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VL */ +/* > \verbatim */ +/* > VL is REAL array, dimension ( M ) */ +/* > On entry, VL(1:NL+1) contains the last components of all */ +/* > right singular vectors of the upper block; and VL(NL+2:M) */ +/* > contains the last components of all right singular vectors */ +/* > of the lower block. On exit, VL contains the last components */ +/* > of all right singular vectors of the bidiagonal matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VLW */ +/* > \verbatim */ +/* > VLW is REAL array, dimension ( M ) */ +/* > Workspace for VL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is REAL */ +/* > Contains the diagonal element associated with the added row. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BETA */ +/* > \verbatim */ +/* > BETA is REAL */ +/* > Contains the off-diagonal element associated with the added */ +/* > row. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DSIGMA */ +/* > \verbatim */ +/* > DSIGMA is REAL array, dimension ( N ) */ +/* > Contains a copy of the diagonal elements (K-1 singular values */ +/* > and one zero) in the secular equation. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IDX */ +/* > \verbatim */ +/* > IDX is INTEGER array, dimension ( N ) */ +/* > This will contain the permutation used to sort the contents of */ +/* > D into ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IDXP */ +/* > \verbatim */ +/* > IDXP is INTEGER array, dimension ( N ) */ +/* > This will contain the permutation used to place deflated */ +/* > values of D at the end of the array. On output IDXP(2:K) */ +/* > points to the nondeflated D-values and IDXP(K+1:N) */ +/* > points to the deflated singular values. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IDXQ */ +/* > \verbatim */ +/* > IDXQ is INTEGER array, dimension ( N ) */ +/* > This contains the permutation which separately sorts the two */ +/* > sub-problems in D into ascending order. Note that entries in */ +/* > the first half of this permutation must first be moved one */ +/* > position backward; and entries in the second half */ +/* > must first have NL+1 added to their values. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PERM */ +/* > \verbatim */ +/* > PERM is INTEGER array, dimension ( N ) */ +/* > The permutations (from deflation and sorting) to be applied */ +/* > to each singular block. Not referenced if ICOMPQ = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] GIVPTR */ +/* > \verbatim */ +/* > GIVPTR is INTEGER */ +/* > The number of Givens rotations which took place in this */ +/* > subproblem. Not referenced if ICOMPQ = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] GIVCOL */ +/* > \verbatim */ +/* > GIVCOL is INTEGER array, dimension ( LDGCOL, 2 ) */ +/* > Each pair of numbers indicates a pair of columns to take place */ +/* > in a Givens rotation. Not referenced if ICOMPQ = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDGCOL */ +/* > \verbatim */ +/* > LDGCOL is INTEGER */ +/* > The leading dimension of GIVCOL, must be at least N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] GIVNUM */ +/* > \verbatim */ +/* > GIVNUM is REAL array, dimension ( LDGNUM, 2 ) */ +/* > Each number indicates the C or S value to be used in the */ +/* > corresponding Givens rotation. Not referenced if ICOMPQ = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDGNUM */ +/* > \verbatim */ +/* > LDGNUM is INTEGER */ +/* > The leading dimension of GIVNUM, must be at least N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] C */ +/* > \verbatim */ +/* > C is REAL */ +/* > C contains garbage if SQRE =0 and the C-value of a Givens */ +/* > rotation related to the right null space if SQRE = 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is REAL */ +/* > S contains garbage if SQRE =0 and the S-value of a Givens */ +/* > rotation related to the right null space if SQRE = 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] 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 OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ming Gu and Huan Ren, Computer Science Division, University of */ +/* > California at Berkeley, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slasd7_(integer *icompq, integer *nl, integer *nr, + integer *sqre, integer *k, real *d__, real *z__, real *zw, real *vf, + real *vfw, real *vl, real *vlw, real *alpha, real *beta, real *dsigma, + integer *idx, integer *idxp, integer *idxq, integer *perm, integer * + givptr, integer *givcol, integer *ldgcol, real *givnum, integer * + ldgnum, real *c__, real *s, integer *info) +{ + /* System generated locals */ + integer givcol_dim1, givcol_offset, givnum_dim1, givnum_offset, i__1; + real r__1, r__2; + + /* Local variables */ + integer idxi, idxj; + extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, + integer *, real *, real *); + integer i__, j, m, n, idxjp, jprev, k2; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + real z1; + extern real slapy2_(real *, real *); + integer jp; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slamrg_( + integer *, integer *, real *, integer *, integer *, integer *); + real hlftol, eps, tau, tol; + integer nlp1, nlp2; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --z__; + --zw; + --vf; + --vfw; + --vl; + --vlw; + --dsigma; + --idx; + --idxp; + --idxq; + --perm; + givcol_dim1 = *ldgcol; + givcol_offset = 1 + givcol_dim1 * 1; + givcol -= givcol_offset; + givnum_dim1 = *ldgnum; + givnum_offset = 1 + givnum_dim1 * 1; + givnum -= givnum_offset; + + /* Function Body */ + *info = 0; + n = *nl + *nr + 1; + m = n + *sqre; + + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*nl < 1) { + *info = -2; + } else if (*nr < 1) { + *info = -3; + } else if (*sqre < 0 || *sqre > 1) { + *info = -4; + } else if (*ldgcol < n) { + *info = -22; + } else if (*ldgnum < n) { + *info = -24; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLASD7", &i__1, (ftnlen)6); + return 0; + } + + nlp1 = *nl + 1; + nlp2 = *nl + 2; + if (*icompq == 1) { + *givptr = 0; + } + +/* Generate the first part of the vector Z and move the singular */ +/* values in the first part of D one position backward. */ + + z1 = *alpha * vl[nlp1]; + vl[nlp1] = 0.f; + tau = vf[nlp1]; + for (i__ = *nl; i__ >= 1; --i__) { + z__[i__ + 1] = *alpha * vl[i__]; + vl[i__] = 0.f; + vf[i__ + 1] = vf[i__]; + d__[i__ + 1] = d__[i__]; + idxq[i__ + 1] = idxq[i__] + 1; +/* L10: */ + } + vf[1] = tau; + +/* Generate the second part of the vector Z. */ + + i__1 = m; + for (i__ = nlp2; i__ <= i__1; ++i__) { + z__[i__] = *beta * vf[i__]; + vf[i__] = 0.f; +/* L20: */ + } + +/* Sort the singular values into increasing order */ + + i__1 = n; + for (i__ = nlp2; i__ <= i__1; ++i__) { + idxq[i__] += nlp1; +/* L30: */ + } + +/* DSIGMA, IDXC, IDXC, and ZW are used as storage space. */ + + i__1 = n; + for (i__ = 2; i__ <= i__1; ++i__) { + dsigma[i__] = d__[idxq[i__]]; + zw[i__] = z__[idxq[i__]]; + vfw[i__] = vf[idxq[i__]]; + vlw[i__] = vl[idxq[i__]]; +/* L40: */ + } + + slamrg_(nl, nr, &dsigma[2], &c__1, &c__1, &idx[2]); + + i__1 = n; + for (i__ = 2; i__ <= i__1; ++i__) { + idxi = idx[i__] + 1; + d__[i__] = dsigma[idxi]; + z__[i__] = zw[idxi]; + vf[i__] = vfw[idxi]; + vl[i__] = vlw[idxi]; +/* L50: */ + } + +/* Calculate the allowable deflation tolerance */ + + eps = slamch_("Epsilon"); +/* Computing MAX */ + r__1 = abs(*alpha), r__2 = abs(*beta); + tol = f2cmax(r__1,r__2); +/* Computing MAX */ + r__2 = (r__1 = d__[n], abs(r__1)); + tol = eps * 64.f * f2cmax(r__2,tol); + +/* There are 2 kinds of deflation -- first a value in the z-vector */ +/* is small, second two (or more) singular values are very close */ +/* together (their difference is small). */ + +/* If the value in the z-vector is small, we simply permute the */ +/* array so that the corresponding singular value is moved to the */ +/* end. */ + +/* If two values in the D-vector are close, we perform a two-sided */ +/* rotation designed to make one of the corresponding z-vector */ +/* entries zero, and then permute the array so that the deflated */ +/* singular value is moved to the end. */ + +/* If there are multiple singular values then the problem deflates. */ +/* Here the number of equal singular values are found. As each equal */ +/* singular value is found, an elementary reflector is computed to */ +/* rotate the corresponding singular subspace so that the */ +/* corresponding components of Z are zero in this new basis. */ + + *k = 1; + k2 = n + 1; + i__1 = n; + for (j = 2; j <= i__1; ++j) { + if ((r__1 = z__[j], abs(r__1)) <= tol) { + +/* Deflate due to small z component. */ + + --k2; + idxp[k2] = j; + if (j == n) { + goto L100; + } + } else { + jprev = j; + goto L70; + } +/* L60: */ + } +L70: + j = jprev; +L80: + ++j; + if (j > n) { + goto L90; + } + if ((r__1 = z__[j], abs(r__1)) <= tol) { + +/* Deflate due to small z component. */ + + --k2; + idxp[k2] = j; + } else { + +/* Check if singular values are close enough to allow deflation. */ + + if ((r__1 = d__[j] - d__[jprev], abs(r__1)) <= tol) { + +/* Deflation is possible. */ + + *s = z__[jprev]; + *c__ = z__[j]; + +/* Find sqrt(a**2+b**2) without overflow or */ +/* destructive underflow. */ + + tau = slapy2_(c__, s); + z__[j] = tau; + z__[jprev] = 0.f; + *c__ /= tau; + *s = -(*s) / tau; + +/* Record the appropriate Givens rotation */ + + if (*icompq == 1) { + ++(*givptr); + idxjp = idxq[idx[jprev] + 1]; + idxj = idxq[idx[j] + 1]; + if (idxjp <= nlp1) { + --idxjp; + } + if (idxj <= nlp1) { + --idxj; + } + givcol[*givptr + (givcol_dim1 << 1)] = idxjp; + givcol[*givptr + givcol_dim1] = idxj; + givnum[*givptr + (givnum_dim1 << 1)] = *c__; + givnum[*givptr + givnum_dim1] = *s; + } + srot_(&c__1, &vf[jprev], &c__1, &vf[j], &c__1, c__, s); + srot_(&c__1, &vl[jprev], &c__1, &vl[j], &c__1, c__, s); + --k2; + idxp[k2] = jprev; + jprev = j; + } else { + ++(*k); + zw[*k] = z__[jprev]; + dsigma[*k] = d__[jprev]; + idxp[*k] = jprev; + jprev = j; + } + } + goto L80; +L90: + +/* Record the last singular value. */ + + ++(*k); + zw[*k] = z__[jprev]; + dsigma[*k] = d__[jprev]; + idxp[*k] = jprev; + +L100: + +/* Sort the singular values into DSIGMA. The singular values which */ +/* were not deflated go into the first K slots of DSIGMA, except */ +/* that DSIGMA(1) is treated separately. */ + + i__1 = n; + for (j = 2; j <= i__1; ++j) { + jp = idxp[j]; + dsigma[j] = d__[jp]; + vfw[j] = vf[jp]; + vlw[j] = vl[jp]; +/* L110: */ + } + if (*icompq == 1) { + i__1 = n; + for (j = 2; j <= i__1; ++j) { + jp = idxp[j]; + perm[j] = idxq[idx[jp] + 1]; + if (perm[j] <= nlp1) { + --perm[j]; + } +/* L120: */ + } + } + +/* The deflated singular values go back into the last N - K slots of */ +/* D. */ + + i__1 = n - *k; + scopy_(&i__1, &dsigma[*k + 1], &c__1, &d__[*k + 1], &c__1); + +/* Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and */ +/* VL(M). */ + + dsigma[1] = 0.f; + hlftol = tol / 2.f; + if (abs(dsigma[2]) <= hlftol) { + dsigma[2] = hlftol; + } + if (m > n) { + z__[1] = slapy2_(&z1, &z__[m]); + if (z__[1] <= tol) { + *c__ = 1.f; + *s = 0.f; + z__[1] = tol; + } else { + *c__ = z1 / z__[1]; + *s = -z__[m] / z__[1]; + } + srot_(&c__1, &vf[m], &c__1, &vf[1], &c__1, c__, s); + srot_(&c__1, &vl[m], &c__1, &vl[1], &c__1, c__, s); + } else { + if (abs(z1) <= tol) { + z__[1] = tol; + } else { + z__[1] = z1; + } + } + +/* Restore Z, VF, and VL. */ + + i__1 = *k - 1; + scopy_(&i__1, &zw[2], &c__1, &z__[2], &c__1); + i__1 = n - 1; + scopy_(&i__1, &vfw[2], &c__1, &vf[2], &c__1); + i__1 = n - 1; + scopy_(&i__1, &vlw[2], &c__1, &vl[2], &c__1); + + return 0; + +/* End of SLASD7 */ + +} /* slasd7_ */ + diff --git a/lapack-netlib/SRC/slasd8.c b/lapack-netlib/SRC/slasd8.c new file mode 100644 index 000000000..5346c0fd1 --- /dev/null +++ b/lapack-netlib/SRC/slasd8.c @@ -0,0 +1,765 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLASD8 finds the square roots of the roots of the secular equation, and stores, for each elemen +t in D, the distance to its two nearest poles. Used by sbdsdc. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASD8 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR, */ +/* DSIGMA, WORK, INFO ) */ + +/* INTEGER ICOMPQ, INFO, K, LDDIFR */ +/* REAL D( * ), DIFL( * ), DIFR( LDDIFR, * ), */ +/* $ DSIGMA( * ), VF( * ), VL( * ), WORK( * ), */ +/* $ Z( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASD8 finds the square roots of the roots of the secular equation, */ +/* > as defined by the values in DSIGMA and Z. It makes the appropriate */ +/* > calls to SLASD4, and stores, for each element in D, the distance */ +/* > to its two nearest poles (elements in DSIGMA). It also updates */ +/* > the arrays VF and VL, the first and last components of all the */ +/* > right singular vectors of the original bidiagonal matrix. */ +/* > */ +/* > SLASD8 is called from SLASD6. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ICOMPQ */ +/* > \verbatim */ +/* > ICOMPQ is INTEGER */ +/* > Specifies whether singular vectors are to be computed in */ +/* > factored form in the calling routine: */ +/* > = 0: Compute singular values only. */ +/* > = 1: Compute singular vectors in factored form as well. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of terms in the rational function to be solved */ +/* > by SLASD4. K >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension ( K ) */ +/* > On output, D contains the updated singular values. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension ( K ) */ +/* > On entry, the first K elements of this array contain the */ +/* > components of the deflation-adjusted updating row vector. */ +/* > On exit, Z is updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VF */ +/* > \verbatim */ +/* > VF is REAL array, dimension ( K ) */ +/* > On entry, VF contains information passed through DBEDE8. */ +/* > On exit, VF contains the first K components of the first */ +/* > components of all right singular vectors of the bidiagonal */ +/* > matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VL */ +/* > \verbatim */ +/* > VL is REAL array, dimension ( K ) */ +/* > On entry, VL contains information passed through DBEDE8. */ +/* > On exit, VL contains the first K components of the last */ +/* > components of all right singular vectors of the bidiagonal */ +/* > matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DIFL */ +/* > \verbatim */ +/* > DIFL is REAL array, dimension ( K ) */ +/* > On exit, DIFL(I) = D(I) - DSIGMA(I). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DIFR */ +/* > \verbatim */ +/* > DIFR is REAL array, */ +/* > dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and */ +/* > dimension ( K ) if ICOMPQ = 0. */ +/* > On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not */ +/* > defined and will not be referenced. */ +/* > */ +/* > If ICOMPQ = 1, DIFR(1:K,2) is an array containing the */ +/* > normalizing factors for the right singular vector matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDDIFR */ +/* > \verbatim */ +/* > LDDIFR is INTEGER */ +/* > The leading dimension of DIFR, must be at least K. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DSIGMA */ +/* > \verbatim */ +/* > DSIGMA is REAL array, dimension ( K ) */ +/* > On entry, the first K elements of this array contain the old */ +/* > roots of the deflated updating problem. These are the poles */ +/* > of the secular equation. */ +/* > On exit, the elements of DSIGMA may be very slightly altered */ +/* > in value. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (3*K) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: if INFO = 1, a singular value did not converge */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ming Gu and Huan Ren, Computer Science Division, University of */ +/* > California at Berkeley, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slasd8_(integer *icompq, integer *k, real *d__, real * + z__, real *vf, real *vl, real *difl, real *difr, integer *lddifr, + real *dsigma, real *work, integer *info) +{ + /* System generated locals */ + integer difr_dim1, difr_offset, i__1, i__2; + real r__1, r__2; + + /* Local variables */ + real temp; + extern real sdot_(integer *, real *, integer *, real *, integer *); + integer iwk2i, iwk3i; + extern real snrm2_(integer *, real *, integer *); + integer i__, j; + real diflj, difrj, dsigj; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + extern real slamc3_(real *, real *); + extern /* Subroutine */ int slasd4_(integer *, integer *, real *, real *, + real *, real *, real *, real *, integer *); + real dj; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real dsigjp; + extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, + real *, integer *, integer *, real *, integer *, integer *), slaset_(char *, integer *, integer *, real *, real *, + real *, integer *); + real rho; + integer iwk1, iwk2, iwk3; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --z__; + --vf; + --vl; + --difl; + difr_dim1 = *lddifr; + difr_offset = 1 + difr_dim1 * 1; + difr -= difr_offset; + --dsigma; + --work; + + /* Function Body */ + *info = 0; + + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*k < 1) { + *info = -2; + } else if (*lddifr < *k) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLASD8", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*k == 1) { + d__[1] = abs(z__[1]); + difl[1] = d__[1]; + if (*icompq == 1) { + difl[2] = 1.f; + difr[(difr_dim1 << 1) + 1] = 1.f; + } + return 0; + } + +/* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can */ +/* be computed with high relative accuracy (barring over/underflow). */ +/* This is a problem on machines without a guard digit in */ +/* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2). */ +/* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I), */ +/* which on any of these machines zeros out the bottommost */ +/* bit of DSIGMA(I) if it is 1; this makes the subsequent */ +/* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation */ +/* occurs. On binary machines with a guard digit (almost all */ +/* machines) it does not change DSIGMA(I) at all. On hexadecimal */ +/* and decimal machines with a guard digit, it slightly */ +/* changes the bottommost bits of DSIGMA(I). It does not account */ +/* for hexadecimal or decimal machines without guard digits */ +/* (we know of none). We use a subroutine call to compute */ +/* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating */ +/* this code. */ + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + dsigma[i__] = slamc3_(&dsigma[i__], &dsigma[i__]) - dsigma[i__]; +/* L10: */ + } + +/* Book keeping. */ + + iwk1 = 1; + iwk2 = iwk1 + *k; + iwk3 = iwk2 + *k; + iwk2i = iwk2 - 1; + iwk3i = iwk3 - 1; + +/* Normalize Z. */ + + rho = snrm2_(k, &z__[1], &c__1); + slascl_("G", &c__0, &c__0, &rho, &c_b8, k, &c__1, &z__[1], k, info); + rho *= rho; + +/* Initialize WORK(IWK3). */ + + slaset_("A", k, &c__1, &c_b8, &c_b8, &work[iwk3], k); + +/* Compute the updated singular values, the arrays DIFL, DIFR, */ +/* and the updated Z. */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + slasd4_(k, &j, &dsigma[1], &z__[1], &work[iwk1], &rho, &d__[j], &work[ + iwk2], info); + +/* If the root finder fails, report the convergence failure. */ + + if (*info != 0) { + return 0; + } + work[iwk3i + j] = work[iwk3i + j] * work[j] * work[iwk2i + j]; + difl[j] = -work[j]; + difr[j + difr_dim1] = -work[j + 1]; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i + + i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[ + j]); +/* L20: */ + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + work[iwk3i + i__] = work[iwk3i + i__] * work[i__] * work[iwk2i + + i__] / (dsigma[i__] - dsigma[j]) / (dsigma[i__] + dsigma[ + j]); +/* L30: */ + } +/* L40: */ + } + +/* Compute updated Z. */ + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + r__2 = sqrt((r__1 = work[iwk3i + i__], abs(r__1))); + z__[i__] = r_sign(&r__2, &z__[i__]); +/* L50: */ + } + +/* Update VF and VL. */ + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + diflj = difl[j]; + dj = d__[j]; + dsigj = -dsigma[j]; + if (j < *k) { + difrj = -difr[j + difr_dim1]; + dsigjp = -dsigma[j + 1]; + } + work[j] = -z__[j] / diflj / (dsigma[j] + dj); + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] = z__[i__] / (slamc3_(&dsigma[i__], &dsigj) - diflj) / ( + dsigma[i__] + dj); +/* L60: */ + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + work[i__] = z__[i__] / (slamc3_(&dsigma[i__], &dsigjp) + difrj) / + (dsigma[i__] + dj); +/* L70: */ + } + temp = snrm2_(k, &work[1], &c__1); + work[iwk2i + j] = sdot_(k, &work[1], &c__1, &vf[1], &c__1) / temp; + work[iwk3i + j] = sdot_(k, &work[1], &c__1, &vl[1], &c__1) / temp; + if (*icompq == 1) { + difr[j + (difr_dim1 << 1)] = temp; + } +/* L80: */ + } + + scopy_(k, &work[iwk2], &c__1, &vf[1], &c__1); + scopy_(k, &work[iwk3], &c__1, &vl[1], &c__1); + + return 0; + +/* End of SLASD8 */ + +} /* slasd8_ */ + diff --git a/lapack-netlib/SRC/slasda.c b/lapack-netlib/SRC/slasda.c new file mode 100644 index 000000000..66fbb330e --- /dev/null +++ b/lapack-netlib/SRC/slasda.c @@ -0,0 +1,967 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLASDA computes the singular value decomposition (SVD) of a real upper bidiagonal matrix with d +iagonal d and off-diagonal e. Used by sbdsdc. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASDA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASDA( ICOMPQ, SMLSIZ, N, SQRE, D, E, U, LDU, VT, K, */ +/* DIFL, DIFR, Z, POLES, GIVPTR, GIVCOL, LDGCOL, */ +/* PERM, GIVNUM, C, S, WORK, IWORK, INFO ) */ + +/* INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE */ +/* INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ), */ +/* $ K( * ), PERM( LDGCOL, * ) */ +/* REAL C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ), */ +/* $ E( * ), GIVNUM( LDU, * ), POLES( LDU, * ), */ +/* $ S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ), */ +/* $ Z( LDU, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Using a divide and conquer approach, SLASDA computes the singular */ +/* > value decomposition (SVD) of a real upper bidiagonal N-by-M matrix */ +/* > B with diagonal D and offdiagonal E, where M = N + SQRE. The */ +/* > algorithm computes the singular values in the SVD B = U * S * VT. */ +/* > The orthogonal matrices U and VT are optionally computed in */ +/* > compact form. */ +/* > */ +/* > A related subroutine, SLASD0, computes the singular values and */ +/* > the singular vectors in explicit form. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ICOMPQ */ +/* > \verbatim */ +/* > ICOMPQ is INTEGER */ +/* > Specifies whether singular vectors are to be computed */ +/* > in compact form, as follows */ +/* > = 0: Compute singular values only. */ +/* > = 1: Compute singular vectors of upper bidiagonal */ +/* > matrix in compact form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SMLSIZ */ +/* > \verbatim */ +/* > SMLSIZ is INTEGER */ +/* > The maximum size of the subproblems at the bottom of the */ +/* > computation tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The row dimension of the upper bidiagonal matrix. This is */ +/* > also the dimension of the main diagonal array D. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SQRE */ +/* > \verbatim */ +/* > SQRE is INTEGER */ +/* > Specifies the column dimension of the bidiagonal matrix. */ +/* > = 0: The bidiagonal matrix has column dimension M = N; */ +/* > = 1: The bidiagonal matrix has column dimension M = N + 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension ( N ) */ +/* > On entry D contains the main diagonal of the bidiagonal */ +/* > matrix. On exit D, if INFO = 0, contains its singular values. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is REAL array, dimension ( M-1 ) */ +/* > Contains the subdiagonal entries of the bidiagonal matrix. */ +/* > On exit, E has been destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] U */ +/* > \verbatim */ +/* > U is REAL array, */ +/* > dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced */ +/* > if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left */ +/* > singular vector matrices of all subproblems at the bottom */ +/* > level. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER, LDU = > N. */ +/* > The leading dimension of arrays U, VT, DIFL, DIFR, POLES, */ +/* > GIVNUM, and Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VT */ +/* > \verbatim */ +/* > VT is REAL array, */ +/* > dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced */ +/* > if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT**T contains the right */ +/* > singular vector matrices of all subproblems at the bottom */ +/* > level. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] K */ +/* > \verbatim */ +/* > K is INTEGER array, dimension ( N ) */ +/* > if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0. */ +/* > If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th */ +/* > secular equation on the computation tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DIFL */ +/* > \verbatim */ +/* > DIFL is REAL array, dimension ( LDU, NLVL ), */ +/* > where NLVL = floor(log_2 (N/SMLSIZ))). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DIFR */ +/* > \verbatim */ +/* > DIFR is REAL array, */ +/* > dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and */ +/* > dimension ( N ) if ICOMPQ = 0. */ +/* > If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1) */ +/* > record distances between singular values on the I-th */ +/* > level and singular values on the (I -1)-th level, and */ +/* > DIFR(1:N, 2 * I ) contains the normalizing factors for */ +/* > the right singular vector matrix. See SLASD8 for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is REAL array, */ +/* > dimension ( LDU, NLVL ) if ICOMPQ = 1 and */ +/* > dimension ( N ) if ICOMPQ = 0. */ +/* > The first K elements of Z(1, I) contain the components of */ +/* > the deflation-adjusted updating row vector for subproblems */ +/* > on the I-th level. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] POLES */ +/* > \verbatim */ +/* > POLES is REAL array, */ +/* > dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced */ +/* > if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and */ +/* > POLES(1, 2*I) contain the new and old singular values */ +/* > involved in the secular equations on the I-th level. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] GIVPTR */ +/* > \verbatim */ +/* > GIVPTR is INTEGER array, */ +/* > dimension ( N ) if ICOMPQ = 1, and not referenced if */ +/* > ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records */ +/* > the number of Givens rotations performed on the I-th */ +/* > problem on the computation tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] GIVCOL */ +/* > \verbatim */ +/* > GIVCOL is INTEGER array, */ +/* > dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not */ +/* > referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, */ +/* > GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations */ +/* > of Givens rotations performed on the I-th level on the */ +/* > computation tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDGCOL */ +/* > \verbatim */ +/* > LDGCOL is INTEGER, LDGCOL = > N. */ +/* > The leading dimension of arrays GIVCOL and PERM. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PERM */ +/* > \verbatim */ +/* > PERM is INTEGER array, dimension ( LDGCOL, NLVL ) */ +/* > if ICOMPQ = 1, and not referenced */ +/* > if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records */ +/* > permutations done on the I-th level of the computation tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] GIVNUM */ +/* > \verbatim */ +/* > GIVNUM is REAL array, */ +/* > dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not */ +/* > referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I, */ +/* > GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S- */ +/* > values of Givens rotations performed on the I-th level on */ +/* > the computation tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] C */ +/* > \verbatim */ +/* > C is REAL array, */ +/* > dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. */ +/* > If ICOMPQ = 1 and the I-th subproblem is not square, on exit, */ +/* > C( I ) contains the C-value of a Givens rotation related to */ +/* > the right null space of the I-th subproblem. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is REAL array, dimension ( N ) if */ +/* > ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1 */ +/* > and the I-th subproblem is not square, on exit, S( I ) */ +/* > contains the S-value of a Givens rotation related to */ +/* > the right null space of the I-th subproblem. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension */ +/* > (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (7*N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: if INFO = 1, a singular value did not converge */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ming Gu and Huan Ren, Computer Science Division, University of */ +/* > California at Berkeley, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slasda_(integer *icompq, integer *smlsiz, integer *n, + integer *sqre, real *d__, real *e, real *u, integer *ldu, real *vt, + integer *k, real *difl, real *difr, real *z__, real *poles, integer * + givptr, integer *givcol, integer *ldgcol, integer *perm, real *givnum, + real *c__, real *s, real *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer givcol_dim1, givcol_offset, perm_dim1, perm_offset, difl_dim1, + difl_offset, difr_dim1, difr_offset, givnum_dim1, givnum_offset, + poles_dim1, poles_offset, u_dim1, u_offset, vt_dim1, vt_offset, + z_dim1, z_offset, i__1, i__2; + + /* Local variables */ + real beta; + integer idxq, nlvl, i__, j, m; + real alpha; + integer inode, ndiml, ndimr, idxqi, itemp, sqrei, i1; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *), slasd6_(integer *, integer *, integer *, integer *, + real *, real *, real *, real *, real *, integer *, integer *, + integer *, integer *, integer *, real *, integer *, real *, real * + , real *, real *, integer *, real *, real *, real *, integer *, + integer *); + integer ic, nwork1, lf, nd, nwork2, ll, nl, vf, nr, vl; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slasdq_( + char *, integer *, integer *, integer *, integer *, integer *, + real *, real *, real *, integer *, real *, integer *, real *, + integer *, real *, integer *), slasdt_(integer *, integer + *, integer *, integer *, integer *, integer *, integer *), + slaset_(char *, integer *, integer *, real *, real *, real *, + integer *); + integer im1, smlszp, ncc, nlf, nrf, vfi, iwk, vli, lvl, nru, ndb1, nlp1, + lvl2, nrp1; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + givnum_dim1 = *ldu; + givnum_offset = 1 + givnum_dim1 * 1; + givnum -= givnum_offset; + poles_dim1 = *ldu; + poles_offset = 1 + poles_dim1 * 1; + poles -= poles_offset; + z_dim1 = *ldu; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + difr_dim1 = *ldu; + difr_offset = 1 + difr_dim1 * 1; + difr -= difr_offset; + difl_dim1 = *ldu; + difl_offset = 1 + difl_dim1 * 1; + difl -= difl_offset; + vt_dim1 = *ldu; + vt_offset = 1 + vt_dim1 * 1; + vt -= vt_offset; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + --k; + --givptr; + perm_dim1 = *ldgcol; + perm_offset = 1 + perm_dim1 * 1; + perm -= perm_offset; + givcol_dim1 = *ldgcol; + givcol_offset = 1 + givcol_dim1 * 1; + givcol -= givcol_offset; + --c__; + --s; + --work; + --iwork; + + /* Function Body */ + *info = 0; + + if (*icompq < 0 || *icompq > 1) { + *info = -1; + } else if (*smlsiz < 3) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*sqre < 0 || *sqre > 1) { + *info = -4; + } else if (*ldu < *n + *sqre) { + *info = -8; + } else if (*ldgcol < *n) { + *info = -17; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLASDA", &i__1, (ftnlen)6); + return 0; + } + + m = *n + *sqre; + +/* If the input matrix is too small, call SLASDQ to find the SVD. */ + + if (*n <= *smlsiz) { + if (*icompq == 0) { + slasdq_("U", sqre, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[ + vt_offset], ldu, &u[u_offset], ldu, &u[u_offset], ldu, & + work[1], info); + } else { + slasdq_("U", sqre, n, &m, n, &c__0, &d__[1], &e[1], &vt[vt_offset] + , ldu, &u[u_offset], ldu, &u[u_offset], ldu, &work[1], + info); + } + return 0; + } + +/* Book-keeping and set up the computation tree. */ + + inode = 1; + ndiml = inode + *n; + ndimr = ndiml + *n; + idxq = ndimr + *n; + iwk = idxq + *n; + + ncc = 0; + nru = 0; + + smlszp = *smlsiz + 1; + vf = 1; + vl = vf + m; + nwork1 = vl + m; + nwork2 = nwork1 + smlszp * smlszp; + + slasdt_(n, &nlvl, &nd, &iwork[inode], &iwork[ndiml], &iwork[ndimr], + smlsiz); + +/* for the nodes on bottom level of the tree, solve */ +/* their subproblems by SLASDQ. */ + + ndb1 = (nd + 1) / 2; + i__1 = nd; + for (i__ = ndb1; i__ <= i__1; ++i__) { + +/* IC : center row of each node */ +/* NL : number of rows of left subproblem */ +/* NR : number of rows of right subproblem */ +/* NLF: starting row of the left subproblem */ +/* NRF: starting row of the right subproblem */ + + i1 = i__ - 1; + ic = iwork[inode + i1]; + nl = iwork[ndiml + i1]; + nlp1 = nl + 1; + nr = iwork[ndimr + i1]; + nlf = ic - nl; + nrf = ic + 1; + idxqi = idxq + nlf - 2; + vfi = vf + nlf - 1; + vli = vl + nlf - 1; + sqrei = 1; + if (*icompq == 0) { + slaset_("A", &nlp1, &nlp1, &c_b11, &c_b12, &work[nwork1], &smlszp); + slasdq_("U", &sqrei, &nl, &nlp1, &nru, &ncc, &d__[nlf], &e[nlf], & + work[nwork1], &smlszp, &work[nwork2], &nl, &work[nwork2], + &nl, &work[nwork2], info); + itemp = nwork1 + nl * smlszp; + scopy_(&nlp1, &work[nwork1], &c__1, &work[vfi], &c__1); + scopy_(&nlp1, &work[itemp], &c__1, &work[vli], &c__1); + } else { + slaset_("A", &nl, &nl, &c_b11, &c_b12, &u[nlf + u_dim1], ldu); + slaset_("A", &nlp1, &nlp1, &c_b11, &c_b12, &vt[nlf + vt_dim1], + ldu); + slasdq_("U", &sqrei, &nl, &nlp1, &nl, &ncc, &d__[nlf], &e[nlf], & + vt[nlf + vt_dim1], ldu, &u[nlf + u_dim1], ldu, &u[nlf + + u_dim1], ldu, &work[nwork1], info); + scopy_(&nlp1, &vt[nlf + vt_dim1], &c__1, &work[vfi], &c__1); + scopy_(&nlp1, &vt[nlf + nlp1 * vt_dim1], &c__1, &work[vli], &c__1) + ; + } + if (*info != 0) { + return 0; + } + i__2 = nl; + for (j = 1; j <= i__2; ++j) { + iwork[idxqi + j] = j; +/* L10: */ + } + if (i__ == nd && *sqre == 0) { + sqrei = 0; + } else { + sqrei = 1; + } + idxqi += nlp1; + vfi += nlp1; + vli += nlp1; + nrp1 = nr + sqrei; + if (*icompq == 0) { + slaset_("A", &nrp1, &nrp1, &c_b11, &c_b12, &work[nwork1], &smlszp); + slasdq_("U", &sqrei, &nr, &nrp1, &nru, &ncc, &d__[nrf], &e[nrf], & + work[nwork1], &smlszp, &work[nwork2], &nr, &work[nwork2], + &nr, &work[nwork2], info); + itemp = nwork1 + (nrp1 - 1) * smlszp; + scopy_(&nrp1, &work[nwork1], &c__1, &work[vfi], &c__1); + scopy_(&nrp1, &work[itemp], &c__1, &work[vli], &c__1); + } else { + slaset_("A", &nr, &nr, &c_b11, &c_b12, &u[nrf + u_dim1], ldu); + slaset_("A", &nrp1, &nrp1, &c_b11, &c_b12, &vt[nrf + vt_dim1], + ldu); + slasdq_("U", &sqrei, &nr, &nrp1, &nr, &ncc, &d__[nrf], &e[nrf], & + vt[nrf + vt_dim1], ldu, &u[nrf + u_dim1], ldu, &u[nrf + + u_dim1], ldu, &work[nwork1], info); + scopy_(&nrp1, &vt[nrf + vt_dim1], &c__1, &work[vfi], &c__1); + scopy_(&nrp1, &vt[nrf + nrp1 * vt_dim1], &c__1, &work[vli], &c__1) + ; + } + if (*info != 0) { + return 0; + } + i__2 = nr; + for (j = 1; j <= i__2; ++j) { + iwork[idxqi + j] = j; +/* L20: */ + } +/* L30: */ + } + +/* Now conquer each subproblem bottom-up. */ + + j = pow_ii(&c__2, &nlvl); + for (lvl = nlvl; lvl >= 1; --lvl) { + lvl2 = (lvl << 1) - 1; + +/* Find the first node LF and last node LL on */ +/* the current level LVL. */ + + if (lvl == 1) { + lf = 1; + ll = 1; + } else { + i__1 = lvl - 1; + lf = pow_ii(&c__2, &i__1); + ll = (lf << 1) - 1; + } + i__1 = ll; + for (i__ = lf; i__ <= i__1; ++i__) { + im1 = i__ - 1; + ic = iwork[inode + im1]; + nl = iwork[ndiml + im1]; + nr = iwork[ndimr + im1]; + nlf = ic - nl; + nrf = ic + 1; + if (i__ == ll) { + sqrei = *sqre; + } else { + sqrei = 1; + } + vfi = vf + nlf - 1; + vli = vl + nlf - 1; + idxqi = idxq + nlf - 1; + alpha = d__[ic]; + beta = e[ic]; + if (*icompq == 0) { + slasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], & + work[vli], &alpha, &beta, &iwork[idxqi], &perm[ + perm_offset], &givptr[1], &givcol[givcol_offset], + ldgcol, &givnum[givnum_offset], ldu, &poles[ + poles_offset], &difl[difl_offset], &difr[difr_offset], + &z__[z_offset], &k[1], &c__[1], &s[1], &work[nwork1], + &iwork[iwk], info); + } else { + --j; + slasd6_(icompq, &nl, &nr, &sqrei, &d__[nlf], &work[vfi], & + work[vli], &alpha, &beta, &iwork[idxqi], &perm[nlf + + lvl * perm_dim1], &givptr[j], &givcol[nlf + lvl2 * + givcol_dim1], ldgcol, &givnum[nlf + lvl2 * + givnum_dim1], ldu, &poles[nlf + lvl2 * poles_dim1], & + difl[nlf + lvl * difl_dim1], &difr[nlf + lvl2 * + difr_dim1], &z__[nlf + lvl * z_dim1], &k[j], &c__[j], + &s[j], &work[nwork1], &iwork[iwk], info); + } + if (*info != 0) { + return 0; + } +/* L40: */ + } +/* L50: */ + } + + return 0; + +/* End of SLASDA */ + +} /* slasda_ */ + diff --git a/lapack-netlib/SRC/slasdq.c b/lapack-netlib/SRC/slasdq.c new file mode 100644 index 000000000..f2a4b543c --- /dev/null +++ b/lapack-netlib/SRC/slasdq.c @@ -0,0 +1,837 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#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 SLASDQ computes the SVD of a real bidiagonal matrix with diagonal d and off-diagonal e. Used by + sbdsdc. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASDQ + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT, */ +/* U, LDU, C, LDC, WORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE */ +/* REAL C( LDC, * ), D( * ), E( * ), U( LDU, * ), */ +/* $ VT( LDVT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASDQ computes the singular value decomposition (SVD) of a real */ +/* > (upper or lower) bidiagonal matrix with diagonal D and offdiagonal */ +/* > E, accumulating the transformations if desired. Letting B denote */ +/* > the input bidiagonal matrix, the algorithm computes orthogonal */ +/* > matrices Q and P such that B = Q * S * P**T (P**T denotes the transpose */ +/* > of P). The singular values S are overwritten on D. */ +/* > */ +/* > The input matrix U is changed to U * Q if desired. */ +/* > The input matrix VT is changed to P**T * VT if desired. */ +/* > The input matrix C is changed to Q**T * C if desired. */ +/* > */ +/* > See "Computing Small Singular Values of Bidiagonal Matrices With */ +/* > Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, */ +/* > LAPACK Working Note #3, for a detailed description of the algorithm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > On entry, UPLO specifies whether the input bidiagonal matrix */ +/* > is upper or lower bidiagonal, and whether it is square are */ +/* > not. */ +/* > UPLO = 'U' or 'u' B is upper bidiagonal. */ +/* > UPLO = 'L' or 'l' B is lower bidiagonal. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SQRE */ +/* > \verbatim */ +/* > SQRE is INTEGER */ +/* > = 0: then the input matrix is N-by-N. */ +/* > = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and */ +/* > (N+1)-by-N if UPLU = 'L'. */ +/* > */ +/* > The bidiagonal matrix has */ +/* > N = NL + NR + 1 rows and */ +/* > M = N + SQRE >= N columns. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > On entry, N specifies the number of rows and columns */ +/* > in the matrix. N must be at least 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NCVT */ +/* > \verbatim */ +/* > NCVT is INTEGER */ +/* > On entry, NCVT specifies the number of columns of */ +/* > the matrix VT. NCVT must be at least 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRU */ +/* > \verbatim */ +/* > NRU is INTEGER */ +/* > On entry, NRU specifies the number of rows of */ +/* > the matrix U. NRU must be at least 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NCC */ +/* > \verbatim */ +/* > NCC is INTEGER */ +/* > On entry, NCC specifies the number of columns of */ +/* > the matrix C. NCC must be at least 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry, D contains the diagonal entries of the */ +/* > bidiagonal matrix whose SVD is desired. On normal exit, */ +/* > D contains the singular values in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is REAL array. */ +/* > dimension is (N-1) if SQRE = 0 and N if SQRE = 1. */ +/* > On entry, the entries of E contain the offdiagonal entries */ +/* > of the bidiagonal matrix whose SVD is desired. On normal */ +/* > exit, E will contain 0. If the algorithm does not converge, */ +/* > D and E will contain the diagonal and superdiagonal entries */ +/* > of a bidiagonal matrix orthogonally equivalent to the one */ +/* > given as input. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VT */ +/* > \verbatim */ +/* > VT is REAL array, dimension (LDVT, NCVT) */ +/* > On entry, contains a matrix which on exit has been */ +/* > premultiplied by P**T, dimension N-by-NCVT if SQRE = 0 */ +/* > and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVT */ +/* > \verbatim */ +/* > LDVT is INTEGER */ +/* > On entry, LDVT specifies the leading dimension of VT as */ +/* > declared in the calling (sub) program. LDVT must be at */ +/* > least 1. If NCVT is nonzero LDVT must also be at least N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] U */ +/* > \verbatim */ +/* > U is REAL array, dimension (LDU, N) */ +/* > On entry, contains a matrix which on exit has been */ +/* > postmultiplied by Q, dimension NRU-by-N if SQRE = 0 */ +/* > and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > On entry, LDU specifies the leading dimension of U as */ +/* > declared in the calling (sub) program. LDU must be at */ +/* > least f2cmax( 1, NRU ) . */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (LDC, NCC) */ +/* > On entry, contains an N-by-NCC matrix which on exit */ +/* > has been premultiplied by Q**T dimension N-by-NCC if SQRE = 0 */ +/* > and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > On entry, LDC specifies the leading dimension of C as */ +/* > declared in the calling (sub) program. LDC must be at */ +/* > least 1. If NCC is nonzero, LDC must also be at least N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (4*N) */ +/* > Workspace. Only referenced if one of NCVT, NRU, or NCC is */ +/* > nonzero, and if N is at least 2. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > On exit, a value of 0 indicates a successful exit. */ +/* > If INFO < 0, argument number -INFO is illegal. */ +/* > If INFO > 0, the algorithm did not converge, and INFO */ +/* > specifies how many superdiagonals did not converge. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ming Gu and Huan Ren, Computer Science Division, University of */ +/* > California at Berkeley, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slasdq_(char *uplo, integer *sqre, integer *n, integer * + ncvt, integer *nru, integer *ncc, real *d__, real *e, real *vt, + integer *ldvt, real *u, integer *ldu, real *c__, integer *ldc, real * + work, integer *info) +{ + /* System generated locals */ + integer c_dim1, c_offset, u_dim1, u_offset, vt_dim1, vt_offset, i__1, + i__2; + + /* Local variables */ + integer isub; + real smin; + integer sqre1, i__, j; + real r__; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int slasr_(char *, char *, char *, integer *, + integer *, real *, real *, real *, integer *); + integer iuplo; + extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, + integer *); + real cs, sn; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slartg_( + real *, real *, real *, real *, real *); + logical rotate; + extern /* Subroutine */ int sbdsqr_(char *, integer *, integer *, integer + *, integer *, real *, real *, real *, integer *, real *, integer * + , real *, integer *, real *, integer *); + integer np1; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input 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; + --work; + + /* Function Body */ + *info = 0; + iuplo = 0; + if (lsame_(uplo, "U")) { + iuplo = 1; + } + if (lsame_(uplo, "L")) { + iuplo = 2; + } + if (iuplo == 0) { + *info = -1; + } else if (*sqre < 0 || *sqre > 1) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ncvt < 0) { + *info = -4; + } else if (*nru < 0) { + *info = -5; + } else if (*ncc < 0) { + *info = -6; + } else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < f2cmax(1,*n)) { + *info = -10; + } else if (*ldu < f2cmax(1,*nru)) { + *info = -12; + } else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < f2cmax(1,*n)) { + *info = -14; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLASDQ", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + +/* ROTATE is true if any singular vectors desired, false otherwise */ + + rotate = *ncvt > 0 || *nru > 0 || *ncc > 0; + np1 = *n + 1; + sqre1 = *sqre; + +/* If matrix non-square upper bidiagonal, rotate to be lower */ +/* bidiagonal. The rotations are on the right. */ + + if (iuplo == 1 && sqre1 == 1) { + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + slartg_(&d__[i__], &e[i__], &cs, &sn, &r__); + d__[i__] = r__; + e[i__] = sn * d__[i__ + 1]; + d__[i__ + 1] = cs * d__[i__ + 1]; + if (rotate) { + work[i__] = cs; + work[*n + i__] = sn; + } +/* L10: */ + } + slartg_(&d__[*n], &e[*n], &cs, &sn, &r__); + d__[*n] = r__; + e[*n] = 0.f; + if (rotate) { + work[*n] = cs; + work[*n + *n] = sn; + } + iuplo = 2; + sqre1 = 0; + +/* Update singular vectors if desired. */ + + if (*ncvt > 0) { + slasr_("L", "V", "F", &np1, ncvt, &work[1], &work[np1], &vt[ + vt_offset], ldvt); + } + } + +/* If matrix lower bidiagonal, rotate to be upper bidiagonal */ +/* by applying Givens rotations on the left. */ + + if (iuplo == 2) { + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + slartg_(&d__[i__], &e[i__], &cs, &sn, &r__); + d__[i__] = r__; + e[i__] = sn * d__[i__ + 1]; + d__[i__ + 1] = cs * d__[i__ + 1]; + if (rotate) { + work[i__] = cs; + work[*n + i__] = sn; + } +/* L20: */ + } + +/* If matrix (N+1)-by-N lower bidiagonal, one additional */ +/* rotation is needed. */ + + if (sqre1 == 1) { + slartg_(&d__[*n], &e[*n], &cs, &sn, &r__); + d__[*n] = r__; + if (rotate) { + work[*n] = cs; + work[*n + *n] = sn; + } + } + +/* Update singular vectors if desired. */ + + if (*nru > 0) { + if (sqre1 == 0) { + slasr_("R", "V", "F", nru, n, &work[1], &work[np1], &u[ + u_offset], ldu); + } else { + slasr_("R", "V", "F", nru, &np1, &work[1], &work[np1], &u[ + u_offset], ldu); + } + } + if (*ncc > 0) { + if (sqre1 == 0) { + slasr_("L", "V", "F", n, ncc, &work[1], &work[np1], &c__[ + c_offset], ldc); + } else { + slasr_("L", "V", "F", &np1, ncc, &work[1], &work[np1], &c__[ + c_offset], ldc); + } + } + } + +/* Call SBDSQR to compute the SVD of the reduced real */ +/* N-by-N upper bidiagonal matrix. */ + + sbdsqr_("U", n, ncvt, nru, ncc, &d__[1], &e[1], &vt[vt_offset], ldvt, &u[ + u_offset], ldu, &c__[c_offset], ldc, &work[1], info); + +/* Sort the singular values into ascending order (insertion sort on */ +/* singular values, but only one transposition per singular vector) */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Scan for smallest D(I). */ + + isub = i__; + smin = d__[i__]; + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + if (d__[j] < smin) { + isub = j; + smin = d__[j]; + } +/* L30: */ + } + if (isub != i__) { + +/* Swap singular values and vectors. */ + + d__[isub] = d__[i__]; + d__[i__] = smin; + if (*ncvt > 0) { + sswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[i__ + vt_dim1], + ldvt); + } + if (*nru > 0) { + sswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[i__ * u_dim1 + 1] + , &c__1); + } + if (*ncc > 0) { + sswap_(ncc, &c__[isub + c_dim1], ldc, &c__[i__ + c_dim1], ldc) + ; + } + } +/* L40: */ + } + + return 0; + +/* End of SLASDQ */ + +} /* slasdq_ */ + diff --git a/lapack-netlib/SRC/slasdt.c b/lapack-netlib/SRC/slasdt.c new file mode 100644 index 000000000..824b2eaf9 --- /dev/null +++ b/lapack-netlib/SRC/slasdt.c @@ -0,0 +1,562 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLASDT creates a tree of subproblems for bidiagonal divide and conquer. Used by sbdsdc. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASDT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB ) */ + +/* INTEGER LVL, MSUB, N, ND */ +/* INTEGER INODE( * ), NDIML( * ), NDIMR( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASDT creates a tree of subproblems for bidiagonal divide and */ +/* > conquer. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > On entry, the number of diagonal elements of the */ +/* > bidiagonal matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] LVL */ +/* > \verbatim */ +/* > LVL is INTEGER */ +/* > On exit, the number of levels on the computation tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ND */ +/* > \verbatim */ +/* > ND is INTEGER */ +/* > On exit, the number of nodes on the tree. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INODE */ +/* > \verbatim */ +/* > INODE is INTEGER array, dimension ( N ) */ +/* > On exit, centers of subproblems. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] NDIML */ +/* > \verbatim */ +/* > NDIML is INTEGER array, dimension ( N ) */ +/* > On exit, row dimensions of left children. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] NDIMR */ +/* > \verbatim */ +/* > NDIMR is INTEGER array, dimension ( N ) */ +/* > On exit, row dimensions of right children. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MSUB */ +/* > \verbatim */ +/* > MSUB is INTEGER */ +/* > On entry, the maximum row dimension each subproblem at the */ +/* > bottom of the tree can be of. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ming Gu and Huan Ren, Computer Science Division, University of */ +/* > California at Berkeley, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slasdt_(integer *n, integer *lvl, integer *nd, integer * + inode, integer *ndiml, integer *ndimr, integer *msub) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer maxn; + real temp; + integer nlvl, llst, i__, ncrnt, il, ir; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Find the number of levels on the tree. */ + + /* Parameter adjustments */ + --ndimr; + --ndiml; + --inode; + + /* Function Body */ + maxn = f2cmax(1,*n); + temp = log((real) maxn / (real) (*msub + 1)) / log(2.f); + *lvl = (integer) temp + 1; + + i__ = *n / 2; + inode[1] = i__ + 1; + ndiml[1] = i__; + ndimr[1] = *n - i__ - 1; + il = 0; + ir = 1; + llst = 1; + i__1 = *lvl - 1; + for (nlvl = 1; nlvl <= i__1; ++nlvl) { + +/* Constructing the tree at (NLVL+1)-st level. The number of */ +/* nodes created on this level is LLST * 2. */ + + i__2 = llst - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + il += 2; + ir += 2; + ncrnt = llst + i__; + ndiml[il] = ndiml[ncrnt] / 2; + ndimr[il] = ndiml[ncrnt] - ndiml[il] - 1; + inode[il] = inode[ncrnt] - ndimr[il] - 1; + ndiml[ir] = ndimr[ncrnt] / 2; + ndimr[ir] = ndimr[ncrnt] - ndiml[ir] - 1; + inode[ir] = inode[ncrnt] + ndiml[ir] + 1; +/* L10: */ + } + llst <<= 1; +/* L20: */ + } + *nd = (llst << 1) - 1; + + return 0; + +/* End of SLASDT */ + +} /* slasdt_ */ + diff --git a/lapack-netlib/SRC/slaset.c b/lapack-netlib/SRC/slaset.c new file mode 100644 index 000000000..d94373461 --- /dev/null +++ b/lapack-netlib/SRC/slaset.c @@ -0,0 +1,585 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given val +ues. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASET + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASET( UPLO, M, N, ALPHA, BETA, A, LDA ) */ + +/* CHARACTER UPLO */ +/* INTEGER LDA, M, N */ +/* REAL ALPHA, BETA */ +/* REAL A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASET initializes an m-by-n matrix A to BETA on the diagonal and */ +/* > ALPHA on the offdiagonals. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies the part of the matrix A to be set. */ +/* > = 'U': Upper triangular part is set; the strictly lower */ +/* > triangular part of A is not changed. */ +/* > = 'L': Lower triangular part is set; the strictly upper */ +/* > triangular part of A is not changed. */ +/* > Otherwise: All of the matrix A is set. */ +/* > \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] ALPHA */ +/* > \verbatim */ +/* > ALPHA is REAL */ +/* > The constant to which the offdiagonal elements are to be set. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BETA */ +/* > \verbatim */ +/* > BETA is REAL */ +/* > The constant to which the diagonal elements are to be set. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On exit, the leading m-by-n submatrix of A is set as follows: */ +/* > */ +/* > if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, */ +/* > if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, */ +/* > otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, */ +/* > */ +/* > and, for all UPLO, A(i,i) = BETA, 1<=i<=f2cmin(m,n). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slaset_(char *uplo, integer *m, integer *n, real *alpha, + real *beta, real *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + if (lsame_(uplo, "U")) { + +/* Set the strictly upper triangular or trapezoidal part of the */ +/* array to ALPHA. */ + + i__1 = *n; + for (j = 2; j <= i__1; ++j) { +/* Computing MIN */ + i__3 = j - 1; + i__2 = f2cmin(i__3,*m); + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = *alpha; +/* L10: */ + } +/* L20: */ + } + + } else if (lsame_(uplo, "L")) { + +/* Set the strictly lower triangular or trapezoidal part of the */ +/* array to ALPHA. */ + + i__1 = f2cmin(*m,*n); + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = j + 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = *alpha; +/* L30: */ + } +/* L40: */ + } + + } else { + +/* Set the leading m-by-n submatrix to ALPHA. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = *alpha; +/* L50: */ + } +/* L60: */ + } + } + +/* Set the first f2cmin(M,N) diagonal elements to BETA. */ + + i__1 = f2cmin(*m,*n); + for (i__ = 1; i__ <= i__1; ++i__) { + a[i__ + i__ * a_dim1] = *beta; +/* L70: */ + } + + return 0; + +/* End of SLASET */ + +} /* slaset_ */ + diff --git a/lapack-netlib/SRC/slasq1.c b/lapack-netlib/SRC/slasq1.c new file mode 100644 index 000000000..ec6f32726 --- /dev/null +++ b/lapack-netlib/SRC/slasq1.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 SLASQ1 computes the singular values of a real square bidiagonal matrix. Used by sbdsqr. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASQ1 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASQ1( N, D, E, WORK, INFO ) */ + +/* INTEGER INFO, N */ +/* REAL D( * ), E( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASQ1 computes the singular values of a real N-by-N bidiagonal */ +/* > matrix with diagonal D and off-diagonal E. The singular values */ +/* > are computed to high relative accuracy, in the absence of */ +/* > denormalization, underflow and overflow. The algorithm was first */ +/* > presented in */ +/* > */ +/* > "Accurate singular values and differential qd algorithms" by K. V. */ +/* > Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230, */ +/* > 1994, */ +/* > */ +/* > and the present implementation is described in "An implementation of */ +/* > the dqds Algorithm (Positive Case)", LAPACK Working Note. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of rows and columns in the matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry, D contains the diagonal elements of the */ +/* > bidiagonal matrix whose SVD is desired. On normal exit, */ +/* > D contains the singular values in decreasing order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (N) */ +/* > On entry, elements E(1:N-1) contain the off-diagonal elements */ +/* > of the bidiagonal matrix whose SVD is desired. */ +/* > On exit, E is overwritten. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL 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 failed */ +/* > = 1, a split was marked by a positive value in E */ +/* > = 2, current block of Z not diagonalized after 100*N */ +/* > iterations (in inner while loop) On exit D and E */ +/* > represent a matrix with the same singular values */ +/* > which the calling subroutine could use to finish the */ +/* > computation, or even feed back into SLASQ1 */ +/* > = 3, termination criterion of outer while loop not met */ +/* > (program created more than N unreduced blocks) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int slasq1_(integer *n, real *d__, real *e, real *work, + integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + real r__1, r__2, r__3; + + /* Local variables */ + extern /* Subroutine */ int slas2_(real *, real *, real *, real *, real *) + ; + integer i__; + real scale; + integer iinfo; + real sigmn, sigmx; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *), slasq2_(integer *, real *, integer *); + extern real slamch_(char *); + real safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slascl_( + char *, integer *, integer *, real *, real *, integer *, integer * + , real *, integer *, integer *), slasrt_(char *, integer * + , real *, 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 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --work; + --e; + --d__; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + i__1 = -(*info); + xerbla_("SLASQ1", &i__1, (ftnlen)6); + return 0; + } else if (*n == 0) { + return 0; + } else if (*n == 1) { + d__[1] = abs(d__[1]); + return 0; + } else if (*n == 2) { + slas2_(&d__[1], &e[1], &d__[2], &sigmn, &sigmx); + d__[1] = sigmx; + d__[2] = sigmn; + return 0; + } + +/* Estimate the largest singular value. */ + + sigmx = 0.f; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = (r__1 = d__[i__], abs(r__1)); +/* Computing MAX */ + r__2 = sigmx, r__3 = (r__1 = e[i__], abs(r__1)); + sigmx = f2cmax(r__2,r__3); +/* L10: */ + } + d__[*n] = (r__1 = d__[*n], abs(r__1)); + +/* Early return if SIGMX is zero (matrix is already diagonal). */ + + if (sigmx == 0.f) { + slasrt_("D", n, &d__[1], &iinfo); + return 0; + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + r__1 = sigmx, r__2 = d__[i__]; + sigmx = f2cmax(r__1,r__2); +/* L20: */ + } + +/* Copy D and E into WORK (in the Z format) and scale (squaring the */ +/* input data makes scaling by a power of the radix pointless). */ + + eps = slamch_("Precision"); + safmin = slamch_("Safe minimum"); + scale = sqrt(eps / safmin); + scopy_(n, &d__[1], &c__1, &work[1], &c__2); + i__1 = *n - 1; + scopy_(&i__1, &e[1], &c__1, &work[2], &c__2); + i__1 = (*n << 1) - 1; + i__2 = (*n << 1) - 1; + slascl_("G", &c__0, &c__0, &sigmx, &scale, &i__1, &c__1, &work[1], &i__2, + &iinfo); + +/* Compute the q's and e's. */ + + i__1 = (*n << 1) - 1; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing 2nd power */ + r__1 = work[i__]; + work[i__] = r__1 * r__1; +/* L30: */ + } + work[*n * 2] = 0.f; + + slasq2_(n, &work[1], info); + + if (*info == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = sqrt(work[i__]); +/* L40: */ + } + slascl_("G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, & + iinfo); + } else if (*info == 2) { + +/* Maximum number of iterations exceeded. Move data from WORK */ +/* into D and E so the calling subroutine can try to finish */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = sqrt(work[(i__ << 1) - 1]); + e[i__] = sqrt(work[i__ * 2]); + } + slascl_("G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &d__[1], n, & + iinfo); + slascl_("G", &c__0, &c__0, &scale, &sigmx, n, &c__1, &e[1], n, &iinfo); + } + + return 0; + +/* End of SLASQ1 */ + +} /* slasq1_ */ + diff --git a/lapack-netlib/SRC/slasq2.c b/lapack-netlib/SRC/slasq2.c new file mode 100644 index 000000000..5debac99c --- /dev/null +++ b/lapack-netlib/SRC/slasq2.c @@ -0,0 +1,1064 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLASQ2 computes all the eigenvalues of the symmetric positive definite tridiagonal matrix assoc +iated with the qd Array Z to high relative accuracy. Used by sbdsqr and sstegr. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASQ2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASQ2( N, Z, INFO ) */ + +/* INTEGER INFO, N */ +/* REAL Z( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASQ2 computes all the eigenvalues of the symmetric positive */ +/* > definite tridiagonal matrix associated with the qd array Z to high */ +/* > relative accuracy are computed to high relative accuracy, in the */ +/* > absence of denormalization, underflow and overflow. */ +/* > */ +/* > To see the relation of Z to the tridiagonal matrix, let L be a */ +/* > unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and */ +/* > let U be an upper bidiagonal matrix with 1's above and diagonal */ +/* > Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the */ +/* > symmetric tridiagonal to which it is similar. */ +/* > */ +/* > Note : SLASQ2 defines a logical variable, IEEE, which is true */ +/* > on machines which follow ieee-754 floating-point standard in their */ +/* > handling of infinities and NaNs, and false otherwise. This variable */ +/* > is passed to SLASQ3. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of rows and columns in the matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension ( 4*N ) */ +/* > On entry Z holds the qd array. On exit, entries 1 to N hold */ +/* > the eigenvalues in decreasing order, Z( 2*N+1 ) holds the */ +/* > trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If */ +/* > N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 ) */ +/* > holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of */ +/* > shifts that failed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if the i-th argument is a scalar and had an illegal */ +/* > value, then INFO = -i, if the i-th argument is an */ +/* > array and the j-entry had an illegal value, then */ +/* > INFO = -(i*100+j) */ +/* > > 0: the algorithm failed */ +/* > = 1, a split was marked by a positive value in E */ +/* > = 2, current block of Z not diagonalized after 100*N */ +/* > iterations (in inner while loop). On exit Z holds */ +/* > a qd array with the same eigenvalues as the given Z. */ +/* > = 3, termination criterion of outer while loop not met */ +/* > (program created more than N unreduced blocks) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Local Variables: I0:N0 defines a current unreduced segment of Z. */ +/* > The shifts are accumulated in SIGMA. Iteration count is in ITER. */ +/* > Ping-pong is controlled by PP (alternates between 0 and 1). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slasq2_(integer *n, real *z__, integer *info) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + real r__1, r__2; + + /* Local variables */ + logical ieee; + integer nbig; + real dmin__, emin, emax; + integer kmin, ndiv, iter; + real qmin, temp, qmax, zmax; + integer splt; + real dmin1, dmin2, d__, e, g; + integer k; + real s, t; + integer nfail; + real desig, trace, sigma; + integer iinfo; + real tempe, tempq; + integer i0, i1, i4, n0, n1, ttype; + extern /* Subroutine */ int slasq3_(integer *, integer *, real *, integer + *, real *, real *, real *, real *, integer *, integer *, integer * + , logical *, integer *, real *, real *, real *, real *, real *, + real *, real *); + real dn; + integer pp; + real deemin; + extern real slamch_(char *); + integer iwhila, iwhilb; + real oldemn, safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real dn1, dn2; + extern /* Subroutine */ int slasrt_(char *, integer *, real *, integer *); + real dee, eps, tau, tol; + integer ipn4; + real tol2; + + +/* -- 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. */ +/* (in case SLASQ2 is not called by SLASQ1) */ + + /* Parameter adjustments */ + --z__; + + /* Function Body */ + *info = 0; + eps = slamch_("Precision"); + safmin = slamch_("Safe minimum"); + tol = eps * 100.f; +/* Computing 2nd power */ + r__1 = tol; + tol2 = r__1 * r__1; + + if (*n < 0) { + *info = -1; + xerbla_("SLASQ2", &c__1, (ftnlen)6); + return 0; + } else if (*n == 0) { + return 0; + } else if (*n == 1) { + +/* 1-by-1 case. */ + + if (z__[1] < 0.f) { + *info = -201; + xerbla_("SLASQ2", &c__2, (ftnlen)6); + } + return 0; + } else if (*n == 2) { + +/* 2-by-2 case. */ + + if (z__[1] < 0.f) { + *info = -201; + xerbla_("SLASQ2", &c__2, (ftnlen)6); + return 0; + } else if (z__[2] < 0.f) { + *info = -202; + xerbla_("SLASQ2", &c__2, (ftnlen)6); + return 0; + } else if (z__[3] < 0.f) { + *info = -203; + xerbla_("SLASQ2", &c__2, (ftnlen)6); + return 0; + } else if (z__[3] > z__[1]) { + d__ = z__[3]; + z__[3] = z__[1]; + z__[1] = d__; + } + z__[5] = z__[1] + z__[2] + z__[3]; + if (z__[2] > z__[3] * tol2) { + t = (z__[1] - z__[3] + z__[2]) * .5f; + s = z__[3] * (z__[2] / t); + if (s <= t) { + s = z__[3] * (z__[2] / (t * (sqrt(s / t + 1.f) + 1.f))); + } else { + s = z__[3] * (z__[2] / (t + sqrt(t) * sqrt(t + s))); + } + t = z__[1] + (s + z__[2]); + z__[3] *= z__[1] / t; + z__[1] = t; + } + z__[2] = z__[3]; + z__[6] = z__[2] + z__[1]; + return 0; + } + +/* Check for negative data and compute sums of q's and e's. */ + + z__[*n * 2] = 0.f; + emin = z__[2]; + qmax = 0.f; + zmax = 0.f; + d__ = 0.f; + e = 0.f; + + i__1 = *n - 1 << 1; + for (k = 1; k <= i__1; k += 2) { + if (z__[k] < 0.f) { + *info = -(k + 200); + xerbla_("SLASQ2", &c__2, (ftnlen)6); + return 0; + } else if (z__[k + 1] < 0.f) { + *info = -(k + 201); + xerbla_("SLASQ2", &c__2, (ftnlen)6); + return 0; + } + d__ += z__[k]; + e += z__[k + 1]; +/* Computing MAX */ + r__1 = qmax, r__2 = z__[k]; + qmax = f2cmax(r__1,r__2); +/* Computing MIN */ + r__1 = emin, r__2 = z__[k + 1]; + emin = f2cmin(r__1,r__2); +/* Computing MAX */ + r__1 = f2cmax(qmax,zmax), r__2 = z__[k + 1]; + zmax = f2cmax(r__1,r__2); +/* L10: */ + } + if (z__[(*n << 1) - 1] < 0.f) { + *info = -((*n << 1) + 199); + xerbla_("SLASQ2", &c__2, (ftnlen)6); + return 0; + } + d__ += z__[(*n << 1) - 1]; +/* Computing MAX */ + r__1 = qmax, r__2 = z__[(*n << 1) - 1]; + qmax = f2cmax(r__1,r__2); + zmax = f2cmax(qmax,zmax); + +/* Check for diagonality. */ + + if (e == 0.f) { + i__1 = *n; + for (k = 2; k <= i__1; ++k) { + z__[k] = z__[(k << 1) - 1]; +/* L20: */ + } + slasrt_("D", n, &z__[1], &iinfo); + z__[(*n << 1) - 1] = d__; + return 0; + } + + trace = d__ + e; + +/* Check for zero data. */ + + if (trace == 0.f) { + z__[(*n << 1) - 1] = 0.f; + return 0; + } + +/* Check whether the machine is IEEE conformable. */ + +/* IEEE = ILAENV( 10, 'SLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND. */ +/* $ ILAENV( 11, 'SLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 */ + +/* [11/15/2008] The case IEEE=.TRUE. has a problem in single precision with */ +/* some the test matrices of type 16. The double precision code is fine. */ + + ieee = FALSE_; + +/* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...). */ + + for (k = *n << 1; k >= 2; k += -2) { + z__[k * 2] = 0.f; + z__[(k << 1) - 1] = z__[k]; + z__[(k << 1) - 2] = 0.f; + z__[(k << 1) - 3] = z__[k - 1]; +/* L30: */ + } + + i0 = 1; + n0 = *n; + +/* Reverse the qd-array, if warranted. */ + + if (z__[(i0 << 2) - 3] * 1.5f < z__[(n0 << 2) - 3]) { + ipn4 = i0 + n0 << 2; + i__1 = i0 + n0 - 1 << 1; + for (i4 = i0 << 2; i4 <= i__1; i4 += 4) { + temp = z__[i4 - 3]; + z__[i4 - 3] = z__[ipn4 - i4 - 3]; + z__[ipn4 - i4 - 3] = temp; + temp = z__[i4 - 1]; + z__[i4 - 1] = z__[ipn4 - i4 - 5]; + z__[ipn4 - i4 - 5] = temp; +/* L40: */ + } + } + +/* Initial split checking via dqd and Li's test. */ + + pp = 0; + + for (k = 1; k <= 2; ++k) { + + d__ = z__[(n0 << 2) + pp - 3]; + i__1 = (i0 << 2) + pp; + for (i4 = (n0 - 1 << 2) + pp; i4 >= i__1; i4 += -4) { + if (z__[i4 - 1] <= tol2 * d__) { + z__[i4 - 1] = 0.f; + d__ = z__[i4 - 3]; + } else { + d__ = z__[i4 - 3] * (d__ / (d__ + z__[i4 - 1])); + } +/* L50: */ + } + +/* dqd maps Z to ZZ plus Li's test. */ + + emin = z__[(i0 << 2) + pp + 1]; + d__ = z__[(i0 << 2) + pp - 3]; + i__1 = (n0 - 1 << 2) + pp; + for (i4 = (i0 << 2) + pp; i4 <= i__1; i4 += 4) { + z__[i4 - (pp << 1) - 2] = d__ + z__[i4 - 1]; + if (z__[i4 - 1] <= tol2 * d__) { + z__[i4 - 1] = 0.f; + z__[i4 - (pp << 1) - 2] = d__; + z__[i4 - (pp << 1)] = 0.f; + d__ = z__[i4 + 1]; + } else if (safmin * z__[i4 + 1] < z__[i4 - (pp << 1) - 2] && + safmin * z__[i4 - (pp << 1) - 2] < z__[i4 + 1]) { + temp = z__[i4 + 1] / z__[i4 - (pp << 1) - 2]; + z__[i4 - (pp << 1)] = z__[i4 - 1] * temp; + d__ *= temp; + } else { + z__[i4 - (pp << 1)] = z__[i4 + 1] * (z__[i4 - 1] / z__[i4 - ( + pp << 1) - 2]); + d__ = z__[i4 + 1] * (d__ / z__[i4 - (pp << 1) - 2]); + } +/* Computing MIN */ + r__1 = emin, r__2 = z__[i4 - (pp << 1)]; + emin = f2cmin(r__1,r__2); +/* L60: */ + } + z__[(n0 << 2) - pp - 2] = d__; + +/* Now find qmax. */ + + qmax = z__[(i0 << 2) - pp - 2]; + i__1 = (n0 << 2) - pp - 2; + for (i4 = (i0 << 2) - pp + 2; i4 <= i__1; i4 += 4) { +/* Computing MAX */ + r__1 = qmax, r__2 = z__[i4]; + qmax = f2cmax(r__1,r__2); +/* L70: */ + } + +/* Prepare for the next iteration on K. */ + + pp = 1 - pp; +/* L80: */ + } + +/* Initialise variables to pass to SLASQ3. */ + + ttype = 0; + dmin1 = 0.f; + dmin2 = 0.f; + dn = 0.f; + dn1 = 0.f; + dn2 = 0.f; + g = 0.f; + tau = 0.f; + + iter = 2; + nfail = 0; + ndiv = n0 - i0 << 1; + + i__1 = *n + 1; + for (iwhila = 1; iwhila <= i__1; ++iwhila) { + if (n0 < 1) { + goto L170; + } + +/* While array unfinished do */ + +/* E(N0) holds the value of SIGMA when submatrix in I0:N0 */ +/* splits from the rest of the array, but is negated. */ + + desig = 0.f; + if (n0 == *n) { + sigma = 0.f; + } else { + sigma = -z__[(n0 << 2) - 1]; + } + if (sigma < 0.f) { + *info = 1; + return 0; + } + +/* Find last unreduced submatrix's top index I0, find QMAX and */ +/* EMIN. Find Gershgorin-type bound if Q's much greater than E's. */ + + emax = 0.f; + if (n0 > i0) { + emin = (r__1 = z__[(n0 << 2) - 5], abs(r__1)); + } else { + emin = 0.f; + } + qmin = z__[(n0 << 2) - 3]; + qmax = qmin; + for (i4 = n0 << 2; i4 >= 8; i4 += -4) { + if (z__[i4 - 5] <= 0.f) { + goto L100; + } + if (qmin >= emax * 4.f) { +/* Computing MIN */ + r__1 = qmin, r__2 = z__[i4 - 3]; + qmin = f2cmin(r__1,r__2); +/* Computing MAX */ + r__1 = emax, r__2 = z__[i4 - 5]; + emax = f2cmax(r__1,r__2); + } +/* Computing MAX */ + r__1 = qmax, r__2 = z__[i4 - 7] + z__[i4 - 5]; + qmax = f2cmax(r__1,r__2); +/* Computing MIN */ + r__1 = emin, r__2 = z__[i4 - 5]; + emin = f2cmin(r__1,r__2); +/* L90: */ + } + i4 = 4; + +L100: + i0 = i4 / 4; + pp = 0; + + if (n0 - i0 > 1) { + dee = z__[(i0 << 2) - 3]; + deemin = dee; + kmin = i0; + i__2 = (n0 << 2) - 3; + for (i4 = (i0 << 2) + 1; i4 <= i__2; i4 += 4) { + dee = z__[i4] * (dee / (dee + z__[i4 - 2])); + if (dee <= deemin) { + deemin = dee; + kmin = (i4 + 3) / 4; + } +/* L110: */ + } + if (kmin - i0 << 1 < n0 - kmin && deemin <= z__[(n0 << 2) - 3] * + .5f) { + ipn4 = i0 + n0 << 2; + pp = 2; + i__2 = i0 + n0 - 1 << 1; + for (i4 = i0 << 2; i4 <= i__2; i4 += 4) { + temp = z__[i4 - 3]; + z__[i4 - 3] = z__[ipn4 - i4 - 3]; + z__[ipn4 - i4 - 3] = temp; + temp = z__[i4 - 2]; + z__[i4 - 2] = z__[ipn4 - i4 - 2]; + z__[ipn4 - i4 - 2] = temp; + temp = z__[i4 - 1]; + z__[i4 - 1] = z__[ipn4 - i4 - 5]; + z__[ipn4 - i4 - 5] = temp; + temp = z__[i4]; + z__[i4] = z__[ipn4 - i4 - 4]; + z__[ipn4 - i4 - 4] = temp; +/* L120: */ + } + } + } + +/* Put -(initial shift) into DMIN. */ + +/* Computing MAX */ + r__1 = 0.f, r__2 = qmin - sqrt(qmin) * 2.f * sqrt(emax); + dmin__ = -f2cmax(r__1,r__2); + +/* Now I0:N0 is unreduced. */ +/* PP = 0 for ping, PP = 1 for pong. */ +/* PP = 2 indicates that flipping was applied to the Z array and */ +/* and that the tests for deflation upon entry in SLASQ3 */ +/* should not be performed. */ + + nbig = (n0 - i0 + 1) * 100; + i__2 = nbig; + for (iwhilb = 1; iwhilb <= i__2; ++iwhilb) { + if (i0 > n0) { + goto L150; + } + +/* While submatrix unfinished take a good dqds step. */ + + slasq3_(&i0, &n0, &z__[1], &pp, &dmin__, &sigma, &desig, &qmax, & + nfail, &iter, &ndiv, &ieee, &ttype, &dmin1, &dmin2, &dn, & + dn1, &dn2, &g, &tau); + + pp = 1 - pp; + +/* When EMIN is very small check for splits. */ + + if (pp == 0 && n0 - i0 >= 3) { + if (z__[n0 * 4] <= tol2 * qmax || z__[(n0 << 2) - 1] <= tol2 * + sigma) { + splt = i0 - 1; + qmax = z__[(i0 << 2) - 3]; + emin = z__[(i0 << 2) - 1]; + oldemn = z__[i0 * 4]; + i__3 = n0 - 3 << 2; + for (i4 = i0 << 2; i4 <= i__3; i4 += 4) { + if (z__[i4] <= tol2 * z__[i4 - 3] || z__[i4 - 1] <= + tol2 * sigma) { + z__[i4 - 1] = -sigma; + splt = i4 / 4; + qmax = 0.f; + emin = z__[i4 + 3]; + oldemn = z__[i4 + 4]; + } else { +/* Computing MAX */ + r__1 = qmax, r__2 = z__[i4 + 1]; + qmax = f2cmax(r__1,r__2); +/* Computing MIN */ + r__1 = emin, r__2 = z__[i4 - 1]; + emin = f2cmin(r__1,r__2); +/* Computing MIN */ + r__1 = oldemn, r__2 = z__[i4]; + oldemn = f2cmin(r__1,r__2); + } +/* L130: */ + } + z__[(n0 << 2) - 1] = emin; + z__[n0 * 4] = oldemn; + i0 = splt + 1; + } + } + +/* L140: */ + } + + *info = 2; + +/* Maximum number of iterations exceeded, restore the shift */ +/* SIGMA and place the new d's and e's in a qd array. */ +/* This might need to be done for several blocks */ + + i1 = i0; + n1 = n0; +L145: + tempq = z__[(i0 << 2) - 3]; + z__[(i0 << 2) - 3] += sigma; + i__2 = n0; + for (k = i0 + 1; k <= i__2; ++k) { + tempe = z__[(k << 2) - 5]; + z__[(k << 2) - 5] *= tempq / z__[(k << 2) - 7]; + tempq = z__[(k << 2) - 3]; + z__[(k << 2) - 3] = z__[(k << 2) - 3] + sigma + tempe - z__[(k << + 2) - 5]; + } + +/* Prepare to do this on the previous block if there is one */ + + if (i1 > 1) { + n1 = i1 - 1; + while(i1 >= 2 && z__[(i1 << 2) - 5] >= 0.f) { + --i1; + } + if (i1 >= 1) { + sigma = -z__[(n1 << 2) - 1]; + goto L145; + } + } + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + z__[(k << 1) - 1] = z__[(k << 2) - 3]; + +/* Only the block 1..N0 is unfinished. The rest of the e's */ +/* must be essentially zero, although sometimes other data */ +/* has been stored in them. */ + + if (k < n0) { + z__[k * 2] = z__[(k << 2) - 1]; + } else { + z__[k * 2] = 0.f; + } + } + return 0; + +/* end IWHILB */ + +L150: + +/* L160: */ + ; + } + + *info = 3; + return 0; + +/* end IWHILA */ + +L170: + +/* Move q's to the front. */ + + i__1 = *n; + for (k = 2; k <= i__1; ++k) { + z__[k] = z__[(k << 2) - 3]; +/* L180: */ + } + +/* Sort and compute sum of eigenvalues. */ + + slasrt_("D", n, &z__[1], &iinfo); + + e = 0.f; + for (k = *n; k >= 1; --k) { + e += z__[k]; +/* L190: */ + } + +/* Store trace, sum(eigenvalues) and information on performance. */ + + z__[(*n << 1) + 1] = trace; + z__[(*n << 1) + 2] = e; + z__[(*n << 1) + 3] = (real) iter; +/* Computing 2nd power */ + i__1 = *n; + z__[(*n << 1) + 4] = (real) ndiv / (real) (i__1 * i__1); + z__[(*n << 1) + 5] = nfail * 100.f / (real) iter; + return 0; + +/* End of SLASQ2 */ + +} /* slasq2_ */ + diff --git a/lapack-netlib/SRC/slasq3.c b/lapack-netlib/SRC/slasq3.c new file mode 100644 index 000000000..7426a9b7b --- /dev/null +++ b/lapack-netlib/SRC/slasq3.c @@ -0,0 +1,821 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLASQ3 checks for deflation, computes a shift and calls dqds. Used by sbdsqr. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASQ3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL, */ +/* ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1, */ +/* DN2, G, TAU ) */ + +/* LOGICAL IEEE */ +/* INTEGER I0, ITER, N0, NDIV, NFAIL, PP */ +/* REAL DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, */ +/* $ QMAX, SIGMA, TAU */ +/* REAL Z( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASQ3 checks for deflation, computes a shift (TAU) and calls dqds. */ +/* > In case of failure it changes shifts, and tries again until output */ +/* > is positive. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] I0 */ +/* > \verbatim */ +/* > I0 is INTEGER */ +/* > First index. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] N0 */ +/* > \verbatim */ +/* > N0 is INTEGER */ +/* > Last index. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension ( 4*N0 ) */ +/* > Z holds the qd array. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] PP */ +/* > \verbatim */ +/* > PP is INTEGER */ +/* > PP=0 for ping, PP=1 for pong. */ +/* > PP=2 indicates that flipping was applied to the Z array */ +/* > and that the initial tests for deflation should not be */ +/* > performed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DMIN */ +/* > \verbatim */ +/* > DMIN is REAL */ +/* > Minimum value of d. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SIGMA */ +/* > \verbatim */ +/* > SIGMA is REAL */ +/* > Sum of shifts used in current segment. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DESIG */ +/* > \verbatim */ +/* > DESIG is REAL */ +/* > Lower order part of SIGMA */ +/* > \endverbatim */ +/* > */ +/* > \param[in] QMAX */ +/* > \verbatim */ +/* > QMAX is REAL */ +/* > Maximum value of q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] NFAIL */ +/* > \verbatim */ +/* > NFAIL is INTEGER */ +/* > Increment NFAIL by 1 each time the shift was too big. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ITER */ +/* > \verbatim */ +/* > ITER is INTEGER */ +/* > Increment ITER by 1 for each iteration. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] NDIV */ +/* > \verbatim */ +/* > NDIV is INTEGER */ +/* > Increment NDIV by 1 for each division. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IEEE */ +/* > \verbatim */ +/* > IEEE is LOGICAL */ +/* > Flag for IEEE or non IEEE arithmetic (passed to SLASQ5). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] TTYPE */ +/* > \verbatim */ +/* > TTYPE is INTEGER */ +/* > Shift type. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DMIN1 */ +/* > \verbatim */ +/* > DMIN1 is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DMIN2 */ +/* > \verbatim */ +/* > DMIN2 is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DN */ +/* > \verbatim */ +/* > DN is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DN1 */ +/* > \verbatim */ +/* > DN1 is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] DN2 */ +/* > \verbatim */ +/* > DN2 is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] G */ +/* > \verbatim */ +/* > G is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] TAU */ +/* > \verbatim */ +/* > TAU is REAL */ +/* > */ +/* > These are passed as arguments in order to save their values */ +/* > between calls to SLASQ3. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int slasq3_(integer *i0, integer *n0, real *z__, integer *pp, + real *dmin__, real *sigma, real *desig, real *qmax, integer *nfail, + integer *iter, integer *ndiv, logical *ieee, integer *ttype, real * + dmin1, real *dmin2, real *dn, real *dn1, real *dn2, real *g, real * + tau) +{ + /* System generated locals */ + integer i__1; + real r__1, r__2; + + /* Local variables */ + real temp, s, t; + integer j4; + extern /* Subroutine */ int slasq4_(integer *, integer *, real *, integer + *, integer *, real *, real *, real *, real *, real *, real *, + real *, integer *, real *), slasq5_(integer *, integer *, real *, + integer *, real *, real *, real *, real *, real *, real *, real *, + real *, logical *, real *), slasq6_(integer *, integer *, real *, + integer *, real *, real *, real *, real *, real *, real *); + integer nn; + extern real slamch_(char *); + extern logical sisnan_(real *); + real eps, tol; + integer n0in, ipn4; + real tol2; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --z__; + + /* Function Body */ + n0in = *n0; + eps = slamch_("Precision"); + tol = eps * 100.f; +/* Computing 2nd power */ + r__1 = tol; + tol2 = r__1 * r__1; + +/* Check for deflation. */ + +L10: + + if (*n0 < *i0) { + return 0; + } + if (*n0 == *i0) { + goto L20; + } + nn = (*n0 << 2) + *pp; + if (*n0 == *i0 + 1) { + goto L40; + } + +/* Check whether E(N0-1) is negligible, 1 eigenvalue. */ + + if (z__[nn - 5] > tol2 * (*sigma + z__[nn - 3]) && z__[nn - (*pp << 1) - + 4] > tol2 * z__[nn - 7]) { + goto L30; + } + +L20: + + z__[(*n0 << 2) - 3] = z__[(*n0 << 2) + *pp - 3] + *sigma; + --(*n0); + goto L10; + +/* Check whether E(N0-2) is negligible, 2 eigenvalues. */ + +L30: + + if (z__[nn - 9] > tol2 * *sigma && z__[nn - (*pp << 1) - 8] > tol2 * z__[ + nn - 11]) { + goto L50; + } + +L40: + + if (z__[nn - 3] > z__[nn - 7]) { + s = z__[nn - 3]; + z__[nn - 3] = z__[nn - 7]; + z__[nn - 7] = s; + } + t = (z__[nn - 7] - z__[nn - 3] + z__[nn - 5]) * .5f; + if (z__[nn - 5] > z__[nn - 3] * tol2 && t != 0.f) { + s = z__[nn - 3] * (z__[nn - 5] / t); + if (s <= t) { + s = z__[nn - 3] * (z__[nn - 5] / (t * (sqrt(s / t + 1.f) + 1.f))); + } else { + s = z__[nn - 3] * (z__[nn - 5] / (t + sqrt(t) * sqrt(t + s))); + } + t = z__[nn - 7] + (s + z__[nn - 5]); + z__[nn - 3] *= z__[nn - 7] / t; + z__[nn - 7] = t; + } + z__[(*n0 << 2) - 7] = z__[nn - 7] + *sigma; + z__[(*n0 << 2) - 3] = z__[nn - 3] + *sigma; + *n0 += -2; + goto L10; + +L50: + if (*pp == 2) { + *pp = 0; + } + +/* Reverse the qd-array, if warranted. */ + + if (*dmin__ <= 0.f || *n0 < n0in) { + if (z__[(*i0 << 2) + *pp - 3] * 1.5f < z__[(*n0 << 2) + *pp - 3]) { + ipn4 = *i0 + *n0 << 2; + i__1 = *i0 + *n0 - 1 << 1; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + temp = z__[j4 - 3]; + z__[j4 - 3] = z__[ipn4 - j4 - 3]; + z__[ipn4 - j4 - 3] = temp; + temp = z__[j4 - 2]; + z__[j4 - 2] = z__[ipn4 - j4 - 2]; + z__[ipn4 - j4 - 2] = temp; + temp = z__[j4 - 1]; + z__[j4 - 1] = z__[ipn4 - j4 - 5]; + z__[ipn4 - j4 - 5] = temp; + temp = z__[j4]; + z__[j4] = z__[ipn4 - j4 - 4]; + z__[ipn4 - j4 - 4] = temp; +/* L60: */ + } + if (*n0 - *i0 <= 4) { + z__[(*n0 << 2) + *pp - 1] = z__[(*i0 << 2) + *pp - 1]; + z__[(*n0 << 2) - *pp] = z__[(*i0 << 2) - *pp]; + } +/* Computing MIN */ + r__1 = *dmin2, r__2 = z__[(*n0 << 2) + *pp - 1]; + *dmin2 = f2cmin(r__1,r__2); +/* Computing MIN */ + r__1 = z__[(*n0 << 2) + *pp - 1], r__2 = z__[(*i0 << 2) + *pp - 1] + , r__1 = f2cmin(r__1,r__2), r__2 = z__[(*i0 << 2) + *pp + 3]; + z__[(*n0 << 2) + *pp - 1] = f2cmin(r__1,r__2); +/* Computing MIN */ + r__1 = z__[(*n0 << 2) - *pp], r__2 = z__[(*i0 << 2) - *pp], r__1 = + f2cmin(r__1,r__2), r__2 = z__[(*i0 << 2) - *pp + 4]; + z__[(*n0 << 2) - *pp] = f2cmin(r__1,r__2); +/* Computing MAX */ + r__1 = *qmax, r__2 = z__[(*i0 << 2) + *pp - 3], r__1 = f2cmax(r__1, + r__2), r__2 = z__[(*i0 << 2) + *pp + 1]; + *qmax = f2cmax(r__1,r__2); + *dmin__ = 0.f; + } + } + +/* Choose a shift. */ + + slasq4_(i0, n0, &z__[1], pp, &n0in, dmin__, dmin1, dmin2, dn, dn1, dn2, + tau, ttype, g); + +/* Call dqds until DMIN > 0. */ + +L70: + + slasq5_(i0, n0, &z__[1], pp, tau, sigma, dmin__, dmin1, dmin2, dn, dn1, + dn2, ieee, &eps); + + *ndiv += *n0 - *i0 + 2; + ++(*iter); + +/* Check status. */ + + if (*dmin__ >= 0.f && *dmin1 >= 0.f) { + +/* Success. */ + + goto L90; + + } else if (*dmin__ < 0.f && *dmin1 > 0.f && z__[(*n0 - 1 << 2) - *pp] < + tol * (*sigma + *dn1) && abs(*dn) < tol * *sigma) { + +/* Convergence hidden by negative DN. */ + + z__[(*n0 - 1 << 2) - *pp + 2] = 0.f; + *dmin__ = 0.f; + goto L90; + } else if (*dmin__ < 0.f) { + +/* TAU too big. Select new TAU and try again. */ + + ++(*nfail); + if (*ttype < -22) { + +/* Failed twice. Play it safe. */ + + *tau = 0.f; + } else if (*dmin1 > 0.f) { + +/* Late failure. Gives excellent shift. */ + + *tau = (*tau + *dmin__) * (1.f - eps * 2.f); + *ttype += -11; + } else { + +/* Early failure. Divide by 4. */ + + *tau *= .25f; + *ttype += -12; + } + goto L70; + } else if (sisnan_(dmin__)) { + +/* NaN. */ + + if (*tau == 0.f) { + goto L80; + } else { + *tau = 0.f; + goto L70; + } + } else { + +/* Possible underflow. Play it safe. */ + + goto L80; + } + +/* Risk of underflow. */ + +L80: + slasq6_(i0, n0, &z__[1], pp, dmin__, dmin1, dmin2, dn, dn1, dn2); + *ndiv += *n0 - *i0 + 2; + ++(*iter); + *tau = 0.f; + +L90: + if (*tau < *sigma) { + *desig += *tau; + t = *sigma + *desig; + *desig -= t - *sigma; + } else { + t = *sigma + *tau; + *desig = *sigma - (t - *tau) + *desig; + } + *sigma = t; + + return 0; + +/* End of SLASQ3 */ + +} /* slasq3_ */ + diff --git a/lapack-netlib/SRC/slasq4.c b/lapack-netlib/SRC/slasq4.c new file mode 100644 index 000000000..8351c72d8 --- /dev/null +++ b/lapack-netlib/SRC/slasq4.c @@ -0,0 +1,853 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SLASQ4 computes an approximation to the smallest eigenvalue using values of d from the previous + transform. Used by sbdsqr. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASQ4 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, */ +/* DN1, DN2, TAU, TTYPE, G ) */ + +/* INTEGER I0, N0, N0IN, PP, TTYPE */ +/* REAL DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU */ +/* REAL Z( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASQ4 computes an approximation TAU to the smallest eigenvalue */ +/* > using values of d from the previous transform. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] I0 */ +/* > \verbatim */ +/* > I0 is INTEGER */ +/* > First index. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N0 */ +/* > \verbatim */ +/* > N0 is INTEGER */ +/* > Last index. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension ( 4*N0 ) */ +/* > Z holds the qd array. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PP */ +/* > \verbatim */ +/* > PP is INTEGER */ +/* > PP=0 for ping, PP=1 for pong. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N0IN */ +/* > \verbatim */ +/* > N0IN is INTEGER */ +/* > The value of N0 at start of EIGTEST. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DMIN */ +/* > \verbatim */ +/* > DMIN is REAL */ +/* > Minimum value of d. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DMIN1 */ +/* > \verbatim */ +/* > DMIN1 is REAL */ +/* > Minimum value of d, excluding D( N0 ). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DMIN2 */ +/* > \verbatim */ +/* > DMIN2 is REAL */ +/* > Minimum value of d, excluding D( N0 ) and D( N0-1 ). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DN */ +/* > \verbatim */ +/* > DN is REAL */ +/* > d(N) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DN1 */ +/* > \verbatim */ +/* > DN1 is REAL */ +/* > d(N-1) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DN2 */ +/* > \verbatim */ +/* > DN2 is REAL */ +/* > d(N-2) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is REAL */ +/* > This is the shift. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TTYPE */ +/* > \verbatim */ +/* > TTYPE is INTEGER */ +/* > Shift type. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] G */ +/* > \verbatim */ +/* > G is REAL */ +/* > G is passed as an argument in order to save its value between */ +/* > calls to SLASQ4. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > CNST1 = 9/16 */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slasq4_(integer *i0, integer *n0, real *z__, integer *pp, + integer *n0in, real *dmin__, real *dmin1, real *dmin2, real *dn, + real *dn1, real *dn2, real *tau, integer *ttype, real *g) +{ + /* System generated locals */ + integer i__1; + real r__1, r__2; + + /* Local variables */ + real s, a2, b1, b2; + integer i4, nn, np; + real gam, gap1, gap2; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* A negative DMIN forces the shift to take that absolute value */ +/* TTYPE records the type of shift. */ + + /* Parameter adjustments */ + --z__; + + /* Function Body */ + if (*dmin__ <= 0.f) { + *tau = -(*dmin__); + *ttype = -1; + return 0; + } + + nn = (*n0 << 2) + *pp; + if (*n0in == *n0) { + +/* No eigenvalues deflated. */ + + if (*dmin__ == *dn || *dmin__ == *dn1) { + + b1 = sqrt(z__[nn - 3]) * sqrt(z__[nn - 5]); + b2 = sqrt(z__[nn - 7]) * sqrt(z__[nn - 9]); + a2 = z__[nn - 7] + z__[nn - 5]; + +/* Cases 2 and 3. */ + + if (*dmin__ == *dn && *dmin1 == *dn1) { + gap2 = *dmin2 - a2 - *dmin2 * .25f; + if (gap2 > 0.f && gap2 > b2) { + gap1 = a2 - *dn - b2 / gap2 * b2; + } else { + gap1 = a2 - *dn - (b1 + b2); + } + if (gap1 > 0.f && gap1 > b1) { +/* Computing MAX */ + r__1 = *dn - b1 / gap1 * b1, r__2 = *dmin__ * .5f; + s = f2cmax(r__1,r__2); + *ttype = -2; + } else { + s = 0.f; + if (*dn > b1) { + s = *dn - b1; + } + if (a2 > b1 + b2) { +/* Computing MIN */ + r__1 = s, r__2 = a2 - (b1 + b2); + s = f2cmin(r__1,r__2); + } +/* Computing MAX */ + r__1 = s, r__2 = *dmin__ * .333f; + s = f2cmax(r__1,r__2); + *ttype = -3; + } + } else { + +/* Case 4. */ + + *ttype = -4; + s = *dmin__ * .25f; + if (*dmin__ == *dn) { + gam = *dn; + a2 = 0.f; + if (z__[nn - 5] > z__[nn - 7]) { + return 0; + } + b2 = z__[nn - 5] / z__[nn - 7]; + np = nn - 9; + } else { + np = nn - (*pp << 1); + gam = *dn1; + if (z__[np - 4] > z__[np - 2]) { + return 0; + } + a2 = z__[np - 4] / z__[np - 2]; + if (z__[nn - 9] > z__[nn - 11]) { + return 0; + } + b2 = z__[nn - 9] / z__[nn - 11]; + np = nn - 13; + } + +/* Approximate contribution to norm squared from I < NN-1. */ + + a2 += b2; + i__1 = (*i0 << 2) - 1 + *pp; + for (i4 = np; i4 >= i__1; i4 += -4) { + if (b2 == 0.f) { + goto L20; + } + b1 = b2; + if (z__[i4] > z__[i4 - 2]) { + return 0; + } + b2 *= z__[i4] / z__[i4 - 2]; + a2 += b2; + if (f2cmax(b2,b1) * 100.f < a2 || .563f < a2) { + goto L20; + } +/* L10: */ + } +L20: + a2 *= 1.05f; + +/* Rayleigh quotient residual bound. */ + + if (a2 < .563f) { + s = gam * (1.f - sqrt(a2)) / (a2 + 1.f); + } + } + } else if (*dmin__ == *dn2) { + +/* Case 5. */ + + *ttype = -5; + s = *dmin__ * .25f; + +/* Compute contribution to norm squared from I > NN-2. */ + + np = nn - (*pp << 1); + b1 = z__[np - 2]; + b2 = z__[np - 6]; + gam = *dn2; + if (z__[np - 8] > b2 || z__[np - 4] > b1) { + return 0; + } + a2 = z__[np - 8] / b2 * (z__[np - 4] / b1 + 1.f); + +/* Approximate contribution to norm squared from I < NN-2. */ + + if (*n0 - *i0 > 2) { + b2 = z__[nn - 13] / z__[nn - 15]; + a2 += b2; + i__1 = (*i0 << 2) - 1 + *pp; + for (i4 = nn - 17; i4 >= i__1; i4 += -4) { + if (b2 == 0.f) { + goto L40; + } + b1 = b2; + if (z__[i4] > z__[i4 - 2]) { + return 0; + } + b2 *= z__[i4] / z__[i4 - 2]; + a2 += b2; + if (f2cmax(b2,b1) * 100.f < a2 || .563f < a2) { + goto L40; + } +/* L30: */ + } +L40: + a2 *= 1.05f; + } + + if (a2 < .563f) { + s = gam * (1.f - sqrt(a2)) / (a2 + 1.f); + } + } else { + +/* Case 6, no information to guide us. */ + + if (*ttype == -6) { + *g += (1.f - *g) * .333f; + } else if (*ttype == -18) { + *g = .083250000000000005f; + } else { + *g = .25f; + } + s = *g * *dmin__; + *ttype = -6; + } + + } else if (*n0in == *n0 + 1) { + +/* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. */ + + if (*dmin1 == *dn1 && *dmin2 == *dn2) { + +/* Cases 7 and 8. */ + + *ttype = -7; + s = *dmin1 * .333f; + if (z__[nn - 5] > z__[nn - 7]) { + return 0; + } + b1 = z__[nn - 5] / z__[nn - 7]; + b2 = b1; + if (b2 == 0.f) { + goto L60; + } + i__1 = (*i0 << 2) - 1 + *pp; + for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) { + a2 = b1; + if (z__[i4] > z__[i4 - 2]) { + return 0; + } + b1 *= z__[i4] / z__[i4 - 2]; + b2 += b1; + if (f2cmax(b1,a2) * 100.f < b2) { + goto L60; + } +/* L50: */ + } +L60: + b2 = sqrt(b2 * 1.05f); +/* Computing 2nd power */ + r__1 = b2; + a2 = *dmin1 / (r__1 * r__1 + 1.f); + gap2 = *dmin2 * .5f - a2; + if (gap2 > 0.f && gap2 > b2 * a2) { +/* Computing MAX */ + r__1 = s, r__2 = a2 * (1.f - a2 * 1.01f * (b2 / gap2) * b2); + s = f2cmax(r__1,r__2); + } else { +/* Computing MAX */ + r__1 = s, r__2 = a2 * (1.f - b2 * 1.01f); + s = f2cmax(r__1,r__2); + *ttype = -8; + } + } else { + +/* Case 9. */ + + s = *dmin1 * .25f; + if (*dmin1 == *dn1) { + s = *dmin1 * .5f; + } + *ttype = -9; + } + + } else if (*n0in == *n0 + 2) { + +/* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. */ + +/* Cases 10 and 11. */ + + if (*dmin2 == *dn2 && z__[nn - 5] * 2.f < z__[nn - 7]) { + *ttype = -10; + s = *dmin2 * .333f; + if (z__[nn - 5] > z__[nn - 7]) { + return 0; + } + b1 = z__[nn - 5] / z__[nn - 7]; + b2 = b1; + if (b2 == 0.f) { + goto L80; + } + i__1 = (*i0 << 2) - 1 + *pp; + for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) { + if (z__[i4] > z__[i4 - 2]) { + return 0; + } + b1 *= z__[i4] / z__[i4 - 2]; + b2 += b1; + if (b1 * 100.f < b2) { + goto L80; + } +/* L70: */ + } +L80: + b2 = sqrt(b2 * 1.05f); +/* Computing 2nd power */ + r__1 = b2; + a2 = *dmin2 / (r__1 * r__1 + 1.f); + gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[ + nn - 9]) - a2; + if (gap2 > 0.f && gap2 > b2 * a2) { +/* Computing MAX */ + r__1 = s, r__2 = a2 * (1.f - a2 * 1.01f * (b2 / gap2) * b2); + s = f2cmax(r__1,r__2); + } else { +/* Computing MAX */ + r__1 = s, r__2 = a2 * (1.f - b2 * 1.01f); + s = f2cmax(r__1,r__2); + } + } else { + s = *dmin2 * .25f; + *ttype = -11; + } + } else if (*n0in > *n0 + 2) { + +/* Case 12, more than two eigenvalues deflated. No information. */ + + s = 0.f; + *ttype = -12; + } + + *tau = s; + return 0; + +/* End of SLASQ4 */ + +} /* slasq4_ */ + diff --git a/lapack-netlib/SRC/slasq5.c b/lapack-netlib/SRC/slasq5.c new file mode 100644 index 000000000..682d9b9a1 --- /dev/null +++ b/lapack-netlib/SRC/slasq5.c @@ -0,0 +1,836 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLASQ5 computes one dqds transform in ping-pong form. Used by sbdsqr and sstegr. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASQ5 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, SIGMA, DMIN, DMIN1, DMIN2, DN, */ +/* DNM1, DNM2, IEEE, EPS ) */ + +/* LOGICAL IEEE */ +/* INTEGER I0, N0, PP */ +/* REAL EPS, DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, SIGMA, TAU */ +/* REAL Z( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASQ5 computes one dqds transform in ping-pong form, one */ +/* > version for IEEE machines another for non IEEE machines. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] I0 */ +/* > \verbatim */ +/* > I0 is INTEGER */ +/* > First index. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N0 */ +/* > \verbatim */ +/* > N0 is INTEGER */ +/* > Last index. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension ( 4*N ) */ +/* > Z holds the qd array. EMIN is stored in Z(4*N0) to avoid */ +/* > an extra argument. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PP */ +/* > \verbatim */ +/* > PP is INTEGER */ +/* > PP=0 for ping, PP=1 for pong. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is REAL */ +/* > This is the shift. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SIGMA */ +/* > \verbatim */ +/* > SIGMA is REAL */ +/* > This is the accumulated shift up to this step. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DMIN */ +/* > \verbatim */ +/* > DMIN is REAL */ +/* > Minimum value of d. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DMIN1 */ +/* > \verbatim */ +/* > DMIN1 is REAL */ +/* > Minimum value of d, excluding D( N0 ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DMIN2 */ +/* > \verbatim */ +/* > DMIN2 is REAL */ +/* > Minimum value of d, excluding D( N0 ) and D( N0-1 ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DN */ +/* > \verbatim */ +/* > DN is REAL */ +/* > d(N0), the last value of d. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DNM1 */ +/* > \verbatim */ +/* > DNM1 is REAL */ +/* > d(N0-1). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DNM2 */ +/* > \verbatim */ +/* > DNM2 is REAL */ +/* > d(N0-2). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IEEE */ +/* > \verbatim */ +/* > IEEE is LOGICAL */ +/* > Flag for IEEE or non IEEE arithmetic. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] EPS */ +/* > \verbatim */ +/* > EPS is REAL */ +/* > This is the value of epsilon used. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int slasq5_(integer *i0, integer *n0, real *z__, integer *pp, + real *tau, real *sigma, real *dmin__, real *dmin1, real *dmin2, real + *dn, real *dnm1, real *dnm2, logical *ieee, real *eps) +{ + /* System generated locals */ + integer i__1; + real r__1, r__2; + + /* Local variables */ + real emin, temp, d__; + integer j4, j4p2; + real dthresh; + + +/* -- 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 */ + --z__; + + /* Function Body */ + if (*n0 - *i0 - 1 <= 0) { + return 0; + } + + dthresh = *eps * (*sigma + *tau); + if (*tau < dthresh * .5f) { + *tau = 0.f; + } + if (*tau != 0.f) { + j4 = (*i0 << 2) + *pp - 3; + emin = z__[j4 + 4]; + d__ = z__[j4] - *tau; + *dmin__ = d__; + *dmin1 = -z__[j4]; + + if (*ieee) { + +/* Code for IEEE arithmetic. */ + + if (*pp == 0) { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 2] = d__ + z__[j4 - 1]; + temp = z__[j4 + 1] / z__[j4 - 2]; + d__ = d__ * temp - *tau; + *dmin__ = f2cmin(*dmin__,d__); + z__[j4] = z__[j4 - 1] * temp; +/* Computing MIN */ + r__1 = z__[j4]; + emin = f2cmin(r__1,emin); +/* L10: */ + } + } else { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 3] = d__ + z__[j4]; + temp = z__[j4 + 2] / z__[j4 - 3]; + d__ = d__ * temp - *tau; + *dmin__ = f2cmin(*dmin__,d__); + z__[j4 - 1] = z__[j4] * temp; +/* Computing MIN */ + r__1 = z__[j4 - 1]; + emin = f2cmin(r__1,emin); +/* L20: */ + } + } + +/* Unroll last two steps. */ + + *dnm2 = d__; + *dmin2 = *dmin__; + j4 = (*n0 - 2 << 2) - *pp; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm2 + z__[j4p2]; + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; + *dmin__ = f2cmin(*dmin__,*dnm1); + + *dmin1 = *dmin__; + j4 += 4; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm1 + z__[j4p2]; + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; + *dmin__ = f2cmin(*dmin__,*dn); + + } else { + +/* Code for non IEEE arithmetic. */ + + if (*pp == 0) { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 2] = d__ + z__[j4 - 1]; + if (d__ < 0.f) { + return 0; + } else { + z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); + d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]) - *tau; + } + *dmin__ = f2cmin(*dmin__,d__); +/* Computing MIN */ + r__1 = emin, r__2 = z__[j4]; + emin = f2cmin(r__1,r__2); +/* L30: */ + } + } else { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 3] = d__ + z__[j4]; + if (d__ < 0.f) { + return 0; + } else { + z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); + d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]) - *tau; + } + *dmin__ = f2cmin(*dmin__,d__); +/* Computing MIN */ + r__1 = emin, r__2 = z__[j4 - 1]; + emin = f2cmin(r__1,r__2); +/* L40: */ + } + } + +/* Unroll last two steps. */ + + *dnm2 = d__; + *dmin2 = *dmin__; + j4 = (*n0 - 2 << 2) - *pp; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm2 + z__[j4p2]; + if (*dnm2 < 0.f) { + return 0; + } else { + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; + } + *dmin__ = f2cmin(*dmin__,*dnm1); + + *dmin1 = *dmin__; + j4 += 4; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm1 + z__[j4p2]; + if (*dnm1 < 0.f) { + return 0; + } else { + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; + } + *dmin__ = f2cmin(*dmin__,*dn); + + } + + } else { +/* This is the version that sets d's to zero if they are small enough */ + j4 = (*i0 << 2) + *pp - 3; + emin = z__[j4 + 4]; + d__ = z__[j4] - *tau; + *dmin__ = d__; + *dmin1 = -z__[j4]; + if (*ieee) { + +/* Code for IEEE arithmetic. */ + + if (*pp == 0) { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 2] = d__ + z__[j4 - 1]; + temp = z__[j4 + 1] / z__[j4 - 2]; + d__ = d__ * temp - *tau; + if (d__ < dthresh) { + d__ = 0.f; + } + *dmin__ = f2cmin(*dmin__,d__); + z__[j4] = z__[j4 - 1] * temp; +/* Computing MIN */ + r__1 = z__[j4]; + emin = f2cmin(r__1,emin); +/* L50: */ + } + } else { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 3] = d__ + z__[j4]; + temp = z__[j4 + 2] / z__[j4 - 3]; + d__ = d__ * temp - *tau; + if (d__ < dthresh) { + d__ = 0.f; + } + *dmin__ = f2cmin(*dmin__,d__); + z__[j4 - 1] = z__[j4] * temp; +/* Computing MIN */ + r__1 = z__[j4 - 1]; + emin = f2cmin(r__1,emin); +/* L60: */ + } + } + +/* Unroll last two steps. */ + + *dnm2 = d__; + *dmin2 = *dmin__; + j4 = (*n0 - 2 << 2) - *pp; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm2 + z__[j4p2]; + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; + *dmin__ = f2cmin(*dmin__,*dnm1); + + *dmin1 = *dmin__; + j4 += 4; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm1 + z__[j4p2]; + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; + *dmin__ = f2cmin(*dmin__,*dn); + + } else { + +/* Code for non IEEE arithmetic. */ + + if (*pp == 0) { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 2] = d__ + z__[j4 - 1]; + if (d__ < 0.f) { + return 0; + } else { + z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); + d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]) - *tau; + } + if (d__ < dthresh) { + d__ = 0.f; + } + *dmin__ = f2cmin(*dmin__,d__); +/* Computing MIN */ + r__1 = emin, r__2 = z__[j4]; + emin = f2cmin(r__1,r__2); +/* L70: */ + } + } else { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 3] = d__ + z__[j4]; + if (d__ < 0.f) { + return 0; + } else { + z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); + d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]) - *tau; + } + if (d__ < dthresh) { + d__ = 0.f; + } + *dmin__ = f2cmin(*dmin__,d__); +/* Computing MIN */ + r__1 = emin, r__2 = z__[j4 - 1]; + emin = f2cmin(r__1,r__2); +/* L80: */ + } + } + +/* Unroll last two steps. */ + + *dnm2 = d__; + *dmin2 = *dmin__; + j4 = (*n0 - 2 << 2) - *pp; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm2 + z__[j4p2]; + if (*dnm2 < 0.f) { + return 0; + } else { + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau; + } + *dmin__ = f2cmin(*dmin__,*dnm1); + + *dmin1 = *dmin__; + j4 += 4; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm1 + z__[j4p2]; + if (*dnm1 < 0.f) { + return 0; + } else { + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau; + } + *dmin__ = f2cmin(*dmin__,*dn); + + } + + } + z__[j4 + 2] = *dn; + z__[(*n0 << 2) - *pp] = emin; + return 0; + +/* End of SLASQ5 */ + +} /* slasq5_ */ + diff --git a/lapack-netlib/SRC/slasq6.c b/lapack-netlib/SRC/slasq6.c new file mode 100644 index 000000000..1508a1dde --- /dev/null +++ b/lapack-netlib/SRC/slasq6.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 SLASQ6 computes one dqd transform in ping-pong form. Used by sbdsqr and sstegr. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASQ6 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, */ +/* DNM1, DNM2 ) */ + +/* INTEGER I0, N0, PP */ +/* REAL DMIN, DMIN1, DMIN2, DN, DNM1, DNM2 */ +/* REAL Z( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASQ6 computes one dqd (shift equal to zero) transform in */ +/* > ping-pong form, with protection against underflow and overflow. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] I0 */ +/* > \verbatim */ +/* > I0 is INTEGER */ +/* > First index. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N0 */ +/* > \verbatim */ +/* > N0 is INTEGER */ +/* > Last index. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension ( 4*N ) */ +/* > Z holds the qd array. EMIN is stored in Z(4*N0) to avoid */ +/* > an extra argument. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PP */ +/* > \verbatim */ +/* > PP is INTEGER */ +/* > PP=0 for ping, PP=1 for pong. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DMIN */ +/* > \verbatim */ +/* > DMIN is REAL */ +/* > Minimum value of d. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DMIN1 */ +/* > \verbatim */ +/* > DMIN1 is REAL */ +/* > Minimum value of d, excluding D( N0 ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DMIN2 */ +/* > \verbatim */ +/* > DMIN2 is REAL */ +/* > Minimum value of d, excluding D( N0 ) and D( N0-1 ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DN */ +/* > \verbatim */ +/* > DN is REAL */ +/* > d(N0), the last value of d. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DNM1 */ +/* > \verbatim */ +/* > DNM1 is REAL */ +/* > d(N0-1). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DNM2 */ +/* > \verbatim */ +/* > DNM2 is REAL */ +/* > d(N0-2). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int slasq6_(integer *i0, integer *n0, real *z__, integer *pp, + real *dmin__, real *dmin1, real *dmin2, real *dn, real *dnm1, real * + dnm2) +{ + /* System generated locals */ + integer i__1; + real r__1, r__2; + + /* Local variables */ + real emin, temp, d__; + integer j4; + extern real slamch_(char *); + real safmin; + integer j4p2; + + +/* -- 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 */ + --z__; + + /* Function Body */ + if (*n0 - *i0 - 1 <= 0) { + return 0; + } + + safmin = slamch_("Safe minimum"); + j4 = (*i0 << 2) + *pp - 3; + emin = z__[j4 + 4]; + d__ = z__[j4]; + *dmin__ = d__; + + if (*pp == 0) { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 2] = d__ + z__[j4 - 1]; + if (z__[j4 - 2] == 0.f) { + z__[j4] = 0.f; + d__ = z__[j4 + 1]; + *dmin__ = d__; + emin = 0.f; + } else if (safmin * z__[j4 + 1] < z__[j4 - 2] && safmin * z__[j4 + - 2] < z__[j4 + 1]) { + temp = z__[j4 + 1] / z__[j4 - 2]; + z__[j4] = z__[j4 - 1] * temp; + d__ *= temp; + } else { + z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]); + d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]); + } + *dmin__ = f2cmin(*dmin__,d__); +/* Computing MIN */ + r__1 = emin, r__2 = z__[j4]; + emin = f2cmin(r__1,r__2); +/* L10: */ + } + } else { + i__1 = *n0 - 3 << 2; + for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) { + z__[j4 - 3] = d__ + z__[j4]; + if (z__[j4 - 3] == 0.f) { + z__[j4 - 1] = 0.f; + d__ = z__[j4 + 2]; + *dmin__ = d__; + emin = 0.f; + } else if (safmin * z__[j4 + 2] < z__[j4 - 3] && safmin * z__[j4 + - 3] < z__[j4 + 2]) { + temp = z__[j4 + 2] / z__[j4 - 3]; + z__[j4 - 1] = z__[j4] * temp; + d__ *= temp; + } else { + z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]); + d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]); + } + *dmin__ = f2cmin(*dmin__,d__); +/* Computing MIN */ + r__1 = emin, r__2 = z__[j4 - 1]; + emin = f2cmin(r__1,r__2); +/* L20: */ + } + } + +/* Unroll last two steps. */ + + *dnm2 = d__; + *dmin2 = *dmin__; + j4 = (*n0 - 2 << 2) - *pp; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm2 + z__[j4p2]; + if (z__[j4 - 2] == 0.f) { + z__[j4] = 0.f; + *dnm1 = z__[j4p2 + 2]; + *dmin__ = *dnm1; + emin = 0.f; + } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] < + z__[j4p2 + 2]) { + temp = z__[j4p2 + 2] / z__[j4 - 2]; + z__[j4] = z__[j4p2] * temp; + *dnm1 = *dnm2 * temp; + } else { + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]); + } + *dmin__ = f2cmin(*dmin__,*dnm1); + + *dmin1 = *dmin__; + j4 += 4; + j4p2 = j4 + (*pp << 1) - 1; + z__[j4 - 2] = *dnm1 + z__[j4p2]; + if (z__[j4 - 2] == 0.f) { + z__[j4] = 0.f; + *dn = z__[j4p2 + 2]; + *dmin__ = *dn; + emin = 0.f; + } else if (safmin * z__[j4p2 + 2] < z__[j4 - 2] && safmin * z__[j4 - 2] < + z__[j4p2 + 2]) { + temp = z__[j4p2 + 2] / z__[j4 - 2]; + z__[j4] = z__[j4p2] * temp; + *dn = *dnm1 * temp; + } else { + z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]); + *dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]); + } + *dmin__ = f2cmin(*dmin__,*dn); + + z__[j4 + 2] = *dn; + z__[(*n0 << 2) - *pp] = emin; + return 0; + +/* End of SLASQ6 */ + +} /* slasq6_ */ + diff --git a/lapack-netlib/SRC/slasr.c b/lapack-netlib/SRC/slasr.c new file mode 100644 index 000000000..a647866cc --- /dev/null +++ b/lapack-netlib/SRC/slasr.c @@ -0,0 +1,886 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#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 SLASR applies a sequence of plane rotations to a general rectangular matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA ) */ + +/* CHARACTER DIRECT, PIVOT, SIDE */ +/* INTEGER LDA, M, N */ +/* REAL A( LDA, * ), C( * ), S( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASR applies a sequence of plane rotations to a real matrix A, */ +/* > from either the left or the right. */ +/* > */ +/* > When SIDE = 'L', the transformation takes the form */ +/* > */ +/* > A := P*A */ +/* > */ +/* > and when SIDE = 'R', the transformation takes the form */ +/* > */ +/* > A := A*P**T */ +/* > */ +/* > where P is an orthogonal matrix consisting of a sequence of z plane */ +/* > rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R', */ +/* > and P**T is the transpose of P. */ +/* > */ +/* > When DIRECT = 'F' (Forward sequence), then */ +/* > */ +/* > P = P(z-1) * ... * P(2) * P(1) */ +/* > */ +/* > and when DIRECT = 'B' (Backward sequence), then */ +/* > */ +/* > P = P(1) * P(2) * ... * P(z-1) */ +/* > */ +/* > where P(k) is a plane rotation matrix defined by the 2-by-2 rotation */ +/* > */ +/* > R(k) = ( c(k) s(k) ) */ +/* > = ( -s(k) c(k) ). */ +/* > */ +/* > When PIVOT = 'V' (Variable pivot), the rotation is performed */ +/* > for the plane (k,k+1), i.e., P(k) has the form */ +/* > */ +/* > P(k) = ( 1 ) */ +/* > ( ... ) */ +/* > ( 1 ) */ +/* > ( c(k) s(k) ) */ +/* > ( -s(k) c(k) ) */ +/* > ( 1 ) */ +/* > ( ... ) */ +/* > ( 1 ) */ +/* > */ +/* > where R(k) appears as a rank-2 modification to the identity matrix in */ +/* > rows and columns k and k+1. */ +/* > */ +/* > When PIVOT = 'T' (Top pivot), the rotation is performed for the */ +/* > plane (1,k+1), so P(k) has the form */ +/* > */ +/* > P(k) = ( c(k) s(k) ) */ +/* > ( 1 ) */ +/* > ( ... ) */ +/* > ( 1 ) */ +/* > ( -s(k) c(k) ) */ +/* > ( 1 ) */ +/* > ( ... ) */ +/* > ( 1 ) */ +/* > */ +/* > where R(k) appears in rows and columns 1 and k+1. */ +/* > */ +/* > Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is */ +/* > performed for the plane (k,z), giving P(k) the form */ +/* > */ +/* > P(k) = ( 1 ) */ +/* > ( ... ) */ +/* > ( 1 ) */ +/* > ( c(k) s(k) ) */ +/* > ( 1 ) */ +/* > ( ... ) */ +/* > ( 1 ) */ +/* > ( -s(k) c(k) ) */ +/* > */ +/* > where R(k) appears in rows and columns k and z. The rotations are */ +/* > performed without ever forming P(k) explicitly. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > Specifies whether the plane rotation matrix P is applied to */ +/* > A on the left or the right. */ +/* > = 'L': Left, compute A := P*A */ +/* > = 'R': Right, compute A:= A*P**T */ +/* > \endverbatim */ +/* > */ +/* > \param[in] PIVOT */ +/* > \verbatim */ +/* > PIVOT is CHARACTER*1 */ +/* > Specifies the plane for which P(k) is a plane rotation */ +/* > matrix. */ +/* > = 'V': Variable pivot, the plane (k,k+1) */ +/* > = 'T': Top pivot, the plane (1,k+1) */ +/* > = 'B': Bottom pivot, the plane (k,z) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIRECT */ +/* > \verbatim */ +/* > DIRECT is CHARACTER*1 */ +/* > Specifies whether P is a forward or backward sequence of */ +/* > plane rotations. */ +/* > = 'F': Forward, P = P(z-1)*...*P(2)*P(1) */ +/* > = 'B': Backward, P = P(1)*P(2)*...*P(z-1) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. If m <= 1, an immediate */ +/* > return is effected. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. If n <= 1, an */ +/* > immediate return is effected. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is REAL array, dimension */ +/* > (M-1) if SIDE = 'L' */ +/* > (N-1) if SIDE = 'R' */ +/* > The cosines c(k) of the plane rotations. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is REAL array, dimension */ +/* > (M-1) if SIDE = 'L' */ +/* > (N-1) if SIDE = 'R' */ +/* > The sines s(k) of the plane rotations. The 2-by-2 plane */ +/* > rotation part of the matrix P(k), R(k), has the form */ +/* > R(k) = ( c(k) s(k) ) */ +/* > ( -s(k) c(k) ). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > The M-by-N matrix A. On exit, A is overwritten by P*A if */ +/* > SIDE = 'R' or by A*P**T if SIDE = 'L'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slasr_(char *side, char *pivot, char *direct, integer *m, + integer *n, real *c__, real *s, real *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer info; + real temp; + integer i__, j; + extern logical lsame_(char *, char *); + real ctemp, stemp; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + --c__; + --s; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + info = 0; + if (! (lsame_(side, "L") || lsame_(side, "R"))) { + info = 1; + } else if (! (lsame_(pivot, "V") || lsame_(pivot, + "T") || lsame_(pivot, "B"))) { + info = 2; + } else if (! (lsame_(direct, "F") || lsame_(direct, + "B"))) { + info = 3; + } else if (*m < 0) { + info = 4; + } else if (*n < 0) { + info = 5; + } else if (*lda < f2cmax(1,*m)) { + info = 9; + } + if (info != 0) { + xerbla_("SLASR ", &info, (ftnlen)5); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + if (lsame_(side, "L")) { + +/* Form P * A */ + + if (lsame_(pivot, "V")) { + if (lsame_(direct, "F")) { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1.f || stemp != 0.f) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[j + 1 + i__ * a_dim1]; + a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp * + a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j + + i__ * a_dim1]; +/* L10: */ + } + } +/* L20: */ + } + } else if (lsame_(direct, "B")) { + for (j = *m - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1.f || stemp != 0.f) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[j + 1 + i__ * a_dim1]; + a[j + 1 + i__ * a_dim1] = ctemp * temp - stemp * + a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = stemp * temp + ctemp * a[j + + i__ * a_dim1]; +/* L30: */ + } + } +/* L40: */ + } + } + } else if (lsame_(pivot, "T")) { + if (lsame_(direct, "F")) { + i__1 = *m; + for (j = 2; j <= i__1; ++j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1.f || stemp != 0.f) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = ctemp * temp - stemp * a[ + i__ * a_dim1 + 1]; + a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[ + i__ * a_dim1 + 1]; +/* L50: */ + } + } +/* L60: */ + } + } else if (lsame_(direct, "B")) { + for (j = *m; j >= 2; --j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1.f || stemp != 0.f) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = ctemp * temp - stemp * a[ + i__ * a_dim1 + 1]; + a[i__ * a_dim1 + 1] = stemp * temp + ctemp * a[ + i__ * a_dim1 + 1]; +/* L70: */ + } + } +/* L80: */ + } + } + } else if (lsame_(pivot, "B")) { + if (lsame_(direct, "F")) { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1.f || stemp != 0.f) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1] + + ctemp * temp; + a[*m + i__ * a_dim1] = ctemp * a[*m + i__ * + a_dim1] - stemp * temp; +/* L90: */ + } + } +/* L100: */ + } + } else if (lsame_(direct, "B")) { + for (j = *m - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1.f || stemp != 0.f) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[j + i__ * a_dim1]; + a[j + i__ * a_dim1] = stemp * a[*m + i__ * a_dim1] + + ctemp * temp; + a[*m + i__ * a_dim1] = ctemp * a[*m + i__ * + a_dim1] - stemp * temp; +/* L110: */ + } + } +/* L120: */ + } + } + } + } else if (lsame_(side, "R")) { + +/* Form A * P**T */ + + if (lsame_(pivot, "V")) { + if (lsame_(direct, "F")) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1.f || stemp != 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[i__ + (j + 1) * a_dim1]; + a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp * + a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = stemp * temp + ctemp * a[ + i__ + j * a_dim1]; +/* L130: */ + } + } +/* L140: */ + } + } else if (lsame_(direct, "B")) { + for (j = *n - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1.f || stemp != 0.f) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[i__ + (j + 1) * a_dim1]; + a[i__ + (j + 1) * a_dim1] = ctemp * temp - stemp * + a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = stemp * temp + ctemp * a[ + i__ + j * a_dim1]; +/* L150: */ + } + } +/* L160: */ + } + } + } else if (lsame_(pivot, "T")) { + if (lsame_(direct, "F")) { + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1.f || stemp != 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = ctemp * temp - stemp * a[ + i__ + a_dim1]; + a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ + + a_dim1]; +/* L170: */ + } + } +/* L180: */ + } + } else if (lsame_(direct, "B")) { + for (j = *n; j >= 2; --j) { + ctemp = c__[j - 1]; + stemp = s[j - 1]; + if (ctemp != 1.f || stemp != 0.f) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = ctemp * temp - stemp * a[ + i__ + a_dim1]; + a[i__ + a_dim1] = stemp * temp + ctemp * a[i__ + + a_dim1]; +/* L190: */ + } + } +/* L200: */ + } + } + } else if (lsame_(pivot, "B")) { + if (lsame_(direct, "F")) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1.f || stemp != 0.f) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + temp = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1] + + ctemp * temp; + a[i__ + *n * a_dim1] = ctemp * a[i__ + *n * + a_dim1] - stemp * temp; +/* L210: */ + } + } +/* L220: */ + } + } else if (lsame_(direct, "B")) { + for (j = *n - 1; j >= 1; --j) { + ctemp = c__[j]; + stemp = s[j]; + if (ctemp != 1.f || stemp != 0.f) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + temp = a[i__ + j * a_dim1]; + a[i__ + j * a_dim1] = stemp * a[i__ + *n * a_dim1] + + ctemp * temp; + a[i__ + *n * a_dim1] = ctemp * a[i__ + *n * + a_dim1] - stemp * temp; +/* L230: */ + } + } +/* L240: */ + } + } + } + } + + return 0; + +/* End of SLASR */ + +} /* slasr_ */ + diff --git a/lapack-netlib/SRC/slasrt.c b/lapack-netlib/SRC/slasrt.c new file mode 100644 index 000000000..ff3cddc94 --- /dev/null +++ b/lapack-netlib/SRC/slasrt.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 SLASRT sorts numbers in increasing or decreasing order. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASRT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASRT( ID, N, D, INFO ) */ + +/* CHARACTER ID */ +/* INTEGER INFO, N */ +/* REAL D( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Sort the numbers in D in increasing order (if ID = 'I') or */ +/* > in decreasing order (if ID = 'D' ). */ +/* > */ +/* > Use Quick Sort, reverting to Insertion sort on arrays of */ +/* > size <= 20. Dimension of STACK limits N to about 2**32. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ID */ +/* > \verbatim */ +/* > ID is CHARACTER*1 */ +/* > = 'I': sort D in increasing order; */ +/* > = 'D': sort D in decreasing order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The length of the array D. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry, the array to be sorted. */ +/* > On exit, D has been sorted into increasing order */ +/* > (D(1) <= ... <= D(N) ) or into decreasing order */ +/* > (D(1) >= ... >= D(N) ), depending on ID. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int slasrt_(char *id, integer *n, real *d__, integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer endd, i__, j; + extern logical lsame_(char *, char *); + integer stack[64] /* was [2][32] */; + real dmnmx, d1, d2, d3; + integer start; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + integer stkpnt, dir; + real tmp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + + /* Function Body */ + *info = 0; + dir = -1; + if (lsame_(id, "D")) { + dir = 0; + } else if (lsame_(id, "I")) { + dir = 1; + } + if (dir == -1) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLASRT", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 1) { + return 0; + } + + stkpnt = 1; + stack[0] = 1; + stack[1] = *n; +L10: + start = stack[(stkpnt << 1) - 2]; + endd = stack[(stkpnt << 1) - 1]; + --stkpnt; + if (endd - start <= 20 && endd - start > 0) { + +/* Do Insertion sort on D( START:ENDD ) */ + + if (dir == 0) { + +/* Sort into decreasing order */ + + i__1 = endd; + for (i__ = start + 1; i__ <= i__1; ++i__) { + i__2 = start + 1; + for (j = i__; j >= i__2; --j) { + if (d__[j] > d__[j - 1]) { + dmnmx = d__[j]; + d__[j] = d__[j - 1]; + d__[j - 1] = dmnmx; + } else { + goto L30; + } +/* L20: */ + } +L30: + ; + } + + } else { + +/* Sort into increasing order */ + + i__1 = endd; + for (i__ = start + 1; i__ <= i__1; ++i__) { + i__2 = start + 1; + for (j = i__; j >= i__2; --j) { + if (d__[j] < d__[j - 1]) { + dmnmx = d__[j]; + d__[j] = d__[j - 1]; + d__[j - 1] = dmnmx; + } else { + goto L50; + } +/* L40: */ + } +L50: + ; + } + + } + + } else if (endd - start > 20) { + +/* Partition D( START:ENDD ) and stack parts, largest one first */ + +/* Choose partition entry as median of 3 */ + + d1 = d__[start]; + d2 = d__[endd]; + i__ = (start + endd) / 2; + d3 = d__[i__]; + if (d1 < d2) { + if (d3 < d1) { + dmnmx = d1; + } else if (d3 < d2) { + dmnmx = d3; + } else { + dmnmx = d2; + } + } else { + if (d3 < d2) { + dmnmx = d2; + } else if (d3 < d1) { + dmnmx = d3; + } else { + dmnmx = d1; + } + } + + if (dir == 0) { + +/* Sort into decreasing order */ + + i__ = start - 1; + j = endd + 1; +L60: +L70: + --j; + if (d__[j] < dmnmx) { + goto L70; + } +L80: + ++i__; + if (d__[i__] > dmnmx) { + goto L80; + } + if (i__ < j) { + tmp = d__[i__]; + d__[i__] = d__[j]; + d__[j] = tmp; + goto L60; + } + if (j - start > endd - j - 1) { + ++stkpnt; + stack[(stkpnt << 1) - 2] = start; + stack[(stkpnt << 1) - 1] = j; + ++stkpnt; + stack[(stkpnt << 1) - 2] = j + 1; + stack[(stkpnt << 1) - 1] = endd; + } else { + ++stkpnt; + stack[(stkpnt << 1) - 2] = j + 1; + stack[(stkpnt << 1) - 1] = endd; + ++stkpnt; + stack[(stkpnt << 1) - 2] = start; + stack[(stkpnt << 1) - 1] = j; + } + } else { + +/* Sort into increasing order */ + + i__ = start - 1; + j = endd + 1; +L90: +L100: + --j; + if (d__[j] > dmnmx) { + goto L100; + } +L110: + ++i__; + if (d__[i__] < dmnmx) { + goto L110; + } + if (i__ < j) { + tmp = d__[i__]; + d__[i__] = d__[j]; + d__[j] = tmp; + goto L90; + } + if (j - start > endd - j - 1) { + ++stkpnt; + stack[(stkpnt << 1) - 2] = start; + stack[(stkpnt << 1) - 1] = j; + ++stkpnt; + stack[(stkpnt << 1) - 2] = j + 1; + stack[(stkpnt << 1) - 1] = endd; + } else { + ++stkpnt; + stack[(stkpnt << 1) - 2] = j + 1; + stack[(stkpnt << 1) - 1] = endd; + ++stkpnt; + stack[(stkpnt << 1) - 2] = start; + stack[(stkpnt << 1) - 1] = j; + } + } + } + if (stkpnt > 0) { + goto L10; + } + return 0; + +/* End of SLASRT */ + +} /* slasrt_ */ + diff --git a/lapack-netlib/SRC/slassq.c b/lapack-netlib/SRC/slassq.c new file mode 100644 index 000000000..7a178dafd --- /dev/null +++ b/lapack-netlib/SRC/slassq.c @@ -0,0 +1,542 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#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 SLASSQ updates a sum of squares represented in scaled form. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASSQ + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASSQ( N, X, INCX, SCALE, SUMSQ ) */ + +/* INTEGER INCX, N */ +/* REAL SCALE, SUMSQ */ +/* REAL X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASSQ returns the values scl and smsq such that */ +/* > */ +/* > ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, */ +/* > */ +/* > where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is */ +/* > assumed to be non-negative and scl returns the value */ +/* > */ +/* > scl = f2cmax( scale, abs( x( i ) ) ). */ +/* > */ +/* > scale and sumsq must be supplied in SCALE and SUMSQ and */ +/* > scl and smsq are overwritten on SCALE and SUMSQ respectively. */ +/* > */ +/* > The routine makes only one pass through the vector x. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of elements to be used from the vector X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (1+(N-1)*INCX) */ +/* > The vector for which a scaled sum of squares is computed. */ +/* > x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The increment between successive values of the vector X. */ +/* > INCX > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] SCALE */ +/* > \verbatim */ +/* > SCALE is REAL */ +/* > On entry, the value scale in the equation above. */ +/* > On exit, SCALE is overwritten with scl , the scaling factor */ +/* > for the sum of squares. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] SUMSQ */ +/* > \verbatim */ +/* > SUMSQ is REAL */ +/* > On entry, the value sumsq in the equation above. */ +/* > On exit, SUMSQ is overwritten with smsq , the basic sum of */ +/* > squares from which scl has been factored out. */ +/* > \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 slassq_(integer *n, real *x, integer *incx, real *scale, + real *sumsq) +{ + /* System generated locals */ + integer i__1, i__2; + real r__1; + + /* Local variables */ + real absxi; + integer ix; + extern logical sisnan_(real *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --x; + + /* Function Body */ + if (*n > 0) { + i__1 = (*n - 1) * *incx + 1; + i__2 = *incx; + for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { + absxi = (r__1 = x[ix], abs(r__1)); + if (absxi > 0.f || sisnan_(&absxi)) { + if (*scale < absxi) { +/* Computing 2nd power */ + r__1 = *scale / absxi; + *sumsq = *sumsq * (r__1 * r__1) + 1; + *scale = absxi; + } else { +/* Computing 2nd power */ + r__1 = absxi / *scale; + *sumsq += r__1 * r__1; + } + } +/* L10: */ + } + } + return 0; + +/* End of SLASSQ */ + +} /* slassq_ */ + diff --git a/lapack-netlib/SRC/slasv2.c b/lapack-netlib/SRC/slasv2.c new file mode 100644 index 000000000..b43638b4e --- /dev/null +++ b/lapack-netlib/SRC/slasv2.c @@ -0,0 +1,709 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#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 SLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASV2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL ) */ + +/* REAL CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASV2 computes the singular value decomposition of a 2-by-2 */ +/* > triangular matrix */ +/* > [ F G ] */ +/* > [ 0 H ]. */ +/* > On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the */ +/* > smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and */ +/* > right singular vectors for abs(SSMAX), giving the decomposition */ +/* > */ +/* > [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ] */ +/* > [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ]. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] F */ +/* > \verbatim */ +/* > F is REAL */ +/* > The (1,1) element of the 2-by-2 matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] G */ +/* > \verbatim */ +/* > G is REAL */ +/* > The (1,2) element of the 2-by-2 matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] H */ +/* > \verbatim */ +/* > H is REAL */ +/* > The (2,2) element of the 2-by-2 matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SSMIN */ +/* > \verbatim */ +/* > SSMIN is REAL */ +/* > abs(SSMIN) is the smaller singular value. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SSMAX */ +/* > \verbatim */ +/* > SSMAX is REAL */ +/* > abs(SSMAX) is the larger singular value. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SNL */ +/* > \verbatim */ +/* > SNL is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CSL */ +/* > \verbatim */ +/* > CSL is REAL */ +/* > The vector (CSL, SNL) is a unit left singular vector for the */ +/* > singular value abs(SSMAX). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SNR */ +/* > \verbatim */ +/* > SNR is REAL */ +/* > \endverbatim */ +/* > */ +/* > \param[out] CSR */ +/* > \verbatim */ +/* > CSR is REAL */ +/* > The vector (CSR, SNR) is a unit right singular vector for the */ +/* > singular value abs(SSMAX). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Any input parameter may be aliased with any output parameter. */ +/* > */ +/* > Barring over/underflow and assuming a guard digit in subtraction, all */ +/* > output quantities are correct to within a few units in the last */ +/* > place (ulps). */ +/* > */ +/* > In IEEE arithmetic, the code works correctly if one matrix element is */ +/* > infinite. */ +/* > */ +/* > Overflow will not occur unless the largest singular value itself */ +/* > overflows or is within a few ulps of overflow. (On machines with */ +/* > partial overflow, like the Cray, overflow may occur if the largest */ +/* > singular value is within a factor of 2 of overflow.) */ +/* > */ +/* > Underflow is harmless if underflow is gradual. Otherwise, results */ +/* > may correspond to a matrix modified by perturbations of size near */ +/* > the underflow threshold. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slasv2_(real *f, real *g, real *h__, real *ssmin, real * + ssmax, real *snr, real *csr, real *snl, real *csl) +{ + /* System generated locals */ + real r__1; + + /* Local variables */ + integer pmax; + real temp; + logical swap; + real a, d__, l, m, r__, s, t, tsign, fa, ga, ha, ft, gt, ht, mm; + logical gasmal; + extern real slamch_(char *); + real tt, clt, crt, slt, srt; + + +/* -- 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 */ + + +/* ===================================================================== */ + + + ft = *f; + fa = abs(ft); + ht = *h__; + ha = abs(*h__); + +/* PMAX points to the maximum absolute element of matrix */ +/* PMAX = 1 if F largest in absolute values */ +/* PMAX = 2 if G largest in absolute values */ +/* PMAX = 3 if H largest in absolute values */ + + pmax = 1; + swap = ha > fa; + if (swap) { + pmax = 3; + temp = ft; + ft = ht; + ht = temp; + temp = fa; + fa = ha; + ha = temp; + +/* Now FA .ge. HA */ + + } + gt = *g; + ga = abs(gt); + if (ga == 0.f) { + +/* Diagonal matrix */ + + *ssmin = ha; + *ssmax = fa; + clt = 1.f; + crt = 1.f; + slt = 0.f; + srt = 0.f; + } else { + gasmal = TRUE_; + if (ga > fa) { + pmax = 2; + if (fa / ga < slamch_("EPS")) { + +/* Case of very large GA */ + + gasmal = FALSE_; + *ssmax = ga; + if (ha > 1.f) { + *ssmin = fa / (ga / ha); + } else { + *ssmin = fa / ga * ha; + } + clt = 1.f; + slt = ht / gt; + srt = 1.f; + crt = ft / gt; + } + } + if (gasmal) { + +/* Normal case */ + + d__ = fa - ha; + if (d__ == fa) { + +/* Copes with infinite F or H */ + + l = 1.f; + } else { + l = d__ / fa; + } + +/* Note that 0 .le. L .le. 1 */ + + m = gt / ft; + +/* Note that abs(M) .le. 1/macheps */ + + t = 2.f - l; + +/* Note that T .ge. 1 */ + + mm = m * m; + tt = t * t; + s = sqrt(tt + mm); + +/* Note that 1 .le. S .le. 1 + 1/macheps */ + + if (l == 0.f) { + r__ = abs(m); + } else { + r__ = sqrt(l * l + mm); + } + +/* Note that 0 .le. R .le. 1 + 1/macheps */ + + a = (s + r__) * .5f; + +/* Note that 1 .le. A .le. 1 + abs(M) */ + + *ssmin = ha / a; + *ssmax = fa * a; + if (mm == 0.f) { + +/* Note that M is very tiny */ + + if (l == 0.f) { + t = r_sign(&c_b3, &ft) * r_sign(&c_b4, >); + } else { + t = gt / r_sign(&d__, &ft) + m / t; + } + } else { + t = (m / (s + t) + m / (r__ + l)) * (a + 1.f); + } + l = sqrt(t * t + 4.f); + crt = 2.f / l; + srt = t / l; + clt = (crt + srt * m) / a; + slt = ht / ft * srt / a; + } + } + if (swap) { + *csl = srt; + *snl = crt; + *csr = slt; + *snr = clt; + } else { + *csl = clt; + *snl = slt; + *csr = crt; + *snr = srt; + } + +/* Correct signs of SSMAX and SSMIN */ + + if (pmax == 1) { + tsign = r_sign(&c_b4, csr) * r_sign(&c_b4, csl) * r_sign(&c_b4, f); + } + if (pmax == 2) { + tsign = r_sign(&c_b4, snr) * r_sign(&c_b4, csl) * r_sign(&c_b4, g); + } + if (pmax == 3) { + tsign = r_sign(&c_b4, snr) * r_sign(&c_b4, snl) * r_sign(&c_b4, h__); + } + *ssmax = r_sign(ssmax, &tsign); + r__1 = tsign * r_sign(&c_b4, f) * r_sign(&c_b4, h__); + *ssmin = r_sign(ssmin, &r__1); + return 0; + +/* End of SLASV2 */ + +} /* slasv2_ */ + diff --git a/lapack-netlib/SRC/slaswlq.c b/lapack-netlib/SRC/slaswlq.c new file mode 100644 index 000000000..c587c0b97 --- /dev/null +++ b/lapack-netlib/SRC/slaswlq.c @@ -0,0 +1,669 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLASWLQ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASWLQ( M, N, MB, NB, A, LDA, T, LDT, WORK, */ +/* LWORK, INFO) */ + +/* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK */ +/* REAL A( LDA, * ), T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASWLQ computes a blocked Tall-Skinny LQ factorization of */ +/* > a real M-by-N matrix A for M <= N: */ +/* > */ +/* > A = ( L 0 ) * Q, */ +/* > */ +/* > where: */ +/* > */ +/* > Q is a n-by-N orthogonal matrix, stored on exit in an implicit */ +/* > form in the elements above the digonal of the array A and in */ +/* > the elemenst of the array T; */ +/* > L is an lower-triangular M-by-M matrix stored on exit in */ +/* > the elements on and below the diagonal of the array A. */ +/* > 0 is a M-by-(N-M) zero matrix, if M < N, and is not stored. */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MB */ +/* > \verbatim */ +/* > MB is INTEGER */ +/* > The row block size to be used in the blocked QR. */ +/* > M >= MB >= 1 */ +/* > \endverbatim */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The column block size to be used in the blocked QR. */ +/* > NB > M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, the elements on and below the diagonal */ +/* > of the array contain the N-by-N lower triangular matrix L; */ +/* > the elements above the diagonal represent Q by the rows */ +/* > of blocked V (see Further Details). */ +/* > */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is REAL array, */ +/* > dimension (LDT, N * Number_of_row_blocks) */ +/* > where Number_of_row_blocks = CEIL((N-M)/(NB-M)) */ +/* > The blocked upper triangular block reflectors stored in compact form */ +/* > as a sequence of upper triangular blocks. */ +/* > See Further Details below. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= MB. */ +/* > \endverbatim */ +/* > */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > (workspace) REAL array, dimension (MAX(1,LWORK)) */ +/* > */ +/* > \endverbatim */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > The dimension of the array WORK. LWORK >= MB * M. */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > */ +/* > \endverbatim */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > Short-Wide LQ (SWLQ) performs LQ by a sequence of orthogonal transformations, */ +/* > representing Q as a product of other orthogonal matrices */ +/* > Q = Q(1) * Q(2) * . . . * Q(k) */ +/* > where each Q(i) zeros out upper diagonal entries of a block of NB rows of A: */ +/* > Q(1) zeros out the upper diagonal entries of rows 1:NB of A */ +/* > Q(2) zeros out the bottom MB-N rows of rows [1:M,NB+1:2*NB-M] of A */ +/* > Q(3) zeros out the bottom MB-N rows of rows [1:M,2*NB-M+1:3*NB-2*M] of A */ +/* > . . . */ +/* > */ +/* > Q(1) is computed by GELQT, which represents Q(1) by Householder vectors */ +/* > stored under the diagonal of rows 1:MB of A, and by upper triangular */ +/* > block reflectors, stored in array T(1:LDT,1:N). */ +/* > For more information see Further Details in GELQT. */ +/* > */ +/* > Q(i) for i>1 is computed by TPLQT, which represents Q(i) by Householder vectors */ +/* > stored in columns [(i-1)*(NB-M)+M+1:i*(NB-M)+M] of A, and by upper triangular */ +/* > block reflectors, stored in array T(1:LDT,(i-1)*M+1:i*M). */ +/* > The last Q(k) may use fewer rows. */ +/* > For more information see Further Details in TPQRT. */ +/* > */ +/* > For more details of the overall algorithm, see the description of */ +/* > Sequential TSQR in Section 2.2 of [1]. */ +/* > */ +/* > [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations, */ +/* > J. Demmel, L. Grigori, M. Hoemmen, J. Langou, */ +/* > SIAM J. Sci. Comput, vol. 34, no. 1, 2012 */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slaswlq_(integer *m, integer *n, integer *mb, integer * + nb, real *a, integer *lda, real *t, integer *ldt, real *work, integer + *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, t_dim1, t_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, ii, kk; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), sgelqt_( + integer *, integer *, integer *, real *, integer *, real *, + integer *, real *, integer *); + logical lquery; + extern /* Subroutine */ int stplqt_(integer *, integer *, integer *, + integer *, real *, integer *, real *, integer *, real *, integer * + , real *, integer *); + integer ctr; + + +/* -- LAPACK computational routine (version 3.9.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. -- */ +/* November 2019 */ + + +/* ===================================================================== */ + + +/* TEST THE INPUT ARGUMENTS */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + --work; + + /* Function Body */ + *info = 0; + + lquery = *lwork == -1; + + if (*m < 0) { + *info = -1; + } else if (*n < 0 || *n < *m) { + *info = -2; + } else if (*mb < 1 || *mb > *m && *m > 0) { + *info = -3; + } else if (*nb <= *m) { + *info = -4; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } else if (*ldt < *mb) { + *info = -8; + } else if (*lwork < *m * *mb && ! lquery) { + *info = -10; + } + if (*info == 0) { + work[1] = (real) (*mb * *m); + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLASWLQ", &i__1, (ftnlen)7); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (f2cmin(*m,*n) == 0) { + return 0; + } + +/* The LQ Decomposition */ + + if (*m >= *n || *nb <= *m || *nb >= *n) { + sgelqt_(m, n, mb, &a[a_offset], lda, &t[t_offset], ldt, &work[1], + info); + return 0; + } + + kk = (*n - *m) % (*nb - *m); + ii = *n - kk + 1; + +/* Compute the LQ factorization of the first block A(1:M,1:NB) */ + + sgelqt_(m, nb, mb, &a[a_dim1 + 1], lda, &t[t_offset], ldt, &work[1], info) + ; + ctr = 1; + + i__1 = ii - *nb + *m; + i__2 = *nb - *m; + for (i__ = *nb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + +/* Compute the QR factorization of the current block A(1:M,I:I+NB-M) */ + + i__3 = *nb - *m; + stplqt_(m, &i__3, &c__0, mb, &a[a_dim1 + 1], lda, &a[i__ * a_dim1 + 1] + , lda, &t[(ctr * *m + 1) * t_dim1 + 1], ldt, &work[1], info); + ++ctr; + } + +/* Compute the QR factorization of the last block A(1:M,II:N) */ + + if (ii <= *n) { + stplqt_(m, &kk, &c__0, mb, &a[a_dim1 + 1], lda, &a[ii * a_dim1 + 1], + lda, &t[(ctr * *m + 1) * t_dim1 + 1], ldt, &work[1], info); + } + + work[1] = (real) (*m * *mb); + return 0; + +/* End of SLASWLQ */ + +} /* slaswlq_ */ + diff --git a/lapack-netlib/SRC/slaswp.c b/lapack-netlib/SRC/slaswp.c new file mode 100644 index 000000000..5866d7103 --- /dev/null +++ b/lapack-netlib/SRC/slaswp.c @@ -0,0 +1,598 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLASWP performs a series of row interchanges on a general rectangular matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASWP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASWP( N, A, LDA, K1, K2, IPIV, INCX ) */ + +/* INTEGER INCX, K1, K2, LDA, N */ +/* INTEGER IPIV( * ) */ +/* REAL A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASWP performs a series of row interchanges on the matrix A. */ +/* > One row interchange is initiated for each of rows K1 through K2 of A. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the matrix of column dimension N to which the row */ +/* > interchanges will be applied. */ +/* > On exit, the permuted matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K1 */ +/* > \verbatim */ +/* > K1 is INTEGER */ +/* > The first element of IPIV for which a row interchange will */ +/* > be done. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K2 */ +/* > \verbatim */ +/* > K2 is INTEGER */ +/* > (K2-K1+1) is the number of elements of IPIV for which a row */ +/* > interchange will be done. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (K1+(K2-K1)*abs(INCX)) */ +/* > The vector of pivot indices. Only the elements in positions */ +/* > K1 through K1+(K2-K1)*abs(INCX) of IPIV are accessed. */ +/* > IPIV(K1+(K-K1)*abs(INCX)) = L implies rows K and L are to be */ +/* > interchanged. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The increment between successive values of IPIV. If INCX */ +/* > is negative, the pivots are applied in reverse order. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Modified by */ +/* > R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slaswp_(integer *n, real *a, integer *lda, integer *k1, + integer *k2, integer *ipiv, integer *incx) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + real temp; + integer i__, j, k, i1, i2, n32, ip, ix, ix0, inc; + + +/* -- LAPACK auxiliary routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Interchange row I with row IPIV(K1+(I-K1)*abs(INCX)) for each of rows */ +/* K1 through K2. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + + /* Function Body */ + if (*incx > 0) { + ix0 = *k1; + i1 = *k1; + i2 = *k2; + inc = 1; + } else if (*incx < 0) { + ix0 = *k1 + (*k1 - *k2) * *incx; + i1 = *k2; + i2 = *k1; + inc = -1; + } else { + return 0; + } + + n32 = *n / 32 << 5; + if (n32 != 0) { + i__1 = n32; + for (j = 1; j <= i__1; j += 32) { + ix = ix0; + i__2 = i2; + i__3 = inc; + for (i__ = i1; i__3 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__3) + { + ip = ipiv[ix]; + if (ip != i__) { + i__4 = j + 31; + for (k = j; k <= i__4; ++k) { + temp = a[i__ + k * a_dim1]; + a[i__ + k * a_dim1] = a[ip + k * a_dim1]; + a[ip + k * a_dim1] = temp; +/* L10: */ + } + } + ix += *incx; +/* L20: */ + } +/* L30: */ + } + } + if (n32 != *n) { + ++n32; + ix = ix0; + i__1 = i2; + i__3 = inc; + for (i__ = i1; i__3 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__3) { + ip = ipiv[ix]; + if (ip != i__) { + i__2 = *n; + for (k = n32; k <= i__2; ++k) { + temp = a[i__ + k * a_dim1]; + a[i__ + k * a_dim1] = a[ip + k * a_dim1]; + a[ip + k * a_dim1] = temp; +/* L40: */ + } + } + ix += *incx; +/* L50: */ + } + } + + return 0; + +/* End of SLASWP */ + +} /* slaswp_ */ + diff --git a/lapack-netlib/SRC/slasy2.c b/lapack-netlib/SRC/slasy2.c new file mode 100644 index 000000000..a28609ed6 --- /dev/null +++ b/lapack-netlib/SRC/slasy2.c @@ -0,0 +1,931 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLASY2 solves the Sylvester matrix equation where the matrices are of order 1 or 2. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASY2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR, */ +/* LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO ) */ + +/* LOGICAL LTRANL, LTRANR */ +/* INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2 */ +/* REAL SCALE, XNORM */ +/* REAL B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ), */ +/* $ X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in */ +/* > */ +/* > op(TL)*X + ISGN*X*op(TR) = SCALE*B, */ +/* > */ +/* > where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or */ +/* > -1. op(T) = T or T**T, where T**T denotes the transpose of T. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] LTRANL */ +/* > \verbatim */ +/* > LTRANL is LOGICAL */ +/* > On entry, LTRANL specifies the op(TL): */ +/* > = .FALSE., op(TL) = TL, */ +/* > = .TRUE., op(TL) = TL**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LTRANR */ +/* > \verbatim */ +/* > LTRANR is LOGICAL */ +/* > On entry, LTRANR specifies the op(TR): */ +/* > = .FALSE., op(TR) = TR, */ +/* > = .TRUE., op(TR) = TR**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ISGN */ +/* > \verbatim */ +/* > ISGN is INTEGER */ +/* > On entry, ISGN specifies the sign of the equation */ +/* > as described before. ISGN may only be 1 or -1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N1 */ +/* > \verbatim */ +/* > N1 is INTEGER */ +/* > On entry, N1 specifies the order of matrix TL. */ +/* > N1 may only be 0, 1 or 2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N2 */ +/* > \verbatim */ +/* > N2 is INTEGER */ +/* > On entry, N2 specifies the order of matrix TR. */ +/* > N2 may only be 0, 1 or 2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TL */ +/* > \verbatim */ +/* > TL is REAL array, dimension (LDTL,2) */ +/* > On entry, TL contains an N1 by N1 matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDTL */ +/* > \verbatim */ +/* > LDTL is INTEGER */ +/* > The leading dimension of the matrix TL. LDTL >= f2cmax(1,N1). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TR */ +/* > \verbatim */ +/* > TR is REAL array, dimension (LDTR,2) */ +/* > On entry, TR contains an N2 by N2 matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDTR */ +/* > \verbatim */ +/* > LDTR is INTEGER */ +/* > The leading dimension of the matrix TR. LDTR >= f2cmax(1,N2). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,2) */ +/* > On entry, the N1 by N2 matrix B contains the right-hand */ +/* > side of the equation. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the matrix B. LDB >= f2cmax(1,N1). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE */ +/* > \verbatim */ +/* > SCALE is REAL */ +/* > On exit, SCALE contains the scale factor. SCALE is chosen */ +/* > less than or equal to 1 to prevent the solution overflowing. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (LDX,2) */ +/* > On exit, X contains the N1 by N2 solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the matrix X. LDX >= f2cmax(1,N1). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] XNORM */ +/* > \verbatim */ +/* > XNORM is REAL */ +/* > On exit, XNORM is the infinity-norm of the solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > On exit, INFO is set to */ +/* > 0: successful exit. */ +/* > 1: TL and TR have too close eigenvalues, so TL or */ +/* > TR is perturbed to get a nonsingular equation. */ +/* > NOTE: In the interests of speed, this routine does not */ +/* > check the inputs for errors. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup realSYauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slasy2_(logical *ltranl, logical *ltranr, integer *isgn, + integer *n1, integer *n2, real *tl, integer *ldtl, real *tr, integer * + ldtr, real *b, integer *ldb, real *scale, real *x, integer *ldx, real + *xnorm, integer *info) +{ + /* Initialized data */ + + static integer locu12[4] = { 3,4,1,2 }; + static integer locl21[4] = { 2,1,4,3 }; + static integer locu22[4] = { 4,3,2,1 }; + static logical xswpiv[4] = { FALSE_,FALSE_,TRUE_,TRUE_ }; + static logical bswpiv[4] = { FALSE_,TRUE_,FALSE_,TRUE_ }; + + /* System generated locals */ + integer b_dim1, b_offset, tl_dim1, tl_offset, tr_dim1, tr_offset, x_dim1, + x_offset; + real r__1, r__2, r__3, r__4, r__5, r__6, r__7, r__8; + + /* Local variables */ + real btmp[4], smin; + integer ipiv; + real temp; + integer jpiv[4]; + real xmax; + integer ipsv, jpsv, i__, j, k; + logical bswap; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *), sswap_(integer *, real *, integer *, real *, integer * + ); + logical xswap; + real x2[2], l21, u11, u12; + integer ip, jp; + real u22, t16[16] /* was [4][4] */; + extern real slamch_(char *); + extern integer isamax_(integer *, real *, integer *); + real smlnum, gam, bet, eps, sgn, tmp[4], tau1; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + /* Parameter adjustments */ + tl_dim1 = *ldtl; + tl_offset = 1 + tl_dim1 * 1; + tl -= tl_offset; + tr_dim1 = *ldtr; + tr_offset = 1 + tr_dim1 * 1; + tr -= tr_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; + + /* Function Body */ + +/* Do not check the input parameters for errors */ + + *info = 0; + +/* Quick return if possible */ + + if (*n1 == 0 || *n2 == 0) { + return 0; + } + +/* Set constants to control overflow */ + + eps = slamch_("P"); + smlnum = slamch_("S") / eps; + sgn = (real) (*isgn); + + k = *n1 + *n1 + *n2 - 2; + switch (k) { + case 1: goto L10; + case 2: goto L20; + case 3: goto L30; + case 4: goto L50; + } + +/* 1 by 1: TL11*X + SGN*X*TR11 = B11 */ + +L10: + tau1 = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1]; + bet = abs(tau1); + if (bet <= smlnum) { + tau1 = smlnum; + bet = smlnum; + *info = 1; + } + + *scale = 1.f; + gam = (r__1 = b[b_dim1 + 1], abs(r__1)); + if (smlnum * gam > bet) { + *scale = 1.f / gam; + } + + x[x_dim1 + 1] = b[b_dim1 + 1] * *scale / tau1; + *xnorm = (r__1 = x[x_dim1 + 1], abs(r__1)); + return 0; + +/* 1 by 2: */ +/* TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12] = [B11 B12] */ +/* [TR21 TR22] */ + +L20: + +/* Computing MAX */ +/* Computing MAX */ + r__7 = (r__1 = tl[tl_dim1 + 1], abs(r__1)), r__8 = (r__2 = tr[tr_dim1 + 1] + , abs(r__2)), r__7 = f2cmax(r__7,r__8), r__8 = (r__3 = tr[(tr_dim1 << + 1) + 1], abs(r__3)), r__7 = f2cmax(r__7,r__8), r__8 = (r__4 = tr[ + tr_dim1 + 2], abs(r__4)), r__7 = f2cmax(r__7,r__8), r__8 = (r__5 = + tr[(tr_dim1 << 1) + 2], abs(r__5)); + r__6 = eps * f2cmax(r__7,r__8); + smin = f2cmax(r__6,smlnum); + tmp[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1]; + tmp[3] = tl[tl_dim1 + 1] + sgn * tr[(tr_dim1 << 1) + 2]; + if (*ltranr) { + tmp[1] = sgn * tr[tr_dim1 + 2]; + tmp[2] = sgn * tr[(tr_dim1 << 1) + 1]; + } else { + tmp[1] = sgn * tr[(tr_dim1 << 1) + 1]; + tmp[2] = sgn * tr[tr_dim1 + 2]; + } + btmp[0] = b[b_dim1 + 1]; + btmp[1] = b[(b_dim1 << 1) + 1]; + goto L40; + +/* 2 by 1: */ +/* op[TL11 TL12]*[X11] + ISGN* [X11]*TR11 = [B11] */ +/* [TL21 TL22] [X21] [X21] [B21] */ + +L30: +/* Computing MAX */ +/* Computing MAX */ + r__7 = (r__1 = tr[tr_dim1 + 1], abs(r__1)), r__8 = (r__2 = tl[tl_dim1 + 1] + , abs(r__2)), r__7 = f2cmax(r__7,r__8), r__8 = (r__3 = tl[(tl_dim1 << + 1) + 1], abs(r__3)), r__7 = f2cmax(r__7,r__8), r__8 = (r__4 = tl[ + tl_dim1 + 2], abs(r__4)), r__7 = f2cmax(r__7,r__8), r__8 = (r__5 = + tl[(tl_dim1 << 1) + 2], abs(r__5)); + r__6 = eps * f2cmax(r__7,r__8); + smin = f2cmax(r__6,smlnum); + tmp[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1]; + tmp[3] = tl[(tl_dim1 << 1) + 2] + sgn * tr[tr_dim1 + 1]; + if (*ltranl) { + tmp[1] = tl[(tl_dim1 << 1) + 1]; + tmp[2] = tl[tl_dim1 + 2]; + } else { + tmp[1] = tl[tl_dim1 + 2]; + tmp[2] = tl[(tl_dim1 << 1) + 1]; + } + btmp[0] = b[b_dim1 + 1]; + btmp[1] = b[b_dim1 + 2]; +L40: + +/* Solve 2 by 2 system using complete pivoting. */ +/* Set pivots less than SMIN to SMIN. */ + + ipiv = isamax_(&c__4, tmp, &c__1); + u11 = tmp[ipiv - 1]; + if (abs(u11) <= smin) { + *info = 1; + u11 = smin; + } + u12 = tmp[locu12[ipiv - 1] - 1]; + l21 = tmp[locl21[ipiv - 1] - 1] / u11; + u22 = tmp[locu22[ipiv - 1] - 1] - u12 * l21; + xswap = xswpiv[ipiv - 1]; + bswap = bswpiv[ipiv - 1]; + if (abs(u22) <= smin) { + *info = 1; + u22 = smin; + } + if (bswap) { + temp = btmp[1]; + btmp[1] = btmp[0] - l21 * temp; + btmp[0] = temp; + } else { + btmp[1] -= l21 * btmp[0]; + } + *scale = 1.f; + if (smlnum * 2.f * abs(btmp[1]) > abs(u22) || smlnum * 2.f * abs(btmp[0]) + > abs(u11)) { +/* Computing MAX */ + r__1 = abs(btmp[0]), r__2 = abs(btmp[1]); + *scale = .5f / f2cmax(r__1,r__2); + btmp[0] *= *scale; + btmp[1] *= *scale; + } + x2[1] = btmp[1] / u22; + x2[0] = btmp[0] / u11 - u12 / u11 * x2[1]; + if (xswap) { + temp = x2[1]; + x2[1] = x2[0]; + x2[0] = temp; + } + x[x_dim1 + 1] = x2[0]; + if (*n1 == 1) { + x[(x_dim1 << 1) + 1] = x2[1]; + *xnorm = (r__1 = x[x_dim1 + 1], abs(r__1)) + (r__2 = x[(x_dim1 << 1) + + 1], abs(r__2)); + } else { + x[x_dim1 + 2] = x2[1]; +/* Computing MAX */ + r__3 = (r__1 = x[x_dim1 + 1], abs(r__1)), r__4 = (r__2 = x[x_dim1 + 2] + , abs(r__2)); + *xnorm = f2cmax(r__3,r__4); + } + return 0; + +/* 2 by 2: */ +/* op[TL11 TL12]*[X11 X12] +ISGN* [X11 X12]*op[TR11 TR12] = [B11 B12] */ +/* [TL21 TL22] [X21 X22] [X21 X22] [TR21 TR22] [B21 B22] */ + +/* Solve equivalent 4 by 4 system using complete pivoting. */ +/* Set pivots less than SMIN to SMIN. */ + +L50: +/* Computing MAX */ + r__5 = (r__1 = tr[tr_dim1 + 1], abs(r__1)), r__6 = (r__2 = tr[(tr_dim1 << + 1) + 1], abs(r__2)), r__5 = f2cmax(r__5,r__6), r__6 = (r__3 = tr[ + tr_dim1 + 2], abs(r__3)), r__5 = f2cmax(r__5,r__6), r__6 = (r__4 = + tr[(tr_dim1 << 1) + 2], abs(r__4)); + smin = f2cmax(r__5,r__6); +/* Computing MAX */ + r__5 = smin, r__6 = (r__1 = tl[tl_dim1 + 1], abs(r__1)), r__5 = f2cmax(r__5, + r__6), r__6 = (r__2 = tl[(tl_dim1 << 1) + 1], abs(r__2)), r__5 = + f2cmax(r__5,r__6), r__6 = (r__3 = tl[tl_dim1 + 2], abs(r__3)), r__5 = + f2cmax(r__5,r__6), r__6 = (r__4 = tl[(tl_dim1 << 1) + 2], abs(r__4)) + ; + smin = f2cmax(r__5,r__6); +/* Computing MAX */ + r__1 = eps * smin; + smin = f2cmax(r__1,smlnum); + btmp[0] = 0.f; + scopy_(&c__16, btmp, &c__0, t16, &c__1); + t16[0] = tl[tl_dim1 + 1] + sgn * tr[tr_dim1 + 1]; + t16[5] = tl[(tl_dim1 << 1) + 2] + sgn * tr[tr_dim1 + 1]; + t16[10] = tl[tl_dim1 + 1] + sgn * tr[(tr_dim1 << 1) + 2]; + t16[15] = tl[(tl_dim1 << 1) + 2] + sgn * tr[(tr_dim1 << 1) + 2]; + if (*ltranl) { + t16[4] = tl[tl_dim1 + 2]; + t16[1] = tl[(tl_dim1 << 1) + 1]; + t16[14] = tl[tl_dim1 + 2]; + t16[11] = tl[(tl_dim1 << 1) + 1]; + } else { + t16[4] = tl[(tl_dim1 << 1) + 1]; + t16[1] = tl[tl_dim1 + 2]; + t16[14] = tl[(tl_dim1 << 1) + 1]; + t16[11] = tl[tl_dim1 + 2]; + } + if (*ltranr) { + t16[8] = sgn * tr[(tr_dim1 << 1) + 1]; + t16[13] = sgn * tr[(tr_dim1 << 1) + 1]; + t16[2] = sgn * tr[tr_dim1 + 2]; + t16[7] = sgn * tr[tr_dim1 + 2]; + } else { + t16[8] = sgn * tr[tr_dim1 + 2]; + t16[13] = sgn * tr[tr_dim1 + 2]; + t16[2] = sgn * tr[(tr_dim1 << 1) + 1]; + t16[7] = sgn * tr[(tr_dim1 << 1) + 1]; + } + btmp[0] = b[b_dim1 + 1]; + btmp[1] = b[b_dim1 + 2]; + btmp[2] = b[(b_dim1 << 1) + 1]; + btmp[3] = b[(b_dim1 << 1) + 2]; + +/* Perform elimination */ + + for (i__ = 1; i__ <= 3; ++i__) { + xmax = 0.f; + for (ip = i__; ip <= 4; ++ip) { + for (jp = i__; jp <= 4; ++jp) { + if ((r__1 = t16[ip + (jp << 2) - 5], abs(r__1)) >= xmax) { + xmax = (r__1 = t16[ip + (jp << 2) - 5], abs(r__1)); + ipsv = ip; + jpsv = jp; + } +/* L60: */ + } +/* L70: */ + } + if (ipsv != i__) { + sswap_(&c__4, &t16[ipsv - 1], &c__4, &t16[i__ - 1], &c__4); + temp = btmp[i__ - 1]; + btmp[i__ - 1] = btmp[ipsv - 1]; + btmp[ipsv - 1] = temp; + } + if (jpsv != i__) { + sswap_(&c__4, &t16[(jpsv << 2) - 4], &c__1, &t16[(i__ << 2) - 4], + &c__1); + } + jpiv[i__ - 1] = jpsv; + if ((r__1 = t16[i__ + (i__ << 2) - 5], abs(r__1)) < smin) { + *info = 1; + t16[i__ + (i__ << 2) - 5] = smin; + } + for (j = i__ + 1; j <= 4; ++j) { + t16[j + (i__ << 2) - 5] /= t16[i__ + (i__ << 2) - 5]; + btmp[j - 1] -= t16[j + (i__ << 2) - 5] * btmp[i__ - 1]; + for (k = i__ + 1; k <= 4; ++k) { + t16[j + (k << 2) - 5] -= t16[j + (i__ << 2) - 5] * t16[i__ + ( + k << 2) - 5]; +/* L80: */ + } +/* L90: */ + } +/* L100: */ + } + if (abs(t16[15]) < smin) { + *info = 1; + t16[15] = smin; + } + *scale = 1.f; + if (smlnum * 8.f * abs(btmp[0]) > abs(t16[0]) || smlnum * 8.f * abs(btmp[ + 1]) > abs(t16[5]) || smlnum * 8.f * abs(btmp[2]) > abs(t16[10]) || + smlnum * 8.f * abs(btmp[3]) > abs(t16[15])) { +/* Computing MAX */ + r__1 = abs(btmp[0]), r__2 = abs(btmp[1]), r__1 = f2cmax(r__1,r__2), r__2 + = abs(btmp[2]), r__1 = f2cmax(r__1,r__2), r__2 = abs(btmp[3]); + *scale = .125f / f2cmax(r__1,r__2); + btmp[0] *= *scale; + btmp[1] *= *scale; + btmp[2] *= *scale; + btmp[3] *= *scale; + } + for (i__ = 1; i__ <= 4; ++i__) { + k = 5 - i__; + temp = 1.f / t16[k + (k << 2) - 5]; + tmp[k - 1] = btmp[k - 1] * temp; + for (j = k + 1; j <= 4; ++j) { + tmp[k - 1] -= temp * t16[k + (j << 2) - 5] * tmp[j - 1]; +/* L110: */ + } +/* L120: */ + } + for (i__ = 1; i__ <= 3; ++i__) { + if (jpiv[4 - i__ - 1] != 4 - i__) { + temp = tmp[4 - i__ - 1]; + tmp[4 - i__ - 1] = tmp[jpiv[4 - i__ - 1] - 1]; + tmp[jpiv[4 - i__ - 1] - 1] = temp; + } +/* L130: */ + } + x[x_dim1 + 1] = tmp[0]; + x[x_dim1 + 2] = tmp[1]; + x[(x_dim1 << 1) + 1] = tmp[2]; + x[(x_dim1 << 1) + 2] = tmp[3]; +/* Computing MAX */ + r__1 = abs(tmp[0]) + abs(tmp[2]), r__2 = abs(tmp[1]) + abs(tmp[3]); + *xnorm = f2cmax(r__1,r__2); + return 0; + +/* End of SLASY2 */ + +} /* slasy2_ */ + diff --git a/lapack-netlib/SRC/slasyf.c b/lapack-netlib/SRC/slasyf.c new file mode 100644 index 000000000..556ec5d84 --- /dev/null +++ b/lapack-netlib/SRC/slasyf.c @@ -0,0 +1,1316 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLASYF computes a partial factorization of a real symmetric matrix using the Bunch-Kaufman diag +onal pivoting method. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASYF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, KB, LDA, LDW, N, NB */ +/* INTEGER IPIV( * ) */ +/* REAL A( LDA, * ), W( LDW, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASYF computes a partial factorization of a real symmetric matrix A */ +/* > using the Bunch-Kaufman diagonal pivoting method. The partial */ +/* > factorization has the form: */ +/* > */ +/* > A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: */ +/* > ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) */ +/* > */ +/* > A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L' */ +/* > ( L21 I ) ( 0 A22 ) ( 0 I ) */ +/* > */ +/* > where the order of D is at most NB. The actual order is returned in */ +/* > the argument KB, and is either NB or NB-1, or N if N <= NB. */ +/* > */ +/* > SLASYF is an auxiliary routine called by SSYTRF. It uses blocked code */ +/* > (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or */ +/* > A22 (if UPLO = 'L'). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The maximum number of columns of the matrix A that should be */ +/* > factored. NB should be at least 2 to allow for 2-by-2 pivot */ +/* > blocks. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] KB */ +/* > \verbatim */ +/* > KB is INTEGER */ +/* > The number of columns of A that were actually factored. */ +/* > KB is either NB-1 or NB, or N if N <= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > n-by-n upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading n-by-n lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > On exit, A contains details of the partial factorization. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D. */ +/* > */ +/* > If UPLO = 'U': */ +/* > Only the last KB elements of IPIV are set. */ +/* > */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* > interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) = IPIV(k-1) < 0, then rows and columns */ +/* > k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ +/* > is a 2-by-2 diagonal block. */ +/* > */ +/* > If UPLO = 'L': */ +/* > Only the first KB elements of IPIV are set. */ +/* > */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* > interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) = IPIV(k+1) < 0, then rows and columns */ +/* > k+1 and -IPIV(k) were interchanged and D(k:k+1,k:k+1) */ +/* > is a 2-by-2 diagonal block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is REAL array, dimension (LDW,NB) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDW */ +/* > \verbatim */ +/* > LDW is INTEGER */ +/* > The leading dimension of the array W. LDW >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > > 0: if INFO = k, D(k,k) is exactly zero. The factorization */ +/* > has been completed, but the block diagonal matrix D is */ +/* > exactly singular. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2013 */ + +/* > \ingroup realSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2013, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int slasyf_(char *uplo, integer *n, integer *nb, integer *kb, + real *a, integer *lda, integer *ipiv, real *w, integer *ldw, integer + *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2, r__3; + + /* Local variables */ + integer imax, jmax, j, k; + real t, alpha; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), + sgemm_(char *, char *, integer *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *), sgemv_(char *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *); + integer kstep; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *), sswap_(integer *, real *, integer *, real *, integer * + ); + real r1, d11, d21, d22; + integer jb, jj, kk, jp, kp; + real absakk; + integer kw; + extern integer isamax_(integer *, real *, integer *); + real colmax, rowmax; + integer kkw; + + +/* -- LAPACK computational routine (version 3.5.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2013 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1 * 1; + w -= w_offset; + + /* Function Body */ + *info = 0; + +/* Initialize ALPHA for use in choosing pivot block size. */ + + alpha = (sqrt(17.f) + 1.f) / 8.f; + + if (lsame_(uplo, "U")) { + +/* Factorize the trailing columns of A using the upper triangle */ +/* of A and working backwards, and compute the matrix W = U12*D */ +/* for use in updating A11 */ + +/* K is the main loop index, decreasing from N in steps of 1 or 2 */ + +/* KW is the column of W which corresponds to column K of A */ + + k = *n; +L10: + kw = *nb + k - *n; + +/* Exit from loop */ + + if (k <= *n - *nb + 1 && *nb < *n || k < 1) { + goto L30; + } + +/* Copy column K of A to column KW of W and update it */ + + scopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); + if (k < *n) { + i__1 = *n - k; + sgemv_("No transpose", &k, &i__1, &c_b8, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b9, &w[kw * + w_dim1 + 1], &c__1); + } + + kstep = 1; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + absakk = (r__1 = w[k + kw * w_dim1], abs(r__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k > 1) { + i__1 = k - 1; + imax = isamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + colmax = (r__1 = w[imax + kw * w_dim1], abs(r__1)); + } else { + colmax = 0.f; + } + + if (f2cmax(absakk,colmax) == 0.f) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + +/* Copy column IMAX to column KW-1 of W and update it */ + + scopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + i__1 = k - imax; + scopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + if (k < *n) { + i__1 = *n - k; + sgemv_("No transpose", &k, &i__1, &c_b8, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b9, &w[(kw - 1) * w_dim1 + 1], &c__1); + } + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value */ + + i__1 = k - imax; + jmax = imax + isamax_(&i__1, &w[imax + 1 + (kw - 1) * w_dim1], + &c__1); + rowmax = (r__1 = w[jmax + (kw - 1) * w_dim1], abs(r__1)); + if (imax > 1) { + i__1 = imax - 1; + jmax = isamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); +/* Computing MAX */ + r__2 = rowmax, r__3 = (r__1 = w[jmax + (kw - 1) * w_dim1], + abs(r__1)); + rowmax = f2cmax(r__2,r__3); + } + + if (absakk >= alpha * colmax * (colmax / rowmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else if ((r__1 = w[imax + (kw - 1) * w_dim1], abs(r__1)) >= + alpha * rowmax) { + +/* interchange rows and columns K and IMAX, use 1-by-1 */ +/* pivot block */ + + kp = imax; + +/* copy column KW-1 of W to column KW of W */ + + scopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + } else { + +/* interchange rows and columns K-1 and IMAX, use 2-by-2 */ +/* pivot block */ + + kp = imax; + kstep = 2; + } + } + +/* ============================================================ */ + +/* KK is the column of A where pivoting step stopped */ + + kk = k - kstep + 1; + +/* KKW is the column of W which corresponds to column KK of A */ + + kkw = *nb + kk - *n; + +/* Interchange rows and columns KP and KK. */ +/* Updated column KP is already stored in column KKW of W. */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP of submatrix A */ +/* at step K. No need to copy element into column K */ +/* (or K and K-1 for 2-by-2 pivot) of A, since these columns */ +/* will be later overwritten. */ + + a[kp + kp * a_dim1] = a[kk + kk * a_dim1]; + i__1 = kk - 1 - kp; + scopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + if (kp > 1) { + i__1 = kp - 1; + scopy_(&i__1, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + +/* Interchange rows KK and KP in last K+1 to N columns of A */ +/* (columns K (or K and K-1 for 2-by-2 pivot) of A will be */ +/* later overwritten). Interchange rows KK and KP */ +/* in last KKW to NB columns of W. */ + + if (k < *n) { + i__1 = *n - k; + sswap_(&i__1, &a[kk + (k + 1) * a_dim1], lda, &a[kp + (k + + 1) * a_dim1], lda); + } + i__1 = *n - kk + 1; + sswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column kw of W now holds */ + +/* W(kw) = U(k)*D(k), */ + +/* where U(k) is the k-th column of U */ + +/* Store subdiag. elements of column U(k) */ +/* and 1-by-1 block D(k) in column k of A. */ +/* NOTE: Diagonal element U(k,k) is a UNIT element */ +/* and not stored. */ +/* A(k,k) := D(k,k) = W(k,kw) */ +/* A(1:k-1,k) := U(1:k-1,k) = W(1:k-1,kw)/D(k,k) */ + + scopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + r1 = 1.f / a[k + k * a_dim1]; + i__1 = k - 1; + sscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + + } else { + +/* 2-by-2 pivot block D(k): columns kw and kw-1 of W now hold */ + +/* ( W(kw-1) W(kw) ) = ( U(k-1) U(k) )*D(k) */ + +/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ +/* of U */ + +/* Store U(1:k-2,k-1) and U(1:k-2,k) and 2-by-2 */ +/* block D(k-1:k,k-1:k) in columns k-1 and k of A. */ +/* NOTE: 2-by-2 diagonal block U(k-1:k,k-1:k) is a UNIT */ +/* block and not stored. */ +/* A(k-1:k,k-1:k) := D(k-1:k,k-1:k) = W(k-1:k,kw-1:kw) */ +/* A(1:k-2,k-1:k) := U(1:k-2,k:k-1:k) = */ +/* = W(1:k-2,kw-1:kw) * ( D(k-1:k,k-1:k)**(-1) ) */ + + if (k > 2) { + +/* Compose the columns of the inverse of 2-by-2 pivot */ +/* block D in the following way to reduce the number */ +/* of FLOPS when we myltiply panel ( W(kw-1) W(kw) ) by */ +/* this inverse */ + +/* D**(-1) = ( d11 d21 )**(-1) = */ +/* ( d21 d22 ) */ + +/* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = */ +/* ( (-d21 ) ( d11 ) ) */ + +/* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * */ + +/* * ( ( d22/d21 ) ( -1 ) ) = */ +/* ( ( -1 ) ( d11/d21 ) ) */ + +/* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = 1/d21 * T * ( ( D11 ) ( -1 ) ) */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = D21 * ( ( D11 ) ( -1 ) ) */ +/* ( ( -1 ) ( D22 ) ) */ + + d21 = w[k - 1 + kw * w_dim1]; + d11 = w[k + kw * w_dim1] / d21; + d22 = w[k - 1 + (kw - 1) * w_dim1] / d21; + t = 1.f / (d11 * d22 - 1.f); + d21 = t / d21; + +/* Update elements in columns A(k-1) and A(k) as */ +/* dot products of rows of ( W(kw-1) W(kw) ) and columns */ +/* of D**(-1) */ + + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + a[j + (k - 1) * a_dim1] = d21 * (d11 * w[j + (kw - 1) + * w_dim1] - w[j + kw * w_dim1]); + a[j + k * a_dim1] = d21 * (d22 * w[j + kw * w_dim1] - + w[j + (kw - 1) * w_dim1]); +/* L20: */ + } + } + +/* Copy D(k) to A */ + + a[k - 1 + (k - 1) * a_dim1] = w[k - 1 + (kw - 1) * w_dim1]; + a[k - 1 + k * a_dim1] = w[k - 1 + kw * w_dim1]; + a[k + k * a_dim1] = w[k + kw * w_dim1]; + + } + + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + goto L10; + +L30: + +/* Update the upper triangle of A11 (= A(1:k,1:k)) as */ + +/* A11 := A11 - U12*D*U12**T = A11 - U12*W**T */ + +/* computing blocks of NB columns at a time */ + + i__1 = -(*nb); + for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += + i__1) { +/* Computing MIN */ + i__2 = *nb, i__3 = k - j + 1; + jb = f2cmin(i__2,i__3); + +/* Update the upper triangle of the diagonal block */ + + i__2 = j + jb - 1; + for (jj = j; jj <= i__2; ++jj) { + i__3 = jj - j + 1; + i__4 = *n - k; + sgemv_("No transpose", &i__3, &i__4, &c_b8, &a[j + (k + 1) * + a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b9, + &a[j + jj * a_dim1], &c__1); +/* L40: */ + } + +/* Update the rectangular superdiagonal block */ + + i__2 = j - 1; + i__3 = *n - k; + sgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &c_b8, &a[( + k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * w_dim1], ldw, + &c_b9, &a[j * a_dim1 + 1], lda); +/* L50: */ + } + +/* Put U12 in standard form by partially undoing the interchanges */ +/* in columns k+1:n looping backwards from k+1 to n */ + + j = k + 1; +L60: + +/* Undo the interchanges (if any) of rows JJ and JP at each */ +/* step J */ + +/* (Here, J is a diagonal index) */ + jj = j; + jp = ipiv[j]; + if (jp < 0) { + jp = -jp; +/* (Here, J is a diagonal index) */ + ++j; + } +/* (NOTE: Here, J is used to determine row length. Length N-J+1 */ +/* of the rows to swap back doesn't include diagonal element) */ + ++j; + if (jp != jj && j <= *n) { + i__1 = *n - j + 1; + sswap_(&i__1, &a[jp + j * a_dim1], lda, &a[jj + j * a_dim1], lda); + } + if (j < *n) { + goto L60; + } + +/* Set KB to the number of columns factorized */ + + *kb = *n - k; + + } else { + +/* Factorize the leading columns of A using the lower triangle */ +/* of A and working forwards, and compute the matrix W = L21*D */ +/* for use in updating A22 */ + +/* K is the main loop index, increasing from 1 in steps of 1 or 2 */ + + k = 1; +L70: + +/* Exit from loop */ + + if (k >= *nb && *nb < *n || k > *n) { + goto L90; + } + +/* Copy column K of A to column K of W and update it */ + + i__1 = *n - k + 1; + scopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1); + i__1 = *n - k + 1; + i__2 = k - 1; + sgemv_("No transpose", &i__1, &i__2, &c_b8, &a[k + a_dim1], lda, &w[k + + w_dim1], ldw, &c_b9, &w[k + k * w_dim1], &c__1); + + kstep = 1; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + absakk = (r__1 = w[k + k * w_dim1], abs(r__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k < *n) { + i__1 = *n - k; + imax = k + isamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + colmax = (r__1 = w[imax + k * w_dim1], abs(r__1)); + } else { + colmax = 0.f; + } + + if (f2cmax(absakk,colmax) == 0.f) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + } else { + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + +/* Copy column IMAX to column K+1 of W and update it */ + + i__1 = imax - k; + scopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = *n - imax + 1; + scopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + + 1) * w_dim1], &c__1); + i__1 = *n - k + 1; + i__2 = k - 1; + sgemv_("No transpose", &i__1, &i__2, &c_b8, &a[k + a_dim1], + lda, &w[imax + w_dim1], ldw, &c_b9, &w[k + (k + 1) * + w_dim1], &c__1); + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value */ + + i__1 = imax - k; + jmax = k - 1 + isamax_(&i__1, &w[k + (k + 1) * w_dim1], &c__1) + ; + rowmax = (r__1 = w[jmax + (k + 1) * w_dim1], abs(r__1)); + if (imax < *n) { + i__1 = *n - imax; + jmax = imax + isamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); +/* Computing MAX */ + r__2 = rowmax, r__3 = (r__1 = w[jmax + (k + 1) * w_dim1], + abs(r__1)); + rowmax = f2cmax(r__2,r__3); + } + + if (absakk >= alpha * colmax * (colmax / rowmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else if ((r__1 = w[imax + (k + 1) * w_dim1], abs(r__1)) >= + alpha * rowmax) { + +/* interchange rows and columns K and IMAX, use 1-by-1 */ +/* pivot block */ + + kp = imax; + +/* copy column K+1 of W to column K of W */ + + i__1 = *n - k + 1; + scopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + } else { + +/* interchange rows and columns K+1 and IMAX, use 2-by-2 */ +/* pivot block */ + + kp = imax; + kstep = 2; + } + } + +/* ============================================================ */ + +/* KK is the column of A where pivoting step stopped */ + + kk = k + kstep - 1; + +/* Interchange rows and columns KP and KK. */ +/* Updated column KP is already stored in column KK of W. */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP of submatrix A */ +/* at step K. No need to copy element into column K */ +/* (or K and K+1 for 2-by-2 pivot) of A, since these columns */ +/* will be later overwritten. */ + + a[kp + kp * a_dim1] = a[kk + kk * a_dim1]; + i__1 = kp - kk - 1; + scopy_(&i__1, &a[kk + 1 + kk * a_dim1], &c__1, &a[kp + (kk + + 1) * a_dim1], lda); + if (kp < *n) { + i__1 = *n - kp; + scopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + +/* Interchange rows KK and KP in first K-1 columns of A */ +/* (columns K (or K and K+1 for 2-by-2 pivot) of A will be */ +/* later overwritten). Interchange rows KK and KP */ +/* in first KK columns of W. */ + + if (k > 1) { + i__1 = k - 1; + sswap_(&i__1, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + } + sswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k of W now holds */ + +/* W(k) = L(k)*D(k), */ + +/* where L(k) is the k-th column of L */ + +/* Store subdiag. elements of column L(k) */ +/* and 1-by-1 block D(k) in column k of A. */ +/* (NOTE: Diagonal element L(k,k) is a UNIT element */ +/* and not stored) */ +/* A(k,k) := D(k,k) = W(k,k) */ +/* A(k+1:N,k) := L(k+1:N,k) = W(k+1:N,k)/D(k,k) */ + + i__1 = *n - k + 1; + scopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + r1 = 1.f / a[k + k * a_dim1]; + i__1 = *n - k; + sscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + } + + } else { + +/* 2-by-2 pivot block D(k): columns k and k+1 of W now hold */ + +/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */ + +/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */ +/* of L */ + +/* Store L(k+2:N,k) and L(k+2:N,k+1) and 2-by-2 */ +/* block D(k:k+1,k:k+1) in columns k and k+1 of A. */ +/* (NOTE: 2-by-2 diagonal block L(k:k+1,k:k+1) is a UNIT */ +/* block and not stored) */ +/* A(k:k+1,k:k+1) := D(k:k+1,k:k+1) = W(k:k+1,k:k+1) */ +/* A(k+2:N,k:k+1) := L(k+2:N,k:k+1) = */ +/* = W(k+2:N,k:k+1) * ( D(k:k+1,k:k+1)**(-1) ) */ + + if (k < *n - 1) { + +/* Compose the columns of the inverse of 2-by-2 pivot */ +/* block D in the following way to reduce the number */ +/* of FLOPS when we myltiply panel ( W(k) W(k+1) ) by */ +/* this inverse */ + +/* D**(-1) = ( d11 d21 )**(-1) = */ +/* ( d21 d22 ) */ + +/* = 1/(d11*d22-d21**2) * ( ( d22 ) (-d21 ) ) = */ +/* ( (-d21 ) ( d11 ) ) */ + +/* = 1/d21 * 1/((d11/d21)*(d22/d21)-1) * */ + +/* * ( ( d22/d21 ) ( -1 ) ) = */ +/* ( ( -1 ) ( d11/d21 ) ) */ + +/* = 1/d21 * 1/(D22*D11-1) * ( ( D11 ) ( -1 ) ) = */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = 1/d21 * T * ( ( D11 ) ( -1 ) ) */ +/* ( ( -1 ) ( D22 ) ) */ + +/* = D21 * ( ( D11 ) ( -1 ) ) */ +/* ( ( -1 ) ( D22 ) ) */ + + d21 = w[k + 1 + k * w_dim1]; + d11 = w[k + 1 + (k + 1) * w_dim1] / d21; + d22 = w[k + k * w_dim1] / d21; + t = 1.f / (d11 * d22 - 1.f); + d21 = t / d21; + +/* Update elements in columns A(k) and A(k+1) as */ +/* dot products of rows of ( W(k) W(k+1) ) and columns */ +/* of D**(-1) */ + + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + a[j + k * a_dim1] = d21 * (d11 * w[j + k * w_dim1] - + w[j + (k + 1) * w_dim1]); + a[j + (k + 1) * a_dim1] = d21 * (d22 * w[j + (k + 1) * + w_dim1] - w[j + k * w_dim1]); +/* L80: */ + } + } + +/* Copy D(k) to A */ + + a[k + k * a_dim1] = w[k + k * w_dim1]; + a[k + 1 + k * a_dim1] = w[k + 1 + k * w_dim1]; + a[k + 1 + (k + 1) * a_dim1] = w[k + 1 + (k + 1) * w_dim1]; + + } + + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + goto L70; + +L90: + +/* Update the lower triangle of A22 (= A(k:n,k:n)) as */ + +/* A22 := A22 - L21*D*L21**T = A22 - L21*W**T */ + +/* computing blocks of NB columns at a time */ + + i__1 = *n; + i__2 = *nb; + for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = *nb, i__4 = *n - j + 1; + jb = f2cmin(i__3,i__4); + +/* Update the lower triangle of the diagonal block */ + + i__3 = j + jb - 1; + for (jj = j; jj <= i__3; ++jj) { + i__4 = j + jb - jj; + i__5 = k - 1; + sgemv_("No transpose", &i__4, &i__5, &c_b8, &a[jj + a_dim1], + lda, &w[jj + w_dim1], ldw, &c_b9, &a[jj + jj * a_dim1] + , &c__1); +/* L100: */ + } + +/* Update the rectangular subdiagonal block */ + + if (j + jb <= *n) { + i__3 = *n - j - jb + 1; + i__4 = k - 1; + sgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &c_b8, + &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b9, + &a[j + jb + j * a_dim1], lda); + } +/* L110: */ + } + +/* Put L21 in standard form by partially undoing the interchanges */ +/* of rows in columns 1:k-1 looping backwards from k-1 to 1 */ + + j = k - 1; +L120: + +/* Undo the interchanges (if any) of rows JJ and JP at each */ +/* step J */ + +/* (Here, J is a diagonal index) */ + jj = j; + jp = ipiv[j]; + if (jp < 0) { + jp = -jp; +/* (Here, J is a diagonal index) */ + --j; + } +/* (NOTE: Here, J is used to determine row length. Length J */ +/* of the rows to swap back doesn't include diagonal element) */ + --j; + if (jp != jj && j >= 1) { + sswap_(&j, &a[jp + a_dim1], lda, &a[jj + a_dim1], lda); + } + if (j > 1) { + goto L120; + } + +/* Set KB to the number of columns factorized */ + + *kb = k - 1; + + } + return 0; + +/* End of SLASYF */ + +} /* slasyf_ */ + diff --git a/lapack-netlib/SRC/slasyf_aa.c b/lapack-netlib/SRC/slasyf_aa.c new file mode 100644 index 000000000..32da69d61 --- /dev/null +++ b/lapack-netlib/SRC/slasyf_aa.c @@ -0,0 +1,928 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#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 SLASYF_AA */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASYF_AA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASYF_AA( UPLO, J1, M, NB, A, LDA, IPIV, */ +/* H, LDH, WORK ) */ + +/* CHARACTER UPLO */ +/* INTEGER J1, M, NB, LDA, LDH */ +/* INTEGER IPIV( * ) */ +/* REAL A( LDA, * ), H( LDH, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DLATRF_AA factorizes a panel of a real symmetric matrix A using */ +/* > the Aasen's algorithm. The panel consists of a set of NB rows of A */ +/* > when UPLO is U, or a set of NB columns when UPLO is L. */ +/* > */ +/* > In order to factorize the panel, the Aasen's algorithm requires the */ +/* > last row, or column, of the previous panel. The first row, or column, */ +/* > of A is set to be the first row, or column, of an identity matrix, */ +/* > which is used to factorize the first panel. */ +/* > */ +/* > The resulting J-th row of U, or J-th column of L, is stored in the */ +/* > (J-1)-th row, or column, of A (without the unit diagonals), while */ +/* > the diagonal and subdiagonal of A are overwritten by those of T. */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] J1 */ +/* > \verbatim */ +/* > J1 is INTEGER */ +/* > The location of the first row, or column, of the panel */ +/* > within the submatrix of A, passed to this routine, e.g., */ +/* > when called by SSYTRF_AA, for the first panel, J1 is 1, */ +/* > while for the remaining panels, J1 is 2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The dimension of the submatrix. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The dimension of the panel to be facotorized. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,M) for */ +/* > the first panel, while dimension (LDA,M+1) for the */ +/* > remaining panels. */ +/* > */ +/* > On entry, A contains the last row, or column, of */ +/* > the previous panel, and the trailing submatrix of A */ +/* > to be factorized, except for the first panel, only */ +/* > the panel is passed. */ +/* > */ +/* > On exit, the leading panel is factorized. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (M) */ +/* > Details of the row and column interchanges, */ +/* > the row and column k were interchanged with the row and */ +/* > column IPIV(k). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] H */ +/* > \verbatim */ +/* > H is REAL workspace, dimension (LDH,NB). */ +/* > */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > The leading dimension of the workspace H. LDH >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL workspace, dimension (M). */ +/* > \endverbatim */ +/* > */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup realSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int slasyf_aa_(char *uplo, integer *j1, integer *m, integer + *nb, real *a, integer *lda, integer *ipiv, real *h__, integer *ldh, + real *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, h_dim1, h_offset, i__1; + + /* Local variables */ + integer j, k; + real alpha; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), + sgemv_(char *, integer *, integer *, real *, real *, integer *, + real *, integer *, real *, real *, integer *); + integer i1, k1, i2; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *), sswap_(integer *, real *, integer *, real *, integer * + ), saxpy_(integer *, real *, real *, integer *, real *, integer *) + ; + integer mj; + extern integer isamax_(integer *, real *, integer *); + extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *, + real *, real *, integer *); + real piv; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + --work; + + /* Function Body */ + j = 1; + +/* K1 is the first column of the panel to be factorized */ +/* i.e., K1 is 2 for the first block column, and 1 for the rest of the blocks */ + + k1 = 2 - *j1 + 1; + + if (lsame_(uplo, "U")) { + +/* ..................................................... */ +/* Factorize A as U**T*D*U using the upper triangle of A */ +/* ..................................................... */ + +L10: + if (j > f2cmin(*m,*nb)) { + goto L20; + } + +/* K is the column to be factorized */ +/* when being called from SSYTRF_AA, */ +/* > for the first block column, J1 is 1, hence J1+J-1 is J, */ +/* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, */ + + k = *j1 + j - 1; + if (j == *m) { + +/* Only need to compute T(J, J) */ + + mj = 1; + } else { + mj = *m - j + 1; + } + +/* H(J:M, J) := A(J, J:M) - H(J:M, 1:(J-1)) * L(J1:(J-1), J), */ +/* where H(J:M, J) has been initialized to be A(J, J:M) */ + + if (k > 2) { + +/* K is the column to be factorized */ +/* > for the first block column, K is J, skipping the first two */ +/* columns */ +/* > for the rest of the columns, K is J+1, skipping only the */ +/* first column */ + + i__1 = j - k1; + sgemv_("No transpose", &mj, &i__1, &c_b6, &h__[j + k1 * h_dim1], + ldh, &a[j * a_dim1 + 1], &c__1, &c_b8, &h__[j + j * + h_dim1], &c__1); + } + +/* Copy H(i:M, i) into WORK */ + + scopy_(&mj, &h__[j + j * h_dim1], &c__1, &work[1], &c__1); + + if (j > k1) { + +/* Compute WORK := WORK - L(J-1, J:M) * T(J-1,J), */ +/* where A(J-1, J) stores T(J-1, J) and A(J-2, J:M) stores U(J-1, J:M) */ + + alpha = -a[k - 1 + j * a_dim1]; + saxpy_(&mj, &alpha, &a[k - 2 + j * a_dim1], lda, &work[1], &c__1); + } + +/* Set A(J, J) = T(J, J) */ + + a[k + j * a_dim1] = work[1]; + + if (j < *m) { + +/* Compute WORK(2:M) = T(J, J) L(J, (J+1):M) */ +/* where A(J, J) stores T(J, J) and A(J-1, (J+1):M) stores U(J, (J+1):M) */ + + if (k > 1) { + alpha = -a[k + j * a_dim1]; + i__1 = *m - j; + saxpy_(&i__1, &alpha, &a[k - 1 + (j + 1) * a_dim1], lda, & + work[2], &c__1); + } + +/* Find f2cmax(|WORK(2:M)|) */ + + i__1 = *m - j; + i2 = isamax_(&i__1, &work[2], &c__1) + 1; + piv = work[i2]; + +/* Apply symmetric pivot */ + + if (i2 != 2 && piv != 0.f) { + +/* Swap WORK(I1) and WORK(I2) */ + + i1 = 2; + work[i2] = work[i1]; + work[i1] = piv; + +/* Swap A(I1, I1+1:M) with A(I1+1:M, I2) */ + + i1 = i1 + j - 1; + i2 = i2 + j - 1; + i__1 = i2 - i1 - 1; + sswap_(&i__1, &a[*j1 + i1 - 1 + (i1 + 1) * a_dim1], lda, &a[* + j1 + i1 + i2 * a_dim1], &c__1); + +/* Swap A(I1, I2+1:M) with A(I2, I2+1:M) */ + + if (i2 < *m) { + i__1 = *m - i2; + sswap_(&i__1, &a[*j1 + i1 - 1 + (i2 + 1) * a_dim1], lda, & + a[*j1 + i2 - 1 + (i2 + 1) * a_dim1], lda); + } + +/* Swap A(I1, I1) with A(I2,I2) */ + + piv = a[i1 + *j1 - 1 + i1 * a_dim1]; + a[*j1 + i1 - 1 + i1 * a_dim1] = a[*j1 + i2 - 1 + i2 * a_dim1]; + a[*j1 + i2 - 1 + i2 * a_dim1] = piv; + +/* Swap H(I1, 1:J1) with H(I2, 1:J1) */ + + i__1 = i1 - 1; + sswap_(&i__1, &h__[i1 + h_dim1], ldh, &h__[i2 + h_dim1], ldh); + ipiv[i1] = i2; + + if (i1 > k1 - 1) { + +/* Swap L(1:I1-1, I1) with L(1:I1-1, I2), */ +/* skipping the first column */ + + i__1 = i1 - k1 + 1; + sswap_(&i__1, &a[i1 * a_dim1 + 1], &c__1, &a[i2 * a_dim1 + + 1], &c__1); + } + } else { + ipiv[j + 1] = j + 1; + } + +/* Set A(J, J+1) = T(J, J+1) */ + + a[k + (j + 1) * a_dim1] = work[2]; + + if (j < *nb) { + +/* Copy A(J+1:M, J+1) into H(J:M, J), */ + + i__1 = *m - j; + scopy_(&i__1, &a[k + 1 + (j + 1) * a_dim1], lda, &h__[j + 1 + + (j + 1) * h_dim1], &c__1); + } + +/* Compute L(J+2, J+1) = WORK( 3:M ) / T(J, J+1), */ +/* where A(J, J+1) = T(J, J+1) and A(J+2:M, J) = L(J+2:M, J+1) */ + + if (j < *m - 1) { + if (a[k + (j + 1) * a_dim1] != 0.f) { + alpha = 1.f / a[k + (j + 1) * a_dim1]; + i__1 = *m - j - 1; + scopy_(&i__1, &work[3], &c__1, &a[k + (j + 2) * a_dim1], + lda); + i__1 = *m - j - 1; + sscal_(&i__1, &alpha, &a[k + (j + 2) * a_dim1], lda); + } else { + i__1 = *m - j - 1; + slaset_("Full", &c__1, &i__1, &c_b22, &c_b22, &a[k + (j + + 2) * a_dim1], lda); + } + } + } + ++j; + goto L10; +L20: + + ; + } else { + +/* ..................................................... */ +/* Factorize A as L*D*L**T using the lower triangle of A */ +/* ..................................................... */ + +L30: + if (j > f2cmin(*m,*nb)) { + goto L40; + } + +/* K is the column to be factorized */ +/* when being called from SSYTRF_AA, */ +/* > for the first block column, J1 is 1, hence J1+J-1 is J, */ +/* > for the rest of the columns, J1 is 2, and J1+J-1 is J+1, */ + + k = *j1 + j - 1; + if (j == *m) { + +/* Only need to compute T(J, J) */ + + mj = 1; + } else { + mj = *m - j + 1; + } + +/* H(J:M, J) := A(J:M, J) - H(J:M, 1:(J-1)) * L(J, J1:(J-1))^T, */ +/* where H(J:M, J) has been initialized to be A(J:M, J) */ + + if (k > 2) { + +/* K is the column to be factorized */ +/* > for the first block column, K is J, skipping the first two */ +/* columns */ +/* > for the rest of the columns, K is J+1, skipping only the */ +/* first column */ + + i__1 = j - k1; + sgemv_("No transpose", &mj, &i__1, &c_b6, &h__[j + k1 * h_dim1], + ldh, &a[j + a_dim1], lda, &c_b8, &h__[j + j * h_dim1], & + c__1); + } + +/* Copy H(J:M, J) into WORK */ + + scopy_(&mj, &h__[j + j * h_dim1], &c__1, &work[1], &c__1); + + if (j > k1) { + +/* Compute WORK := WORK - L(J:M, J-1) * T(J-1,J), */ +/* where A(J-1, J) = T(J-1, J) and A(J, J-2) = L(J, J-1) */ + + alpha = -a[j + (k - 1) * a_dim1]; + saxpy_(&mj, &alpha, &a[j + (k - 2) * a_dim1], &c__1, &work[1], & + c__1); + } + +/* Set A(J, J) = T(J, J) */ + + a[j + k * a_dim1] = work[1]; + + if (j < *m) { + +/* Compute WORK(2:M) = T(J, J) L((J+1):M, J) */ +/* where A(J, J) = T(J, J) and A((J+1):M, J-1) = L((J+1):M, J) */ + + if (k > 1) { + alpha = -a[j + k * a_dim1]; + i__1 = *m - j; + saxpy_(&i__1, &alpha, &a[j + 1 + (k - 1) * a_dim1], &c__1, & + work[2], &c__1); + } + +/* Find f2cmax(|WORK(2:M)|) */ + + i__1 = *m - j; + i2 = isamax_(&i__1, &work[2], &c__1) + 1; + piv = work[i2]; + +/* Apply symmetric pivot */ + + if (i2 != 2 && piv != 0.f) { + +/* Swap WORK(I1) and WORK(I2) */ + + i1 = 2; + work[i2] = work[i1]; + work[i1] = piv; + +/* Swap A(I1+1:M, I1) with A(I2, I1+1:M) */ + + i1 = i1 + j - 1; + i2 = i2 + j - 1; + i__1 = i2 - i1 - 1; + sswap_(&i__1, &a[i1 + 1 + (*j1 + i1 - 1) * a_dim1], &c__1, &a[ + i2 + (*j1 + i1) * a_dim1], lda); + +/* Swap A(I2+1:M, I1) with A(I2+1:M, I2) */ + + if (i2 < *m) { + i__1 = *m - i2; + sswap_(&i__1, &a[i2 + 1 + (*j1 + i1 - 1) * a_dim1], &c__1, + &a[i2 + 1 + (*j1 + i2 - 1) * a_dim1], &c__1); + } + +/* Swap A(I1, I1) with A(I2, I2) */ + + piv = a[i1 + (*j1 + i1 - 1) * a_dim1]; + a[i1 + (*j1 + i1 - 1) * a_dim1] = a[i2 + (*j1 + i2 - 1) * + a_dim1]; + a[i2 + (*j1 + i2 - 1) * a_dim1] = piv; + +/* Swap H(I1, I1:J1) with H(I2, I2:J1) */ + + i__1 = i1 - 1; + sswap_(&i__1, &h__[i1 + h_dim1], ldh, &h__[i2 + h_dim1], ldh); + ipiv[i1] = i2; + + if (i1 > k1 - 1) { + +/* Swap L(1:I1-1, I1) with L(1:I1-1, I2), */ +/* skipping the first column */ + + i__1 = i1 - k1 + 1; + sswap_(&i__1, &a[i1 + a_dim1], lda, &a[i2 + a_dim1], lda); + } + } else { + ipiv[j + 1] = j + 1; + } + +/* Set A(J+1, J) = T(J+1, J) */ + + a[j + 1 + k * a_dim1] = work[2]; + + if (j < *nb) { + +/* Copy A(J+1:M, J+1) into H(J+1:M, J), */ + + i__1 = *m - j; + scopy_(&i__1, &a[j + 1 + (k + 1) * a_dim1], &c__1, &h__[j + 1 + + (j + 1) * h_dim1], &c__1); + } + +/* Compute L(J+2, J+1) = WORK( 3:M ) / T(J, J+1), */ +/* where A(J, J+1) = T(J, J+1) and A(J+2:M, J) = L(J+2:M, J+1) */ + + if (j < *m - 1) { + if (a[j + 1 + k * a_dim1] != 0.f) { + alpha = 1.f / a[j + 1 + k * a_dim1]; + i__1 = *m - j - 1; + scopy_(&i__1, &work[3], &c__1, &a[j + 2 + k * a_dim1], & + c__1); + i__1 = *m - j - 1; + sscal_(&i__1, &alpha, &a[j + 2 + k * a_dim1], &c__1); + } else { + i__1 = *m - j - 1; + slaset_("Full", &i__1, &c__1, &c_b22, &c_b22, &a[j + 2 + + k * a_dim1], lda); + } + } + } + ++j; + goto L30; +L40: + ; + } + return 0; + +/* End of SLASYF_AA */ + +} /* slasyf_aa__ */ + diff --git a/lapack-netlib/SRC/slasyf_rk.c b/lapack-netlib/SRC/slasyf_rk.c new file mode 100644 index 000000000..439f5b669 --- /dev/null +++ b/lapack-netlib/SRC/slasyf_rk.c @@ -0,0 +1,1467 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLASYF_RK computes a partial factorization of a real symmetric indefinite matrix using bounded +Bunch-Kaufman (rook) diagonal pivoting method. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASYF_RK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASYF_RK( UPLO, N, NB, KB, A, LDA, E, IPIV, W, LDW, */ +/* INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, KB, LDA, LDW, N, NB */ +/* INTEGER IPIV( * ) */ +/* REAL A( LDA, * ), E( * ), W( LDW, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > SLASYF_RK computes a partial factorization of a real symmetric */ +/* > matrix A using the bounded Bunch-Kaufman (rook) diagonal */ +/* > pivoting method. The partial factorization has the form: */ +/* > */ +/* > A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: */ +/* > ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) */ +/* > */ +/* > A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L', */ +/* > ( L21 I ) ( 0 A22 ) ( 0 I ) */ +/* > */ +/* > where the order of D is at most NB. The actual order is returned in */ +/* > the argument KB, and is either NB or NB-1, or N if N <= NB. */ +/* > */ +/* > SLASYF_RK is an auxiliary routine called by SSYTRF_RK. It uses */ +/* > blocked code (calling Level 3 BLAS) to update the submatrix */ +/* > A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The maximum number of columns of the matrix A that should be */ +/* > factored. NB should be at least 2 to allow for 2-by-2 pivot */ +/* > blocks. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] KB */ +/* > \verbatim */ +/* > KB is INTEGER */ +/* > The number of columns of A that were actually factored. */ +/* > KB is either NB-1 or NB, or N if N <= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. */ +/* > If UPLO = 'U': the leading N-by-N upper triangular part */ +/* > of A contains the upper triangular part of the matrix A, */ +/* > and the strictly lower triangular part of A is not */ +/* > referenced. */ +/* > */ +/* > If UPLO = 'L': the leading N-by-N lower triangular part */ +/* > of A contains the lower triangular part of the matrix A, */ +/* > and the strictly upper triangular part of A is not */ +/* > referenced. */ +/* > */ +/* > On exit, contains: */ +/* > a) ONLY diagonal elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > are stored on exit in array E), and */ +/* > b) If UPLO = 'U': factor U in the superdiagonal part of A. */ +/* > If UPLO = 'L': factor L in the subdiagonal part of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (N) */ +/* > On exit, contains the superdiagonal (or subdiagonal) */ +/* > elements of the symmetric block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; */ +/* > If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. */ +/* > */ +/* > NOTE: For 1-by-1 diagonal block D(k), where */ +/* > 1 <= k <= N, the element E(k) is set to 0 in both */ +/* > UPLO = 'U' or UPLO = 'L' cases. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > IPIV describes the permutation matrix P in the factorization */ +/* > of matrix A as follows. The absolute value of IPIV(k) */ +/* > represents the index of row and column that were */ +/* > interchanged with the k-th row and column. The value of UPLO */ +/* > describes the order in which the interchanges were applied. */ +/* > Also, the sign of IPIV represents the block structure of */ +/* > the symmetric block diagonal matrix D with 1-by-1 or 2-by-2 */ +/* > diagonal blocks which correspond to 1 or 2 interchanges */ +/* > at each factorization step. */ +/* > */ +/* > If UPLO = 'U', */ +/* > ( in factorization order, k decreases from N to 1 ): */ +/* > a) A single positive entry IPIV(k) > 0 means: */ +/* > D(k,k) is a 1-by-1 diagonal block. */ +/* > If IPIV(k) != k, rows and columns k and IPIV(k) were */ +/* > interchanged in the submatrix A(1:N,N-KB+1:N); */ +/* > If IPIV(k) = k, no interchange occurred. */ +/* > */ +/* > */ +/* > b) A pair of consecutive negative entries */ +/* > IPIV(k) < 0 and IPIV(k-1) < 0 means: */ +/* > D(k-1:k,k-1:k) is a 2-by-2 diagonal block. */ +/* > (NOTE: negative entries in IPIV appear ONLY in pairs). */ +/* > 1) If -IPIV(k) != k, rows and columns */ +/* > k and -IPIV(k) were interchanged */ +/* > in the matrix A(1:N,N-KB+1:N). */ +/* > If -IPIV(k) = k, no interchange occurred. */ +/* > 2) If -IPIV(k-1) != k-1, rows and columns */ +/* > k-1 and -IPIV(k-1) were interchanged */ +/* > in the submatrix A(1:N,N-KB+1:N). */ +/* > If -IPIV(k-1) = k-1, no interchange occurred. */ +/* > */ +/* > c) In both cases a) and b) is always ABS( IPIV(k) ) <= k. */ +/* > */ +/* > d) NOTE: Any entry IPIV(k) is always NONZERO on output. */ +/* > */ +/* > If UPLO = 'L', */ +/* > ( in factorization order, k increases from 1 to N ): */ +/* > a) A single positive entry IPIV(k) > 0 means: */ +/* > D(k,k) is a 1-by-1 diagonal block. */ +/* > If IPIV(k) != k, rows and columns k and IPIV(k) were */ +/* > interchanged in the submatrix A(1:N,1:KB). */ +/* > If IPIV(k) = k, no interchange occurred. */ +/* > */ +/* > b) A pair of consecutive negative entries */ +/* > IPIV(k) < 0 and IPIV(k+1) < 0 means: */ +/* > D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ +/* > (NOTE: negative entries in IPIV appear ONLY in pairs). */ +/* > 1) If -IPIV(k) != k, rows and columns */ +/* > k and -IPIV(k) were interchanged */ +/* > in the submatrix A(1:N,1:KB). */ +/* > If -IPIV(k) = k, no interchange occurred. */ +/* > 2) If -IPIV(k+1) != k+1, rows and columns */ +/* > k-1 and -IPIV(k-1) were interchanged */ +/* > in the submatrix A(1:N,1:KB). */ +/* > If -IPIV(k+1) = k+1, no interchange occurred. */ +/* > */ +/* > c) In both cases a) and b) is always ABS( IPIV(k) ) >= k. */ +/* > */ +/* > d) NOTE: Any entry IPIV(k) is always NONZERO on output. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is REAL array, dimension (LDW,NB) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDW */ +/* > \verbatim */ +/* > LDW is INTEGER */ +/* > The leading dimension of the array W. LDW >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > */ +/* > < 0: If INFO = -k, the k-th argument had an illegal value */ +/* > */ +/* > > 0: If INFO = k, the matrix A is singular, because: */ +/* > If UPLO = 'U': column k in the upper */ +/* > triangular part of A contains all zeros. */ +/* > If UPLO = 'L': column k in the lower */ +/* > triangular part of A contains all zeros. */ +/* > */ +/* > Therefore D(k,k) is exactly zero, and superdiagonal */ +/* > elements of column k of U (or subdiagonal elements of */ +/* > column k of L ) are all zeros. The factorization has */ +/* > been completed, but the block diagonal matrix D is */ +/* > exactly singular, and division by zero will occur if */ +/* > it is used to solve a system of equations. */ +/* > */ +/* > NOTE: INFO only stores the first occurrence of */ +/* > a singularity, any subsequent occurrence of singularity */ +/* > is not stored in INFO even though the factorization */ +/* > always completes. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup singleSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > December 2016, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int slasyf_rk_(char *uplo, integer *n, integer *nb, integer + *kb, real *a, integer *lda, real *e, integer *ipiv, real *w, integer * + ldw, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5; + real r__1; + + /* Local variables */ + logical done; + integer imax, jmax, j, k, p; + real t, alpha; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), + sgemm_(char *, char *, integer *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *); + real sfmin; + integer itemp; + extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *); + integer kstep; + real stemp; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *), sswap_(integer *, real *, integer *, real *, integer * + ); + real r1, d11, d12, d21, d22; + integer jb, ii, jj, kk, kp; + real absakk; + integer kw; + extern real slamch_(char *); + extern integer isamax_(integer *, real *, integer *); + real colmax, rowmax; + integer kkw; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --e; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1 * 1; + w -= w_offset; + + /* Function Body */ + *info = 0; + +/* Initialize ALPHA for use in choosing pivot block size. */ + + alpha = (sqrt(17.f) + 1.f) / 8.f; + +/* Compute machine safe minimum */ + + sfmin = slamch_("S"); + + if (lsame_(uplo, "U")) { + +/* Factorize the trailing columns of A using the upper triangle */ +/* of A and working backwards, and compute the matrix W = U12*D */ +/* for use in updating A11 */ + +/* Initialize the first entry of array E, where superdiagonal */ +/* elements of D are stored */ + + e[1] = 0.f; + +/* K is the main loop index, decreasing from N in steps of 1 or 2 */ + + k = *n; +L10: + +/* KW is the column of W which corresponds to column K of A */ + + kw = *nb + k - *n; + +/* Exit from loop */ + + if (k <= *n - *nb + 1 && *nb < *n || k < 1) { + goto L30; + } + + kstep = 1; + p = k; + +/* Copy column K of A to column KW of W and update it */ + + scopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); + if (k < *n) { + i__1 = *n - k; + sgemv_("No transpose", &k, &i__1, &c_b9, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b10, &w[kw * + w_dim1 + 1], &c__1); + } + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + absakk = (r__1 = w[k + kw * w_dim1], abs(r__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k > 1) { + i__1 = k - 1; + imax = isamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + colmax = (r__1 = w[imax + kw * w_dim1], abs(r__1)); + } else { + colmax = 0.f; + } + + if (f2cmax(absakk,colmax) == 0.f) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + scopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + +/* Set E( K ) to zero */ + + if (k > 1) { + e[k] = 0.f; + } + + } else { + +/* ============================================================ */ + +/* Test for interchange */ + +/* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX */ +/* (used to handle NaN and Inf) */ + + if (! (absakk < alpha * colmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + + } else { + + done = FALSE_; + +/* Loop until pivot found */ + +L12: + +/* Begin pivot search loop body */ + + +/* Copy column IMAX to column KW-1 of W and update it */ + + scopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + i__1 = k - imax; + scopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + + if (k < *n) { + i__1 = *n - k; + sgemv_("No transpose", &k, &i__1, &c_b9, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b10, &w[(kw - 1) * w_dim1 + 1], &c__1); + } + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine both ROWMAX and JMAX. */ + + if (imax != k) { + i__1 = k - imax; + jmax = imax + isamax_(&i__1, &w[imax + 1 + (kw - 1) * + w_dim1], &c__1); + rowmax = (r__1 = w[jmax + (kw - 1) * w_dim1], abs(r__1)); + } else { + rowmax = 0.f; + } + + if (imax > 1) { + i__1 = imax - 1; + itemp = isamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); + stemp = (r__1 = w[itemp + (kw - 1) * w_dim1], abs(r__1)); + if (stemp > rowmax) { + rowmax = stemp; + jmax = itemp; + } + } + +/* Equivalent to testing for */ +/* ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX */ +/* (used to handle NaN and Inf) */ + + if (! ((r__1 = w[imax + (kw - 1) * w_dim1], abs(r__1)) < + alpha * rowmax)) { + +/* interchange rows and columns K and IMAX, */ +/* use 1-by-1 pivot block */ + + kp = imax; + +/* copy column KW-1 of W to column KW of W */ + + scopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + + done = TRUE_; + +/* Equivalent to testing for ROWMAX.EQ.COLMAX, */ +/* (used to handle NaN and Inf) */ + + } else if (p == jmax || rowmax <= colmax) { + +/* interchange rows and columns K-1 and IMAX, */ +/* use 2-by-2 pivot block */ + + kp = imax; + kstep = 2; + done = TRUE_; + } else { + +/* Pivot not found: set params and repeat */ + + p = imax; + colmax = rowmax; + imax = jmax; + +/* Copy updated JMAXth (next IMAXth) column to Kth of W */ + + scopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + + } + +/* End pivot search loop body */ + + if (! done) { + goto L12; + } + + } + +/* ============================================================ */ + + kk = k - kstep + 1; + +/* KKW is the column of W which corresponds to column KK of A */ + + kkw = *nb + kk - *n; + + if (kstep == 2 && p != k) { + +/* Copy non-updated column K to column P */ + + i__1 = k - p; + scopy_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + (p + 1) * + a_dim1], lda); + scopy_(&p, &a[k * a_dim1 + 1], &c__1, &a[p * a_dim1 + 1], & + c__1); + +/* Interchange rows K and P in last N-K+1 columns of A */ +/* and last N-K+2 columns of W */ + + i__1 = *n - k + 1; + sswap_(&i__1, &a[k + k * a_dim1], lda, &a[p + k * a_dim1], + lda); + i__1 = *n - kk + 1; + sswap_(&i__1, &w[k + kkw * w_dim1], ldw, &w[p + kkw * w_dim1], + ldw); + } + +/* Updated column KP is already stored in column KKW of W */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP */ + + a[kp + k * a_dim1] = a[kk + k * a_dim1]; + i__1 = k - 1 - kp; + scopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + scopy_(&kp, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], & + c__1); + +/* Interchange rows KK and KP in last N-KK+1 columns */ +/* of A and W */ + + i__1 = *n - kk + 1; + sswap_(&i__1, &a[kk + kk * a_dim1], lda, &a[kp + kk * a_dim1], + lda); + i__1 = *n - kk + 1; + sswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column KW of W now holds */ + +/* W(k) = U(k)*D(k) */ + +/* where U(k) is the k-th column of U */ + +/* Store U(k) in column k of A */ + + scopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + if (k > 1) { + if ((r__1 = a[k + k * a_dim1], abs(r__1)) >= sfmin) { + r1 = 1.f / a[k + k * a_dim1]; + i__1 = k - 1; + sscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + } else if (a[k + k * a_dim1] != 0.f) { + i__1 = k - 1; + for (ii = 1; ii <= i__1; ++ii) { + a[ii + k * a_dim1] /= a[k + k * a_dim1]; +/* L14: */ + } + } + +/* Store the superdiagonal element of D in array E */ + + e[k] = 0.f; + + } + + } else { + +/* 2-by-2 pivot block D(k): columns KW and KW-1 of W now */ +/* hold */ + +/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */ + +/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ +/* of U */ + + if (k > 2) { + +/* Store U(k) and U(k-1) in columns k and k-1 of A */ + + d12 = w[k - 1 + kw * w_dim1]; + d11 = w[k + kw * w_dim1] / d12; + d22 = w[k - 1 + (kw - 1) * w_dim1] / d12; + t = 1.f / (d11 * d22 - 1.f); + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + a[j + (k - 1) * a_dim1] = t * ((d11 * w[j + (kw - 1) * + w_dim1] - w[j + kw * w_dim1]) / d12); + a[j + k * a_dim1] = t * ((d22 * w[j + kw * w_dim1] - + w[j + (kw - 1) * w_dim1]) / d12); +/* L20: */ + } + } + +/* Copy diagonal elements of D(K) to A, */ +/* copy superdiagonal element of D(K) to E(K) and */ +/* ZERO out superdiagonal entry of A */ + + a[k - 1 + (k - 1) * a_dim1] = w[k - 1 + (kw - 1) * w_dim1]; + a[k - 1 + k * a_dim1] = 0.f; + a[k + k * a_dim1] = w[k + kw * w_dim1]; + e[k] = w[k - 1 + kw * w_dim1]; + e[k - 1] = 0.f; + + } + +/* End column K is nonsingular */ + + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + goto L10; + +L30: + +/* Update the upper triangle of A11 (= A(1:k,1:k)) as */ + +/* A11 := A11 - U12*D*U12**T = A11 - U12*W**T */ + +/* computing blocks of NB columns at a time */ + + i__1 = -(*nb); + for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += + i__1) { +/* Computing MIN */ + i__2 = *nb, i__3 = k - j + 1; + jb = f2cmin(i__2,i__3); + +/* Update the upper triangle of the diagonal block */ + + i__2 = j + jb - 1; + for (jj = j; jj <= i__2; ++jj) { + i__3 = jj - j + 1; + i__4 = *n - k; + sgemv_("No transpose", &i__3, &i__4, &c_b9, &a[j + (k + 1) * + a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b10, + &a[j + jj * a_dim1], &c__1); +/* L40: */ + } + +/* Update the rectangular superdiagonal block */ + + if (j >= 2) { + i__2 = j - 1; + i__3 = *n - k; + sgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &c_b9, + &a[(k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * + w_dim1], ldw, &c_b10, &a[j * a_dim1 + 1], lda); + } +/* L50: */ + } + +/* Set KB to the number of columns factorized */ + + *kb = *n - k; + + } else { + +/* Factorize the leading columns of A using the lower triangle */ +/* of A and working forwards, and compute the matrix W = L21*D */ +/* for use in updating A22 */ + +/* Initialize the unused last entry of the subdiagonal array E. */ + + e[*n] = 0.f; + +/* K is the main loop index, increasing from 1 in steps of 1 or 2 */ + + k = 1; +L70: + +/* Exit from loop */ + + if (k >= *nb && *nb < *n || k > *n) { + goto L90; + } + + kstep = 1; + p = k; + +/* Copy column K of A to column K of W and update it */ + + i__1 = *n - k + 1; + scopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1); + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + sgemv_("No transpose", &i__1, &i__2, &c_b9, &a[k + a_dim1], lda, & + w[k + w_dim1], ldw, &c_b10, &w[k + k * w_dim1], &c__1); + } + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + absakk = (r__1 = w[k + k * w_dim1], abs(r__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k < *n) { + i__1 = *n - k; + imax = k + isamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + colmax = (r__1 = w[imax + k * w_dim1], abs(r__1)); + } else { + colmax = 0.f; + } + + if (f2cmax(absakk,colmax) == 0.f) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = *n - k + 1; + scopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + +/* Set E( K ) to zero */ + + if (k < *n) { + e[k] = 0.f; + } + + } else { + +/* ============================================================ */ + +/* Test for interchange */ + +/* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX */ +/* (used to handle NaN and Inf) */ + + if (! (absakk < alpha * colmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + + } else { + + done = FALSE_; + +/* Loop until pivot found */ + +L72: + +/* Begin pivot search loop body */ + + +/* Copy column IMAX to column K+1 of W and update it */ + + i__1 = imax - k; + scopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = *n - imax + 1; + scopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + + 1) * w_dim1], &c__1); + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + sgemv_("No transpose", &i__1, &i__2, &c_b9, &a[k + a_dim1] + , lda, &w[imax + w_dim1], ldw, &c_b10, &w[k + (k + + 1) * w_dim1], &c__1); + } + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine both ROWMAX and JMAX. */ + + if (imax != k) { + i__1 = imax - k; + jmax = k - 1 + isamax_(&i__1, &w[k + (k + 1) * w_dim1], & + c__1); + rowmax = (r__1 = w[jmax + (k + 1) * w_dim1], abs(r__1)); + } else { + rowmax = 0.f; + } + + if (imax < *n) { + i__1 = *n - imax; + itemp = imax + isamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); + stemp = (r__1 = w[itemp + (k + 1) * w_dim1], abs(r__1)); + if (stemp > rowmax) { + rowmax = stemp; + jmax = itemp; + } + } + +/* Equivalent to testing for */ +/* ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX */ +/* (used to handle NaN and Inf) */ + + if (! ((r__1 = w[imax + (k + 1) * w_dim1], abs(r__1)) < alpha + * rowmax)) { + +/* interchange rows and columns K and IMAX, */ +/* use 1-by-1 pivot block */ + + kp = imax; + +/* copy column K+1 of W to column K of W */ + + i__1 = *n - k + 1; + scopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + + done = TRUE_; + +/* Equivalent to testing for ROWMAX.EQ.COLMAX, */ +/* (used to handle NaN and Inf) */ + + } else if (p == jmax || rowmax <= colmax) { + +/* interchange rows and columns K+1 and IMAX, */ +/* use 2-by-2 pivot block */ + + kp = imax; + kstep = 2; + done = TRUE_; + } else { + +/* Pivot not found: set params and repeat */ + + p = imax; + colmax = rowmax; + imax = jmax; + +/* Copy updated JMAXth (next IMAXth) column to Kth of W */ + + i__1 = *n - k + 1; + scopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + + } + +/* End pivot search loop body */ + + if (! done) { + goto L72; + } + + } + +/* ============================================================ */ + + kk = k + kstep - 1; + + if (kstep == 2 && p != k) { + +/* Copy non-updated column K to column P */ + + i__1 = p - k; + scopy_(&i__1, &a[k + k * a_dim1], &c__1, &a[p + k * a_dim1], + lda); + i__1 = *n - p + 1; + scopy_(&i__1, &a[p + k * a_dim1], &c__1, &a[p + p * a_dim1], & + c__1); + +/* Interchange rows K and P in first K columns of A */ +/* and first K+1 columns of W */ + + sswap_(&k, &a[k + a_dim1], lda, &a[p + a_dim1], lda); + sswap_(&kk, &w[k + w_dim1], ldw, &w[p + w_dim1], ldw); + } + +/* Updated column KP is already stored in column KK of W */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP */ + + a[kp + k * a_dim1] = a[kk + k * a_dim1]; + i__1 = kp - k - 1; + scopy_(&i__1, &a[k + 1 + kk * a_dim1], &c__1, &a[kp + (k + 1) + * a_dim1], lda); + i__1 = *n - kp + 1; + scopy_(&i__1, &a[kp + kk * a_dim1], &c__1, &a[kp + kp * + a_dim1], &c__1); + +/* Interchange rows KK and KP in first KK columns of A and W */ + + sswap_(&kk, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + sswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k of W now holds */ + +/* W(k) = L(k)*D(k) */ + +/* where L(k) is the k-th column of L */ + +/* Store L(k) in column k of A */ + + i__1 = *n - k + 1; + scopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + if ((r__1 = a[k + k * a_dim1], abs(r__1)) >= sfmin) { + r1 = 1.f / a[k + k * a_dim1]; + i__1 = *n - k; + sscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + } else if (a[k + k * a_dim1] != 0.f) { + i__1 = *n; + for (ii = k + 1; ii <= i__1; ++ii) { + a[ii + k * a_dim1] /= a[k + k * a_dim1]; +/* L74: */ + } + } + +/* Store the subdiagonal element of D in array E */ + + e[k] = 0.f; + + } + + } else { + +/* 2-by-2 pivot block D(k): columns k and k+1 of W now hold */ + +/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */ + +/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */ +/* of L */ + + if (k < *n - 1) { + +/* Store L(k) and L(k+1) in columns k and k+1 of A */ + + d21 = w[k + 1 + k * w_dim1]; + d11 = w[k + 1 + (k + 1) * w_dim1] / d21; + d22 = w[k + k * w_dim1] / d21; + t = 1.f / (d11 * d22 - 1.f); + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + a[j + k * a_dim1] = t * ((d11 * w[j + k * w_dim1] - w[ + j + (k + 1) * w_dim1]) / d21); + a[j + (k + 1) * a_dim1] = t * ((d22 * w[j + (k + 1) * + w_dim1] - w[j + k * w_dim1]) / d21); +/* L80: */ + } + } + +/* Copy diagonal elements of D(K) to A, */ +/* copy subdiagonal element of D(K) to E(K) and */ +/* ZERO out subdiagonal entry of A */ + + a[k + k * a_dim1] = w[k + k * w_dim1]; + a[k + 1 + k * a_dim1] = 0.f; + a[k + 1 + (k + 1) * a_dim1] = w[k + 1 + (k + 1) * w_dim1]; + e[k] = w[k + 1 + k * w_dim1]; + e[k + 1] = 0.f; + + } + +/* End column K is nonsingular */ + + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + goto L70; + +L90: + +/* Update the lower triangle of A22 (= A(k:n,k:n)) as */ + +/* A22 := A22 - L21*D*L21**T = A22 - L21*W**T */ + +/* computing blocks of NB columns at a time */ + + i__1 = *n; + i__2 = *nb; + for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = *nb, i__4 = *n - j + 1; + jb = f2cmin(i__3,i__4); + +/* Update the lower triangle of the diagonal block */ + + i__3 = j + jb - 1; + for (jj = j; jj <= i__3; ++jj) { + i__4 = j + jb - jj; + i__5 = k - 1; + sgemv_("No transpose", &i__4, &i__5, &c_b9, &a[jj + a_dim1], + lda, &w[jj + w_dim1], ldw, &c_b10, &a[jj + jj * + a_dim1], &c__1); +/* L100: */ + } + +/* Update the rectangular subdiagonal block */ + + if (j + jb <= *n) { + i__3 = *n - j - jb + 1; + i__4 = k - 1; + sgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &c_b9, + &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b10, + &a[j + jb + j * a_dim1], lda); + } +/* L110: */ + } + +/* Set KB to the number of columns factorized */ + + *kb = k - 1; + + } + + return 0; + +/* End of SLASYF_RK */ + +} /* slasyf_rk__ */ + diff --git a/lapack-netlib/SRC/slasyf_rook.c b/lapack-netlib/SRC/slasyf_rook.c new file mode 100644 index 000000000..d27d5fbae --- /dev/null +++ b/lapack-netlib/SRC/slasyf_rook.c @@ -0,0 +1,1402 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLASYF_ROOK computes a partial factorization of a real symmetric matrix using the bounded Bunch +-Kaufman ("rook") diagonal pivoting method. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLASYF_ROOK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLASYF_ROOK( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, KB, LDA, LDW, N, NB */ +/* INTEGER IPIV( * ) */ +/* REAL A( LDA, * ), W( LDW, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLASYF_ROOK computes a partial factorization of a real symmetric */ +/* > matrix A using the bounded Bunch-Kaufman ("rook") diagonal */ +/* > pivoting method. The partial factorization has the form: */ +/* > */ +/* > A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or: */ +/* > ( 0 U22 ) ( 0 D ) ( U12**T U22**T ) */ +/* > */ +/* > A = ( L11 0 ) ( D 0 ) ( L11**T L21**T ) if UPLO = 'L' */ +/* > ( L21 I ) ( 0 A22 ) ( 0 I ) */ +/* > */ +/* > where the order of D is at most NB. The actual order is returned in */ +/* > the argument KB, and is either NB or NB-1, or N if N <= NB. */ +/* > */ +/* > SLASYF_ROOK is an auxiliary routine called by SSYTRF_ROOK. It uses */ +/* > blocked code (calling Level 3 BLAS) to update the submatrix */ +/* > A11 (if UPLO = 'U') or A22 (if UPLO = 'L'). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The maximum number of columns of the matrix A that should be */ +/* > factored. NB should be at least 2 to allow for 2-by-2 pivot */ +/* > blocks. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] KB */ +/* > \verbatim */ +/* > KB is INTEGER */ +/* > The number of columns of A that were actually factored. */ +/* > KB is either NB-1 or NB, or N if N <= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > n-by-n upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading n-by-n lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > On exit, A contains details of the partial factorization. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D. */ +/* > */ +/* > If UPLO = 'U': */ +/* > Only the last KB elements of IPIV are set. */ +/* > */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* > interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and */ +/* > columns k and -IPIV(k) were interchanged and rows and */ +/* > columns k-1 and -IPIV(k-1) were inerchaged, */ +/* > D(k-1:k,k-1:k) is a 2-by-2 diagonal block. */ +/* > */ +/* > If UPLO = 'L': */ +/* > Only the first KB elements of IPIV are set. */ +/* > */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) */ +/* > were interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and */ +/* > columns k and -IPIV(k) were interchanged and rows and */ +/* > columns k+1 and -IPIV(k+1) were inerchaged, */ +/* > D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is REAL array, dimension (LDW,NB) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDW */ +/* > \verbatim */ +/* > LDW is INTEGER */ +/* > The leading dimension of the array W. LDW >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > > 0: if INFO = k, D(k,k) is exactly zero. The factorization */ +/* > has been completed, but the block diagonal matrix D is */ +/* > exactly singular. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2013 */ + +/* > \ingroup realSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2013, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int slasyf_rook_(char *uplo, integer *n, integer *nb, + integer *kb, real *a, integer *lda, integer *ipiv, real *w, integer * + ldw, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3, i__4, i__5; + real r__1; + + /* Local variables */ + logical done; + integer imax, jmax, j, k, p; + real t, alpha; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), + sgemm_(char *, char *, integer *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *); + real sfmin; + integer itemp; + extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *); + integer kstep; + real stemp; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *), sswap_(integer *, real *, integer *, real *, integer * + ); + real r1, d11, d12, d21, d22; + integer jb, ii, jj, kk, kp; + real absakk; + integer kw; + extern real slamch_(char *); + extern integer isamax_(integer *, real *, integer *); + real colmax; + integer jp1, jp2; + real rowmax; + integer kkw; + + +/* -- LAPACK computational routine (version 3.5.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2013 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + w_dim1 = *ldw; + w_offset = 1 + w_dim1 * 1; + w -= w_offset; + + /* Function Body */ + *info = 0; + +/* Initialize ALPHA for use in choosing pivot block size. */ + + alpha = (sqrt(17.f) + 1.f) / 8.f; + +/* Compute machine safe minimum */ + + sfmin = slamch_("S"); + + if (lsame_(uplo, "U")) { + +/* Factorize the trailing columns of A using the upper triangle */ +/* of A and working backwards, and compute the matrix W = U12*D */ +/* for use in updating A11 */ + +/* K is the main loop index, decreasing from N in steps of 1 or 2 */ + + k = *n; +L10: + +/* KW is the column of W which corresponds to column K of A */ + + kw = *nb + k - *n; + +/* Exit from loop */ + + if (k <= *n - *nb + 1 && *nb < *n || k < 1) { + goto L30; + } + + kstep = 1; + p = k; + +/* Copy column K of A to column KW of W and update it */ + + scopy_(&k, &a[k * a_dim1 + 1], &c__1, &w[kw * w_dim1 + 1], &c__1); + if (k < *n) { + i__1 = *n - k; + sgemv_("No transpose", &k, &i__1, &c_b9, &a[(k + 1) * a_dim1 + 1], + lda, &w[k + (kw + 1) * w_dim1], ldw, &c_b10, &w[kw * + w_dim1 + 1], &c__1); + } + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + absakk = (r__1 = w[k + kw * w_dim1], abs(r__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k > 1) { + i__1 = k - 1; + imax = isamax_(&i__1, &w[kw * w_dim1 + 1], &c__1); + colmax = (r__1 = w[imax + kw * w_dim1], abs(r__1)); + } else { + colmax = 0.f; + } + + if (f2cmax(absakk,colmax) == 0.f) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + scopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], &c__1); + } else { + +/* ============================================================ */ + +/* Test for interchange */ + +/* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX */ +/* (used to handle NaN and Inf) */ + + if (! (absakk < alpha * colmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + + } else { + + done = FALSE_; + +/* Loop until pivot found */ + +L12: + +/* Begin pivot search loop body */ + + +/* Copy column IMAX to column KW-1 of W and update it */ + + scopy_(&imax, &a[imax * a_dim1 + 1], &c__1, &w[(kw - 1) * + w_dim1 + 1], &c__1); + i__1 = k - imax; + scopy_(&i__1, &a[imax + (imax + 1) * a_dim1], lda, &w[imax + + 1 + (kw - 1) * w_dim1], &c__1); + + if (k < *n) { + i__1 = *n - k; + sgemv_("No transpose", &k, &i__1, &c_b9, &a[(k + 1) * + a_dim1 + 1], lda, &w[imax + (kw + 1) * w_dim1], + ldw, &c_b10, &w[(kw - 1) * w_dim1 + 1], &c__1); + } + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine both ROWMAX and JMAX. */ + + if (imax != k) { + i__1 = k - imax; + jmax = imax + isamax_(&i__1, &w[imax + 1 + (kw - 1) * + w_dim1], &c__1); + rowmax = (r__1 = w[jmax + (kw - 1) * w_dim1], abs(r__1)); + } else { + rowmax = 0.f; + } + + if (imax > 1) { + i__1 = imax - 1; + itemp = isamax_(&i__1, &w[(kw - 1) * w_dim1 + 1], &c__1); + stemp = (r__1 = w[itemp + (kw - 1) * w_dim1], abs(r__1)); + if (stemp > rowmax) { + rowmax = stemp; + jmax = itemp; + } + } + +/* Equivalent to testing for */ +/* ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX */ +/* (used to handle NaN and Inf) */ + + if (! ((r__1 = w[imax + (kw - 1) * w_dim1], abs(r__1)) < + alpha * rowmax)) { + +/* interchange rows and columns K and IMAX, */ +/* use 1-by-1 pivot block */ + + kp = imax; + +/* copy column KW-1 of W to column KW of W */ + + scopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + + done = TRUE_; + +/* Equivalent to testing for ROWMAX.EQ.COLMAX, */ +/* (used to handle NaN and Inf) */ + + } else if (p == jmax || rowmax <= colmax) { + +/* interchange rows and columns K-1 and IMAX, */ +/* use 2-by-2 pivot block */ + + kp = imax; + kstep = 2; + done = TRUE_; + } else { + +/* Pivot not found: set params and repeat */ + + p = imax; + colmax = rowmax; + imax = jmax; + +/* Copy updated JMAXth (next IMAXth) column to Kth of W */ + + scopy_(&k, &w[(kw - 1) * w_dim1 + 1], &c__1, &w[kw * + w_dim1 + 1], &c__1); + + } + +/* End pivot search loop body */ + + if (! done) { + goto L12; + } + + } + +/* ============================================================ */ + + kk = k - kstep + 1; + +/* KKW is the column of W which corresponds to column KK of A */ + + kkw = *nb + kk - *n; + + if (kstep == 2 && p != k) { + +/* Copy non-updated column K to column P */ + + i__1 = k - p; + scopy_(&i__1, &a[p + 1 + k * a_dim1], &c__1, &a[p + (p + 1) * + a_dim1], lda); + scopy_(&p, &a[k * a_dim1 + 1], &c__1, &a[p * a_dim1 + 1], & + c__1); + +/* Interchange rows K and P in last N-K+1 columns of A */ +/* and last N-K+2 columns of W */ + + i__1 = *n - k + 1; + sswap_(&i__1, &a[k + k * a_dim1], lda, &a[p + k * a_dim1], + lda); + i__1 = *n - kk + 1; + sswap_(&i__1, &w[k + kkw * w_dim1], ldw, &w[p + kkw * w_dim1], + ldw); + } + +/* Updated column KP is already stored in column KKW of W */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP */ + + a[kp + k * a_dim1] = a[kk + k * a_dim1]; + i__1 = k - 1 - kp; + scopy_(&i__1, &a[kp + 1 + kk * a_dim1], &c__1, &a[kp + (kp + + 1) * a_dim1], lda); + scopy_(&kp, &a[kk * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], & + c__1); + +/* Interchange rows KK and KP in last N-KK+1 columns */ +/* of A and W */ + + i__1 = *n - kk + 1; + sswap_(&i__1, &a[kk + kk * a_dim1], lda, &a[kp + kk * a_dim1], + lda); + i__1 = *n - kk + 1; + sswap_(&i__1, &w[kk + kkw * w_dim1], ldw, &w[kp + kkw * + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column KW of W now holds */ + +/* W(k) = U(k)*D(k) */ + +/* where U(k) is the k-th column of U */ + +/* Store U(k) in column k of A */ + + scopy_(&k, &w[kw * w_dim1 + 1], &c__1, &a[k * a_dim1 + 1], & + c__1); + if (k > 1) { + if ((r__1 = a[k + k * a_dim1], abs(r__1)) >= sfmin) { + r1 = 1.f / a[k + k * a_dim1]; + i__1 = k - 1; + sscal_(&i__1, &r1, &a[k * a_dim1 + 1], &c__1); + } else if (a[k + k * a_dim1] != 0.f) { + i__1 = k - 1; + for (ii = 1; ii <= i__1; ++ii) { + a[ii + k * a_dim1] /= a[k + k * a_dim1]; +/* L14: */ + } + } + } + + } else { + +/* 2-by-2 pivot block D(k): columns KW and KW-1 of W now */ +/* hold */ + +/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */ + +/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ +/* of U */ + + if (k > 2) { + +/* Store U(k) and U(k-1) in columns k and k-1 of A */ + + d12 = w[k - 1 + kw * w_dim1]; + d11 = w[k + kw * w_dim1] / d12; + d22 = w[k - 1 + (kw - 1) * w_dim1] / d12; + t = 1.f / (d11 * d22 - 1.f); + i__1 = k - 2; + for (j = 1; j <= i__1; ++j) { + a[j + (k - 1) * a_dim1] = t * ((d11 * w[j + (kw - 1) * + w_dim1] - w[j + kw * w_dim1]) / d12); + a[j + k * a_dim1] = t * ((d22 * w[j + kw * w_dim1] - + w[j + (kw - 1) * w_dim1]) / d12); +/* L20: */ + } + } + +/* Copy D(k) to A */ + + a[k - 1 + (k - 1) * a_dim1] = w[k - 1 + (kw - 1) * w_dim1]; + a[k - 1 + k * a_dim1] = w[k - 1 + kw * w_dim1]; + a[k + k * a_dim1] = w[k + kw * w_dim1]; + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + goto L10; + +L30: + +/* Update the upper triangle of A11 (= A(1:k,1:k)) as */ + +/* A11 := A11 - U12*D*U12**T = A11 - U12*W**T */ + +/* computing blocks of NB columns at a time */ + + i__1 = -(*nb); + for (j = (k - 1) / *nb * *nb + 1; i__1 < 0 ? j >= 1 : j <= 1; j += + i__1) { +/* Computing MIN */ + i__2 = *nb, i__3 = k - j + 1; + jb = f2cmin(i__2,i__3); + +/* Update the upper triangle of the diagonal block */ + + i__2 = j + jb - 1; + for (jj = j; jj <= i__2; ++jj) { + i__3 = jj - j + 1; + i__4 = *n - k; + sgemv_("No transpose", &i__3, &i__4, &c_b9, &a[j + (k + 1) * + a_dim1], lda, &w[jj + (kw + 1) * w_dim1], ldw, &c_b10, + &a[j + jj * a_dim1], &c__1); +/* L40: */ + } + +/* Update the rectangular superdiagonal block */ + + if (j >= 2) { + i__2 = j - 1; + i__3 = *n - k; + sgemm_("No transpose", "Transpose", &i__2, &jb, &i__3, &c_b9, + &a[(k + 1) * a_dim1 + 1], lda, &w[j + (kw + 1) * + w_dim1], ldw, &c_b10, &a[j * a_dim1 + 1], lda); + } +/* L50: */ + } + +/* Put U12 in standard form by partially undoing the interchanges */ +/* in columns k+1:n */ + + j = k + 1; +L60: + + kstep = 1; + jp1 = 1; + jj = j; + jp2 = ipiv[j]; + if (jp2 < 0) { + jp2 = -jp2; + ++j; + jp1 = -ipiv[j]; + kstep = 2; + } + + ++j; + if (jp2 != jj && j <= *n) { + i__1 = *n - j + 1; + sswap_(&i__1, &a[jp2 + j * a_dim1], lda, &a[jj + j * a_dim1], lda) + ; + } + jj = j - 1; + if (jp1 != jj && kstep == 2) { + i__1 = *n - j + 1; + sswap_(&i__1, &a[jp1 + j * a_dim1], lda, &a[jj + j * a_dim1], lda) + ; + } + if (j <= *n) { + goto L60; + } + +/* Set KB to the number of columns factorized */ + + *kb = *n - k; + + } else { + +/* Factorize the leading columns of A using the lower triangle */ +/* of A and working forwards, and compute the matrix W = L21*D */ +/* for use in updating A22 */ + +/* K is the main loop index, increasing from 1 in steps of 1 or 2 */ + + k = 1; +L70: + +/* Exit from loop */ + + if (k >= *nb && *nb < *n || k > *n) { + goto L90; + } + + kstep = 1; + p = k; + +/* Copy column K of A to column K of W and update it */ + + i__1 = *n - k + 1; + scopy_(&i__1, &a[k + k * a_dim1], &c__1, &w[k + k * w_dim1], &c__1); + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + sgemv_("No transpose", &i__1, &i__2, &c_b9, &a[k + a_dim1], lda, & + w[k + w_dim1], ldw, &c_b10, &w[k + k * w_dim1], &c__1); + } + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + absakk = (r__1 = w[k + k * w_dim1], abs(r__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value. */ +/* Determine both COLMAX and IMAX. */ + + if (k < *n) { + i__1 = *n - k; + imax = k + isamax_(&i__1, &w[k + 1 + k * w_dim1], &c__1); + colmax = (r__1 = w[imax + k * w_dim1], abs(r__1)); + } else { + colmax = 0.f; + } + + if (f2cmax(absakk,colmax) == 0.f) { + +/* Column K is zero or underflow: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = *n - k + 1; + scopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + } else { + +/* ============================================================ */ + +/* Test for interchange */ + +/* Equivalent to testing for ABSAKK.GE.ALPHA*COLMAX */ +/* (used to handle NaN and Inf) */ + + if (! (absakk < alpha * colmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + + } else { + + done = FALSE_; + +/* Loop until pivot found */ + +L72: + +/* Begin pivot search loop body */ + + +/* Copy column IMAX to column K+1 of W and update it */ + + i__1 = imax - k; + scopy_(&i__1, &a[imax + k * a_dim1], lda, &w[k + (k + 1) * + w_dim1], &c__1); + i__1 = *n - imax + 1; + scopy_(&i__1, &a[imax + imax * a_dim1], &c__1, &w[imax + (k + + 1) * w_dim1], &c__1); + if (k > 1) { + i__1 = *n - k + 1; + i__2 = k - 1; + sgemv_("No transpose", &i__1, &i__2, &c_b9, &a[k + a_dim1] + , lda, &w[imax + w_dim1], ldw, &c_b10, &w[k + (k + + 1) * w_dim1], &c__1); + } + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value. */ +/* Determine both ROWMAX and JMAX. */ + + if (imax != k) { + i__1 = imax - k; + jmax = k - 1 + isamax_(&i__1, &w[k + (k + 1) * w_dim1], & + c__1); + rowmax = (r__1 = w[jmax + (k + 1) * w_dim1], abs(r__1)); + } else { + rowmax = 0.f; + } + + if (imax < *n) { + i__1 = *n - imax; + itemp = imax + isamax_(&i__1, &w[imax + 1 + (k + 1) * + w_dim1], &c__1); + stemp = (r__1 = w[itemp + (k + 1) * w_dim1], abs(r__1)); + if (stemp > rowmax) { + rowmax = stemp; + jmax = itemp; + } + } + +/* Equivalent to testing for */ +/* ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX */ +/* (used to handle NaN and Inf) */ + + if (! ((r__1 = w[imax + (k + 1) * w_dim1], abs(r__1)) < alpha + * rowmax)) { + +/* interchange rows and columns K and IMAX, */ +/* use 1-by-1 pivot block */ + + kp = imax; + +/* copy column K+1 of W to column K of W */ + + i__1 = *n - k + 1; + scopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + + done = TRUE_; + +/* Equivalent to testing for ROWMAX.EQ.COLMAX, */ +/* (used to handle NaN and Inf) */ + + } else if (p == jmax || rowmax <= colmax) { + +/* interchange rows and columns K+1 and IMAX, */ +/* use 2-by-2 pivot block */ + + kp = imax; + kstep = 2; + done = TRUE_; + } else { + +/* Pivot not found: set params and repeat */ + + p = imax; + colmax = rowmax; + imax = jmax; + +/* Copy updated JMAXth (next IMAXth) column to Kth of W */ + + i__1 = *n - k + 1; + scopy_(&i__1, &w[k + (k + 1) * w_dim1], &c__1, &w[k + k * + w_dim1], &c__1); + + } + +/* End pivot search loop body */ + + if (! done) { + goto L72; + } + + } + +/* ============================================================ */ + + kk = k + kstep - 1; + + if (kstep == 2 && p != k) { + +/* Copy non-updated column K to column P */ + + i__1 = p - k; + scopy_(&i__1, &a[k + k * a_dim1], &c__1, &a[p + k * a_dim1], + lda); + i__1 = *n - p + 1; + scopy_(&i__1, &a[p + k * a_dim1], &c__1, &a[p + p * a_dim1], & + c__1); + +/* Interchange rows K and P in first K columns of A */ +/* and first K+1 columns of W */ + + sswap_(&k, &a[k + a_dim1], lda, &a[p + a_dim1], lda); + sswap_(&kk, &w[k + w_dim1], ldw, &w[p + w_dim1], ldw); + } + +/* Updated column KP is already stored in column KK of W */ + + if (kp != kk) { + +/* Copy non-updated column KK to column KP */ + + a[kp + k * a_dim1] = a[kk + k * a_dim1]; + i__1 = kp - k - 1; + scopy_(&i__1, &a[k + 1 + kk * a_dim1], &c__1, &a[kp + (k + 1) + * a_dim1], lda); + i__1 = *n - kp + 1; + scopy_(&i__1, &a[kp + kk * a_dim1], &c__1, &a[kp + kp * + a_dim1], &c__1); + +/* Interchange rows KK and KP in first KK columns of A and W */ + + sswap_(&kk, &a[kk + a_dim1], lda, &a[kp + a_dim1], lda); + sswap_(&kk, &w[kk + w_dim1], ldw, &w[kp + w_dim1], ldw); + } + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k of W now holds */ + +/* W(k) = L(k)*D(k) */ + +/* where L(k) is the k-th column of L */ + +/* Store L(k) in column k of A */ + + i__1 = *n - k + 1; + scopy_(&i__1, &w[k + k * w_dim1], &c__1, &a[k + k * a_dim1], & + c__1); + if (k < *n) { + if ((r__1 = a[k + k * a_dim1], abs(r__1)) >= sfmin) { + r1 = 1.f / a[k + k * a_dim1]; + i__1 = *n - k; + sscal_(&i__1, &r1, &a[k + 1 + k * a_dim1], &c__1); + } else if (a[k + k * a_dim1] != 0.f) { + i__1 = *n; + for (ii = k + 1; ii <= i__1; ++ii) { + a[ii + k * a_dim1] /= a[k + k * a_dim1]; +/* L74: */ + } + } + } + + } else { + +/* 2-by-2 pivot block D(k): columns k and k+1 of W now hold */ + +/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */ + +/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */ +/* of L */ + + if (k < *n - 1) { + +/* Store L(k) and L(k+1) in columns k and k+1 of A */ + + d21 = w[k + 1 + k * w_dim1]; + d11 = w[k + 1 + (k + 1) * w_dim1] / d21; + d22 = w[k + k * w_dim1] / d21; + t = 1.f / (d11 * d22 - 1.f); + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + a[j + k * a_dim1] = t * ((d11 * w[j + k * w_dim1] - w[ + j + (k + 1) * w_dim1]) / d21); + a[j + (k + 1) * a_dim1] = t * ((d22 * w[j + (k + 1) * + w_dim1] - w[j + k * w_dim1]) / d21); +/* L80: */ + } + } + +/* Copy D(k) to A */ + + a[k + k * a_dim1] = w[k + k * w_dim1]; + a[k + 1 + k * a_dim1] = w[k + 1 + k * w_dim1]; + a[k + 1 + (k + 1) * a_dim1] = w[k + 1 + (k + 1) * w_dim1]; + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -p; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + goto L70; + +L90: + +/* Update the lower triangle of A22 (= A(k:n,k:n)) as */ + +/* A22 := A22 - L21*D*L21**T = A22 - L21*W**T */ + +/* computing blocks of NB columns at a time */ + + i__1 = *n; + i__2 = *nb; + for (j = k; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = *nb, i__4 = *n - j + 1; + jb = f2cmin(i__3,i__4); + +/* Update the lower triangle of the diagonal block */ + + i__3 = j + jb - 1; + for (jj = j; jj <= i__3; ++jj) { + i__4 = j + jb - jj; + i__5 = k - 1; + sgemv_("No transpose", &i__4, &i__5, &c_b9, &a[jj + a_dim1], + lda, &w[jj + w_dim1], ldw, &c_b10, &a[jj + jj * + a_dim1], &c__1); +/* L100: */ + } + +/* Update the rectangular subdiagonal block */ + + if (j + jb <= *n) { + i__3 = *n - j - jb + 1; + i__4 = k - 1; + sgemm_("No transpose", "Transpose", &i__3, &jb, &i__4, &c_b9, + &a[j + jb + a_dim1], lda, &w[j + w_dim1], ldw, &c_b10, + &a[j + jb + j * a_dim1], lda); + } +/* L110: */ + } + +/* Put L21 in standard form by partially undoing the interchanges */ +/* in columns 1:k-1 */ + + j = k - 1; +L120: + + kstep = 1; + jp1 = 1; + jj = j; + jp2 = ipiv[j]; + if (jp2 < 0) { + jp2 = -jp2; + --j; + jp1 = -ipiv[j]; + kstep = 2; + } + + --j; + if (jp2 != jj && j >= 1) { + sswap_(&j, &a[jp2 + a_dim1], lda, &a[jj + a_dim1], lda); + } + jj = j + 1; + if (jp1 != jj && kstep == 2) { + sswap_(&j, &a[jp1 + a_dim1], lda, &a[jj + a_dim1], lda); + } + if (j >= 1) { + goto L120; + } + +/* Set KB to the number of columns factorized */ + + *kb = k - 1; + + } + return 0; + +/* End of SLASYF_ROOK */ + +} /* slasyf_rook__ */ + diff --git a/lapack-netlib/SRC/slatbs.c b/lapack-netlib/SRC/slatbs.c new file mode 100644 index 000000000..66622989b --- /dev/null +++ b/lapack-netlib/SRC/slatbs.c @@ -0,0 +1,1296 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLATBS solves a triangular banded system of equations. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLATBS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X, */ +/* SCALE, CNORM, INFO ) */ + +/* CHARACTER DIAG, NORMIN, TRANS, UPLO */ +/* INTEGER INFO, KD, LDAB, N */ +/* REAL SCALE */ +/* REAL AB( LDAB, * ), CNORM( * ), X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLATBS solves one of the triangular systems */ +/* > */ +/* > A *x = s*b or A**T*x = s*b */ +/* > */ +/* > with scaling to prevent overflow, where A is an upper or lower */ +/* > triangular band matrix. Here A**T denotes the transpose of A, x and b */ +/* > are n-element vectors, and s is a scaling factor, usually less than */ +/* > or equal to 1, chosen so that the components of x will be less than */ +/* > the overflow threshold. If the unscaled problem will not cause */ +/* > overflow, the Level 2 BLAS routine STBSV is called. If the matrix A */ +/* > is singular (A(j,j) = 0 for some j), then s is set to 0 and a */ +/* > non-trivial solution to A*x = 0 is returned. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the matrix A is upper or lower triangular. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the operation applied to A. */ +/* > = 'N': Solve A * x = s*b (No transpose) */ +/* > = 'T': Solve A**T* x = s*b (Transpose) */ +/* > = 'C': Solve A**T* x = s*b (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > Specifies whether or not the matrix A is unit triangular. */ +/* > = 'N': Non-unit triangular */ +/* > = 'U': Unit triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NORMIN */ +/* > \verbatim */ +/* > NORMIN is CHARACTER*1 */ +/* > Specifies whether CNORM has been set or not. */ +/* > = 'Y': CNORM contains the column norms on entry */ +/* > = 'N': CNORM is not set on entry. On exit, the norms will */ +/* > be computed and stored in CNORM. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of subdiagonals or superdiagonals in the */ +/* > triangular matrix A. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is 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). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (N) */ +/* > On entry, the right hand side b of the triangular system. */ +/* > On exit, X is overwritten by the solution vector x. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE */ +/* > \verbatim */ +/* > SCALE is REAL */ +/* > The scaling factor s for the triangular system */ +/* > A * x = s*b or A**T* x = s*b. */ +/* > If SCALE = 0, the matrix A is singular or badly scaled, and */ +/* > the vector x is an exact or approximate solution to A*x = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] CNORM */ +/* > \verbatim */ +/* > CNORM is REAL array, dimension (N) */ +/* > */ +/* > If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */ +/* > contains the norm of the off-diagonal part of the j-th column */ +/* > of A. If TRANS = 'N', CNORM(j) must be greater than or equal */ +/* > to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */ +/* > must be greater than or equal to the 1-norm. */ +/* > */ +/* > If NORMIN = 'N', CNORM is an output argument and CNORM(j) */ +/* > returns the 1-norm of the offdiagonal part of the j-th column */ +/* > of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > A rough bound on x is computed; if that is less than overflow, STBSV */ +/* > is called, otherwise, specific code is used which checks for possible */ +/* > overflow or divide-by-zero at every operation. */ +/* > */ +/* > A columnwise scheme is used for solving A*x = b. The basic algorithm */ +/* > if A is lower triangular is */ +/* > */ +/* > x[1:n] := b[1:n] */ +/* > for j = 1, ..., n */ +/* > x(j) := x(j) / A(j,j) */ +/* > x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */ +/* > end */ +/* > */ +/* > Define bounds on the components of x after j iterations of the loop: */ +/* > M(j) = bound on x[1:j] */ +/* > G(j) = bound on x[j+1:n] */ +/* > Initially, let M(0) = 0 and G(0) = f2cmax{x(i), i=1,...,n}. */ +/* > */ +/* > Then for iteration j+1 we have */ +/* > M(j+1) <= G(j) / | A(j+1,j+1) | */ +/* > G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */ +/* > <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */ +/* > */ +/* > where CNORM(j+1) is greater than or equal to the infinity-norm of */ +/* > column j+1 of A, not counting the diagonal. Hence */ +/* > */ +/* > G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */ +/* > 1<=i<=j */ +/* > and */ +/* > */ +/* > |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */ +/* > 1<=i< j */ +/* > */ +/* > Since |x(j)| <= M(j), we use the Level 2 BLAS routine STBSV if the */ +/* > reciprocal of the largest M(j), j=1,..,n, is larger than */ +/* > f2cmax(underflow, 1/overflow). */ +/* > */ +/* > The bound on x(j) is also used to determine when a step in the */ +/* > columnwise method can be performed without fear of overflow. If */ +/* > the computed bound is greater than a large constant, x is scaled to */ +/* > prevent overflow, but if the bound overflows, x is set to 0, x(j) to */ +/* > 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */ +/* > */ +/* > Similarly, a row-wise scheme is used to solve A**T*x = b. The basic */ +/* > algorithm for A upper triangular is */ +/* > */ +/* > for j = 1, ..., n */ +/* > x(j) := ( b(j) - A[1:j-1,j]**T * x[1:j-1] ) / A(j,j) */ +/* > end */ +/* > */ +/* > We simultaneously compute two bounds */ +/* > G(j) = bound on ( b(i) - A[1:i-1,i]**T * x[1:i-1] ), 1<=i<=j */ +/* > M(j) = bound on x(i), 1<=i<=j */ +/* > */ +/* > The initial values are G(0) = 0, M(0) = f2cmax{b(i), i=1,..,n}, and we */ +/* > add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */ +/* > Then the bound on x(j) is */ +/* > */ +/* > M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */ +/* > */ +/* > <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */ +/* > 1<=i<=j */ +/* > */ +/* > and we can safely call STBSV if 1/M(n) and 1/G(n) are both greater */ +/* > than f2cmax(underflow, 1/overflow). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slatbs_(char *uplo, char *trans, char *diag, char * + normin, integer *n, integer *kd, real *ab, integer *ldab, real *x, + real *scale, real *cnorm, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; + real r__1, r__2, r__3; + + /* Local variables */ + integer jinc, jlen; + real xbnd; + integer imax; + real tmax, tjjs; + extern real sdot_(integer *, real *, integer *, real *, integer *); + real xmax, grow, sumj; + integer i__, j, maind; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + real tscal, uscal; + integer jlast; + extern real sasum_(integer *, real *, integer *); + logical upper; + extern /* Subroutine */ int stbsv_(char *, char *, char *, integer *, + integer *, real *, integer *, real *, integer *), saxpy_(integer *, real *, real *, integer *, real *, + integer *); + real xj; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real bignum; + extern integer isamax_(integer *, real *, integer *); + logical notran; + integer jfirst; + real smlnum; + logical nounit; + real rec, tjj; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --x; + --cnorm; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + notran = lsame_(trans, "N"); + nounit = lsame_(diag, "N"); + +/* Test the input parameters. */ + + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (! lsame_(normin, "Y") && ! lsame_(normin, + "N")) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*kd < 0) { + *info = -6; + } else if (*ldab < *kd + 1) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLATBS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Determine machine dependent parameters to control overflow. */ + + smlnum = slamch_("Safe minimum") / slamch_("Precision"); + bignum = 1.f / smlnum; + *scale = 1.f; + + if (lsame_(normin, "N")) { + +/* Compute the 1-norm of each column, not including the diagonal. */ + + if (upper) { + +/* A is upper triangular. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = *kd, i__3 = j - 1; + jlen = f2cmin(i__2,i__3); + cnorm[j] = sasum_(&jlen, &ab[*kd + 1 - jlen + j * ab_dim1], & + c__1); +/* L10: */ + } + } else { + +/* A is lower triangular. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = *kd, i__3 = *n - j; + jlen = f2cmin(i__2,i__3); + if (jlen > 0) { + cnorm[j] = sasum_(&jlen, &ab[j * ab_dim1 + 2], &c__1); + } else { + cnorm[j] = 0.f; + } +/* L20: */ + } + } + } + +/* Scale the column norms by TSCAL if the maximum element in CNORM is */ +/* greater than BIGNUM. */ + + imax = isamax_(n, &cnorm[1], &c__1); + tmax = cnorm[imax]; + if (tmax <= bignum) { + tscal = 1.f; + } else { + tscal = 1.f / (smlnum * tmax); + sscal_(n, &tscal, &cnorm[1], &c__1); + } + +/* Compute a bound on the computed solution vector to see if the */ +/* Level 2 BLAS routine STBSV can be used. */ + + j = isamax_(n, &x[1], &c__1); + xmax = (r__1 = x[j], abs(r__1)); + xbnd = xmax; + if (notran) { + +/* Compute the growth in A * x = b. */ + + if (upper) { + jfirst = *n; + jlast = 1; + jinc = -1; + maind = *kd + 1; + } else { + jfirst = 1; + jlast = *n; + jinc = 1; + maind = 1; + } + + if (tscal != 1.f) { + grow = 0.f; + goto L50; + } + + if (nounit) { + +/* A is non-unit triangular. */ + +/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ +/* Initially, G(0) = f2cmax{x(i), i=1,...,n}. */ + + grow = 1.f / f2cmax(xbnd,smlnum); + xbnd = grow; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L50; + } + +/* M(j) = G(j-1) / abs(A(j,j)) */ + + tjj = (r__1 = ab[maind + j * ab_dim1], abs(r__1)); +/* Computing MIN */ + r__1 = xbnd, r__2 = f2cmin(1.f,tjj) * grow; + xbnd = f2cmin(r__1,r__2); + if (tjj + cnorm[j] >= smlnum) { + +/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */ + + grow *= tjj / (tjj + cnorm[j]); + } else { + +/* G(j) could overflow, set GROW to 0. */ + + grow = 0.f; + } +/* L30: */ + } + grow = xbnd; + } else { + +/* A is unit triangular. */ + +/* Compute GROW = 1/G(j), where G(0) = f2cmax{x(i), i=1,...,n}. */ + +/* Computing MIN */ + r__1 = 1.f, r__2 = 1.f / f2cmax(xbnd,smlnum); + grow = f2cmin(r__1,r__2); + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L50; + } + +/* G(j) = G(j-1)*( 1 + CNORM(j) ) */ + + grow *= 1.f / (cnorm[j] + 1.f); +/* L40: */ + } + } +L50: + + ; + } else { + +/* Compute the growth in A**T * x = b. */ + + if (upper) { + jfirst = 1; + jlast = *n; + jinc = 1; + maind = *kd + 1; + } else { + jfirst = *n; + jlast = 1; + jinc = -1; + maind = 1; + } + + if (tscal != 1.f) { + grow = 0.f; + goto L80; + } + + if (nounit) { + +/* A is non-unit triangular. */ + +/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ +/* Initially, M(0) = f2cmax{x(i), i=1,...,n}. */ + + grow = 1.f / f2cmax(xbnd,smlnum); + xbnd = grow; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L80; + } + +/* G(j) = f2cmax( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */ + + xj = cnorm[j] + 1.f; +/* Computing MIN */ + r__1 = grow, r__2 = xbnd / xj; + grow = f2cmin(r__1,r__2); + +/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */ + + tjj = (r__1 = ab[maind + j * ab_dim1], abs(r__1)); + if (xj > tjj) { + xbnd *= tjj / xj; + } +/* L60: */ + } + grow = f2cmin(grow,xbnd); + } else { + +/* A is unit triangular. */ + +/* Compute GROW = 1/G(j), where G(0) = f2cmax{x(i), i=1,...,n}. */ + +/* Computing MIN */ + r__1 = 1.f, r__2 = 1.f / f2cmax(xbnd,smlnum); + grow = f2cmin(r__1,r__2); + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L80; + } + +/* G(j) = ( 1 + CNORM(j) )*G(j-1) */ + + xj = cnorm[j] + 1.f; + grow /= xj; +/* L70: */ + } + } +L80: + ; + } + + if (grow * tscal > smlnum) { + +/* Use the Level 2 BLAS solve if the reciprocal of the bound on */ +/* elements of X is not too small. */ + + stbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &x[1], &c__1); + } else { + +/* Use a Level 1 BLAS solve, scaling intermediate results. */ + + if (xmax > bignum) { + +/* Scale X so that its components are less than or equal to */ +/* BIGNUM in absolute value. */ + + *scale = bignum / xmax; + sscal_(n, scale, &x[1], &c__1); + xmax = bignum; + } + + if (notran) { + +/* Solve A * x = b */ + + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */ + + xj = (r__1 = x[j], abs(r__1)); + if (nounit) { + tjjs = ab[maind + j * ab_dim1] * tscal; + } else { + tjjs = tscal; + if (tscal == 1.f) { + goto L95; + } + } + tjj = abs(tjjs); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.f) { + if (xj > tjj * bignum) { + +/* Scale x by 1/b(j). */ + + rec = 1.f / xj; + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + x[j] /= tjjs; + xj = (r__1 = x[j], abs(r__1)); + } else if (tjj > 0.f) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */ +/* to avoid overflow when dividing by A(j,j). */ + + rec = tjj * bignum / xj; + if (cnorm[j] > 1.f) { + +/* Scale by 1/CNORM(j) to avoid overflow when */ +/* multiplying x(j) times column j. */ + + rec /= cnorm[j]; + } + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + x[j] /= tjjs; + xj = (r__1 = x[j], abs(r__1)); + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0, and compute a solution to A*x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + x[i__] = 0.f; +/* L90: */ + } + x[j] = 1.f; + xj = 1.f; + *scale = 0.f; + xmax = 0.f; + } +L95: + +/* Scale x if necessary to avoid overflow when adding a */ +/* multiple of column j of A. */ + + if (xj > 1.f) { + rec = 1.f / xj; + if (cnorm[j] > (bignum - xmax) * rec) { + +/* Scale x by 1/(2*abs(x(j))). */ + + rec *= .5f; + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + } + } else if (xj * cnorm[j] > bignum - xmax) { + +/* Scale x by 1/2. */ + + sscal_(n, &c_b36, &x[1], &c__1); + *scale *= .5f; + } + + if (upper) { + if (j > 1) { + +/* Compute the update */ +/* x(f2cmax(1,j-kd):j-1) := x(f2cmax(1,j-kd):j-1) - */ +/* x(j)* A(f2cmax(1,j-kd):j-1,j) */ + +/* Computing MIN */ + i__3 = *kd, i__4 = j - 1; + jlen = f2cmin(i__3,i__4); + r__1 = -x[j] * tscal; + saxpy_(&jlen, &r__1, &ab[*kd + 1 - jlen + j * ab_dim1] + , &c__1, &x[j - jlen], &c__1); + i__3 = j - 1; + i__ = isamax_(&i__3, &x[1], &c__1); + xmax = (r__1 = x[i__], abs(r__1)); + } + } else if (j < *n) { + +/* Compute the update */ +/* x(j+1:f2cmin(j+kd,n)) := x(j+1:f2cmin(j+kd,n)) - */ +/* x(j) * A(j+1:f2cmin(j+kd,n),j) */ + +/* Computing MIN */ + i__3 = *kd, i__4 = *n - j; + jlen = f2cmin(i__3,i__4); + if (jlen > 0) { + r__1 = -x[j] * tscal; + saxpy_(&jlen, &r__1, &ab[j * ab_dim1 + 2], &c__1, &x[ + j + 1], &c__1); + } + i__3 = *n - j; + i__ = j + isamax_(&i__3, &x[j + 1], &c__1); + xmax = (r__1 = x[i__], abs(r__1)); + } +/* L100: */ + } + + } else { + +/* Solve A**T * x = b */ + + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Compute x(j) = b(j) - sum A(k,j)*x(k). */ +/* k<>j */ + + xj = (r__1 = x[j], abs(r__1)); + uscal = tscal; + rec = 1.f / f2cmax(xmax,1.f); + if (cnorm[j] > (bignum - xj) * rec) { + +/* If x(j) could overflow, scale x by 1/(2*XMAX). */ + + rec *= .5f; + if (nounit) { + tjjs = ab[maind + j * ab_dim1] * tscal; + } else { + tjjs = tscal; + } + tjj = abs(tjjs); + if (tjj > 1.f) { + +/* Divide by A(j,j) when scaling x if A(j,j) > 1. */ + +/* Computing MIN */ + r__1 = 1.f, r__2 = rec * tjj; + rec = f2cmin(r__1,r__2); + uscal /= tjjs; + } + if (rec < 1.f) { + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + + sumj = 0.f; + if (uscal == 1.f) { + +/* If the scaling needed for A in the dot product is 1, */ +/* call SDOT to perform the dot product. */ + + if (upper) { +/* Computing MIN */ + i__3 = *kd, i__4 = j - 1; + jlen = f2cmin(i__3,i__4); + sumj = sdot_(&jlen, &ab[*kd + 1 - jlen + j * ab_dim1], + &c__1, &x[j - jlen], &c__1); + } else { +/* Computing MIN */ + i__3 = *kd, i__4 = *n - j; + jlen = f2cmin(i__3,i__4); + if (jlen > 0) { + sumj = sdot_(&jlen, &ab[j * ab_dim1 + 2], &c__1, & + x[j + 1], &c__1); + } + } + } else { + +/* Otherwise, use in-line code for the dot product. */ + + if (upper) { +/* Computing MIN */ + i__3 = *kd, i__4 = j - 1; + jlen = f2cmin(i__3,i__4); + i__3 = jlen; + for (i__ = 1; i__ <= i__3; ++i__) { + sumj += ab[*kd + i__ - jlen + j * ab_dim1] * + uscal * x[j - jlen - 1 + i__]; +/* L110: */ + } + } else { +/* Computing MIN */ + i__3 = *kd, i__4 = *n - j; + jlen = f2cmin(i__3,i__4); + i__3 = jlen; + for (i__ = 1; i__ <= i__3; ++i__) { + sumj += ab[i__ + 1 + j * ab_dim1] * uscal * x[j + + i__]; +/* L120: */ + } + } + } + + if (uscal == tscal) { + +/* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) */ +/* was not used to scale the dotproduct. */ + + x[j] -= sumj; + xj = (r__1 = x[j], abs(r__1)); + if (nounit) { + +/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ + + tjjs = ab[maind + j * ab_dim1] * tscal; + } else { + tjjs = tscal; + if (tscal == 1.f) { + goto L135; + } + } + tjj = abs(tjjs); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.f) { + if (xj > tjj * bignum) { + +/* Scale X by 1/abs(x(j)). */ + + rec = 1.f / xj; + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + x[j] /= tjjs; + } else if (tjj > 0.f) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ + + rec = tjj * bignum / xj; + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + x[j] /= tjjs; + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0, and compute a solution to A**T*x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + x[i__] = 0.f; +/* L130: */ + } + x[j] = 1.f; + *scale = 0.f; + xmax = 0.f; + } +L135: + ; + } else { + +/* Compute x(j) := x(j) / A(j,j) - sumj if the dot */ +/* product has already been divided by 1/A(j,j). */ + + x[j] = x[j] / tjjs - sumj; + } +/* Computing MAX */ + r__2 = xmax, r__3 = (r__1 = x[j], abs(r__1)); + xmax = f2cmax(r__2,r__3); +/* L140: */ + } + } + *scale /= tscal; + } + +/* Scale the column norms by 1/TSCAL for return. */ + + if (tscal != 1.f) { + r__1 = 1.f / tscal; + sscal_(n, &r__1, &cnorm[1], &c__1); + } + + return 0; + +/* End of SLATBS */ + +} /* slatbs_ */ + diff --git a/lapack-netlib/SRC/slatdf.c b/lapack-netlib/SRC/slatdf.c new file mode 100644 index 000000000..d17417fd3 --- /dev/null +++ b/lapack-netlib/SRC/slatdf.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 SLATDF uses the LU factorization of the n-by-n matrix computed by sgetc2 and computes a contrib +ution to the reciprocal Dif-estimate. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLATDF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV, */ +/* JPIV ) */ + +/* INTEGER IJOB, LDZ, N */ +/* REAL RDSCAL, RDSUM */ +/* INTEGER IPIV( * ), JPIV( * ) */ +/* REAL RHS( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLATDF uses the LU factorization of the n-by-n matrix Z computed by */ +/* > SGETC2 and computes a contribution to the reciprocal Dif-estimate */ +/* > by solving Z * x = b for x, and choosing the r.h.s. b such that */ +/* > the norm of x is as large as possible. On entry RHS = b holds the */ +/* > contribution from earlier solved sub-systems, and on return RHS = x. */ +/* > */ +/* > The factorization of Z returned by SGETC2 has the form Z = P*L*U*Q, */ +/* > where P and Q are permutation matrices. L is lower triangular with */ +/* > unit diagonal elements and U is upper triangular. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] IJOB */ +/* > \verbatim */ +/* > IJOB is INTEGER */ +/* > IJOB = 2: First compute an approximative null-vector e */ +/* > of Z using SGECON, e is normalized and solve for */ +/* > Zx = +-e - f with the sign giving the greater value */ +/* > of 2-norm(x). About 5 times as expensive as Default. */ +/* > IJOB .ne. 2: Local look ahead strategy where all entries of */ +/* > the r.h.s. b is chosen as either +1 or -1 (Default). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension (LDZ, N) */ +/* > On entry, the LU part of the factorization of the n-by-n */ +/* > matrix Z computed by SGETC2: Z = P * L * U * Q */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDA >= f2cmax(1, N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] RHS */ +/* > \verbatim */ +/* > RHS is REAL array, dimension N. */ +/* > On entry, RHS contains contributions from other subsystems. */ +/* > On exit, RHS contains the solution of the subsystem with */ +/* > entries according to the value of IJOB (see above). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] RDSUM */ +/* > \verbatim */ +/* > RDSUM is 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[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N). */ +/* > The pivot indices; for 1 <= i <= N, row i of the */ +/* > matrix has been interchanged with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JPIV */ +/* > \verbatim */ +/* > JPIV is INTEGER array, dimension (N). */ +/* > The pivot indices; for 1 <= j <= N, column j of the */ +/* > matrix has been interchanged with column JPIV(j). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > This routine is a further developed implementation of algorithm */ +/* > BSOLVE in [1] using complete pivoting in the LU factorization. */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* > Umea University, S-901 87 Umea, Sweden. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > \verbatim */ +/* > */ +/* > */ +/* > [1] Bo Kagstrom and Lars Westin, */ +/* > Generalized Schur Methods with Condition Estimators for */ +/* > Solving the Generalized Sylvester Equation, IEEE Transactions */ +/* > on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751. */ +/* > */ +/* > [2] Peter Poromaa, */ +/* > On Efficient and Robust Estimators for the Separation */ +/* > between two Regular Matrix Pairs with Applications in */ +/* > Condition Estimation. Report IMINF-95.05, Departement of */ +/* > Computing Science, Umea University, S-901 87 Umea, Sweden, 1995. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slatdf_(integer *ijob, integer *n, real *z__, integer * + ldz, real *rhs, real *rdsum, real *rdscal, integer *ipiv, integer * + jpiv) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2; + real r__1; + + /* Local variables */ + integer info; + real temp; + extern real sdot_(integer *, real *, integer *, real *, integer *); + real work[32]; + integer i__, j, k; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + real pmone; + extern real sasum_(integer *, real *, integer *); + real sminu; + integer iwork[8]; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *), saxpy_(integer *, real *, real *, integer *, real *, + integer *); + real splus; + extern /* Subroutine */ int sgesc2_(integer *, real *, integer *, real *, + integer *, integer *, real *); + real bm, bp, xm[8], xp[8]; + extern /* Subroutine */ int sgecon_(char *, integer *, real *, integer *, + real *, real *, real *, integer *, integer *), slassq_( + integer *, real *, integer *, real *, real *), slaswp_(integer *, + real *, integer *, integer *, integer *, integer *, integer *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --rhs; + --ipiv; + --jpiv; + + /* Function Body */ + if (*ijob != 2) { + +/* Apply permutations IPIV to RHS */ + + i__1 = *n - 1; + slaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &ipiv[1], &c__1); + +/* Solve for L-part choosing RHS either to +1 or -1. */ + + pmone = -1.f; + + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + bp = rhs[j] + 1.f; + bm = rhs[j] - 1.f; + splus = 1.f; + +/* Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and */ +/* SMIN computed more efficiently than in BSOLVE [1]. */ + + i__2 = *n - j; + splus += sdot_(&i__2, &z__[j + 1 + j * z_dim1], &c__1, &z__[j + 1 + + j * z_dim1], &c__1); + i__2 = *n - j; + sminu = sdot_(&i__2, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1], + &c__1); + splus *= rhs[j]; + if (splus > sminu) { + rhs[j] = bp; + } else if (sminu > splus) { + rhs[j] = bm; + } else { + +/* In this case the updating sums are equal and we can */ +/* choose RHS(J) +1 or -1. The first time this happens */ +/* we choose -1, thereafter +1. This is a simple way to */ +/* get good estimates of matrices like Byers well-known */ +/* example (see [1]). (Not done in BSOLVE.) */ + + rhs[j] += pmone; + pmone = 1.f; + } + +/* Compute the remaining r.h.s. */ + + temp = -rhs[j]; + i__2 = *n - j; + saxpy_(&i__2, &temp, &z__[j + 1 + j * z_dim1], &c__1, &rhs[j + 1], + &c__1); + +/* L10: */ + } + +/* Solve for U-part, look-ahead for RHS(N) = +-1. This is not done */ +/* in BSOLVE and will hopefully give us a better estimate because */ +/* any ill-conditioning of the original matrix is transferred to U */ +/* and not to L. U(N, N) is an approximation to sigma_min(LU). */ + + i__1 = *n - 1; + scopy_(&i__1, &rhs[1], &c__1, xp, &c__1); + xp[*n - 1] = rhs[*n] + 1.f; + rhs[*n] += -1.f; + splus = 0.f; + sminu = 0.f; + for (i__ = *n; i__ >= 1; --i__) { + temp = 1.f / z__[i__ + i__ * z_dim1]; + xp[i__ - 1] *= temp; + rhs[i__] *= temp; + i__1 = *n; + for (k = i__ + 1; k <= i__1; ++k) { + xp[i__ - 1] -= xp[k - 1] * (z__[i__ + k * z_dim1] * temp); + rhs[i__] -= rhs[k] * (z__[i__ + k * z_dim1] * temp); +/* L20: */ + } + splus += (r__1 = xp[i__ - 1], abs(r__1)); + sminu += (r__1 = rhs[i__], abs(r__1)); +/* L30: */ + } + if (splus > sminu) { + scopy_(n, xp, &c__1, &rhs[1], &c__1); + } + +/* Apply the permutations JPIV to the computed solution (RHS) */ + + i__1 = *n - 1; + slaswp_(&c__1, &rhs[1], ldz, &c__1, &i__1, &jpiv[1], &c_n1); + +/* Compute the sum of squares */ + + slassq_(n, &rhs[1], &c__1, rdscal, rdsum); + + } else { + +/* IJOB = 2, Compute approximate nullvector XM of Z */ + + sgecon_("I", n, &z__[z_offset], ldz, &c_b23, &temp, work, iwork, & + info); + scopy_(n, &work[*n], &c__1, xm, &c__1); + +/* Compute RHS */ + + i__1 = *n - 1; + slaswp_(&c__1, xm, ldz, &c__1, &i__1, &ipiv[1], &c_n1); + temp = 1.f / sqrt(sdot_(n, xm, &c__1, xm, &c__1)); + sscal_(n, &temp, xm, &c__1); + scopy_(n, xm, &c__1, xp, &c__1); + saxpy_(n, &c_b23, &rhs[1], &c__1, xp, &c__1); + saxpy_(n, &c_b37, xm, &c__1, &rhs[1], &c__1); + sgesc2_(n, &z__[z_offset], ldz, &rhs[1], &ipiv[1], &jpiv[1], &temp); + sgesc2_(n, &z__[z_offset], ldz, xp, &ipiv[1], &jpiv[1], &temp); + if (sasum_(n, xp, &c__1) > sasum_(n, &rhs[1], &c__1)) { + scopy_(n, xp, &c__1, &rhs[1], &c__1); + } + +/* Compute the sum of squares */ + + slassq_(n, &rhs[1], &c__1, rdscal, rdsum); + + } + + return 0; + +/* End of SLATDF */ + +} /* slatdf_ */ + diff --git a/lapack-netlib/SRC/slatps.c b/lapack-netlib/SRC/slatps.c new file mode 100644 index 000000000..6eed1a04d --- /dev/null +++ b/lapack-netlib/SRC/slatps.c @@ -0,0 +1,1265 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLATPS solves a triangular system of equations with the matrix held in packed storage. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLATPS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE, */ +/* CNORM, INFO ) */ + +/* CHARACTER DIAG, NORMIN, TRANS, UPLO */ +/* INTEGER INFO, N */ +/* REAL SCALE */ +/* REAL AP( * ), CNORM( * ), X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLATPS solves one of the triangular systems */ +/* > */ +/* > A *x = s*b or A**T*x = s*b */ +/* > */ +/* > with scaling to prevent overflow, where A is an upper or lower */ +/* > triangular matrix stored in packed form. Here A**T denotes the */ +/* > transpose of A, x and b are n-element vectors, and s is a scaling */ +/* > factor, usually less than or equal to 1, chosen so that the */ +/* > components of x will be less than the overflow threshold. If the */ +/* > unscaled problem will not cause overflow, the Level 2 BLAS routine */ +/* > STPSV is called. If the matrix A is singular (A(j,j) = 0 for some j), */ +/* > then s is set to 0 and a non-trivial solution to A*x = 0 is returned. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the matrix A is upper or lower triangular. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the operation applied to A. */ +/* > = 'N': Solve A * x = s*b (No transpose) */ +/* > = 'T': Solve A**T* x = s*b (Transpose) */ +/* > = 'C': Solve A**T* x = s*b (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > Specifies whether or not the matrix A is unit triangular. */ +/* > = 'N': Non-unit triangular */ +/* > = 'U': Unit triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NORMIN */ +/* > \verbatim */ +/* > NORMIN is CHARACTER*1 */ +/* > Specifies whether CNORM has been set or not. */ +/* > = 'Y': CNORM contains the column norms on entry */ +/* > = 'N': CNORM is not set on entry. On exit, the norms will */ +/* > be computed and stored in CNORM. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] 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. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (N) */ +/* > On entry, the right hand side b of the triangular system. */ +/* > On exit, X is overwritten by the solution vector x. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE */ +/* > \verbatim */ +/* > SCALE is REAL */ +/* > The scaling factor s for the triangular system */ +/* > A * x = s*b or A**T* x = s*b. */ +/* > If SCALE = 0, the matrix A is singular or badly scaled, and */ +/* > the vector x is an exact or approximate solution to A*x = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] CNORM */ +/* > \verbatim */ +/* > CNORM is REAL array, dimension (N) */ +/* > */ +/* > If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */ +/* > contains the norm of the off-diagonal part of the j-th column */ +/* > of A. If TRANS = 'N', CNORM(j) must be greater than or equal */ +/* > to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */ +/* > must be greater than or equal to the 1-norm. */ +/* > */ +/* > If NORMIN = 'N', CNORM is an output argument and CNORM(j) */ +/* > returns the 1-norm of the offdiagonal part of the j-th column */ +/* > of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > A rough bound on x is computed; if that is less than overflow, STPSV */ +/* > is called, otherwise, specific code is used which checks for possible */ +/* > overflow or divide-by-zero at every operation. */ +/* > */ +/* > A columnwise scheme is used for solving A*x = b. The basic algorithm */ +/* > if A is lower triangular is */ +/* > */ +/* > x[1:n] := b[1:n] */ +/* > for j = 1, ..., n */ +/* > x(j) := x(j) / A(j,j) */ +/* > x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */ +/* > end */ +/* > */ +/* > Define bounds on the components of x after j iterations of the loop: */ +/* > M(j) = bound on x[1:j] */ +/* > G(j) = bound on x[j+1:n] */ +/* > Initially, let M(0) = 0 and G(0) = f2cmax{x(i), i=1,...,n}. */ +/* > */ +/* > Then for iteration j+1 we have */ +/* > M(j+1) <= G(j) / | A(j+1,j+1) | */ +/* > G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */ +/* > <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */ +/* > */ +/* > where CNORM(j+1) is greater than or equal to the infinity-norm of */ +/* > column j+1 of A, not counting the diagonal. Hence */ +/* > */ +/* > G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */ +/* > 1<=i<=j */ +/* > and */ +/* > */ +/* > |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */ +/* > 1<=i< j */ +/* > */ +/* > Since |x(j)| <= M(j), we use the Level 2 BLAS routine STPSV if the */ +/* > reciprocal of the largest M(j), j=1,..,n, is larger than */ +/* > f2cmax(underflow, 1/overflow). */ +/* > */ +/* > The bound on x(j) is also used to determine when a step in the */ +/* > columnwise method can be performed without fear of overflow. If */ +/* > the computed bound is greater than a large constant, x is scaled to */ +/* > prevent overflow, but if the bound overflows, x is set to 0, x(j) to */ +/* > 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */ +/* > */ +/* > Similarly, a row-wise scheme is used to solve A**T*x = b. The basic */ +/* > algorithm for A upper triangular is */ +/* > */ +/* > for j = 1, ..., n */ +/* > x(j) := ( b(j) - A[1:j-1,j]**T * x[1:j-1] ) / A(j,j) */ +/* > end */ +/* > */ +/* > We simultaneously compute two bounds */ +/* > G(j) = bound on ( b(i) - A[1:i-1,i]**T * x[1:i-1] ), 1<=i<=j */ +/* > M(j) = bound on x(i), 1<=i<=j */ +/* > */ +/* > The initial values are G(0) = 0, M(0) = f2cmax{b(i), i=1,..,n}, and we */ +/* > add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */ +/* > Then the bound on x(j) is */ +/* > */ +/* > M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */ +/* > */ +/* > <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */ +/* > 1<=i<=j */ +/* > */ +/* > and we can safely call STPSV if 1/M(n) and 1/G(n) are both greater */ +/* > than f2cmax(underflow, 1/overflow). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slatps_(char *uplo, char *trans, char *diag, char * + normin, integer *n, real *ap, real *x, real *scale, real *cnorm, + integer *info) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + real r__1, r__2, r__3; + + /* Local variables */ + integer jinc, jlen; + real xbnd; + integer imax; + real tmax, tjjs; + extern real sdot_(integer *, real *, integer *, real *, integer *); + real xmax, grow, sumj; + integer i__, j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + real tscal, uscal; + integer jlast; + extern real sasum_(integer *, real *, integer *); + logical upper; + extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, + real *, integer *), stpsv_(char *, char *, char *, integer *, + real *, real *, integer *); + integer ip; + real xj; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real bignum; + extern integer isamax_(integer *, real *, integer *); + logical notran; + integer jfirst; + real smlnum; + logical nounit; + real rec, tjj; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --cnorm; + --x; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + notran = lsame_(trans, "N"); + nounit = lsame_(diag, "N"); + +/* Test the input parameters. */ + + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (! lsame_(normin, "Y") && ! lsame_(normin, + "N")) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLATPS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Determine machine dependent parameters to control overflow. */ + + smlnum = slamch_("Safe minimum") / slamch_("Precision"); + bignum = 1.f / smlnum; + *scale = 1.f; + + if (lsame_(normin, "N")) { + +/* Compute the 1-norm of each column, not including the diagonal. */ + + if (upper) { + +/* A is upper triangular. */ + + ip = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + cnorm[j] = sasum_(&i__2, &ap[ip], &c__1); + ip += j; +/* L10: */ + } + } else { + +/* A is lower triangular. */ + + ip = 1; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j; + cnorm[j] = sasum_(&i__2, &ap[ip + 1], &c__1); + ip = ip + *n - j + 1; +/* L20: */ + } + cnorm[*n] = 0.f; + } + } + +/* Scale the column norms by TSCAL if the maximum element in CNORM is */ +/* greater than BIGNUM. */ + + imax = isamax_(n, &cnorm[1], &c__1); + tmax = cnorm[imax]; + if (tmax <= bignum) { + tscal = 1.f; + } else { + tscal = 1.f / (smlnum * tmax); + sscal_(n, &tscal, &cnorm[1], &c__1); + } + +/* Compute a bound on the computed solution vector to see if the */ +/* Level 2 BLAS routine STPSV can be used. */ + + j = isamax_(n, &x[1], &c__1); + xmax = (r__1 = x[j], abs(r__1)); + xbnd = xmax; + if (notran) { + +/* Compute the growth in A * x = b. */ + + if (upper) { + jfirst = *n; + jlast = 1; + jinc = -1; + } else { + jfirst = 1; + jlast = *n; + jinc = 1; + } + + if (tscal != 1.f) { + grow = 0.f; + goto L50; + } + + if (nounit) { + +/* A is non-unit triangular. */ + +/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ +/* Initially, G(0) = f2cmax{x(i), i=1,...,n}. */ + + grow = 1.f / f2cmax(xbnd,smlnum); + xbnd = grow; + ip = jfirst * (jfirst + 1) / 2; + jlen = *n; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L50; + } + +/* M(j) = G(j-1) / abs(A(j,j)) */ + + tjj = (r__1 = ap[ip], abs(r__1)); +/* Computing MIN */ + r__1 = xbnd, r__2 = f2cmin(1.f,tjj) * grow; + xbnd = f2cmin(r__1,r__2); + if (tjj + cnorm[j] >= smlnum) { + +/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */ + + grow *= tjj / (tjj + cnorm[j]); + } else { + +/* G(j) could overflow, set GROW to 0. */ + + grow = 0.f; + } + ip += jinc * jlen; + --jlen; +/* L30: */ + } + grow = xbnd; + } else { + +/* A is unit triangular. */ + +/* Compute GROW = 1/G(j), where G(0) = f2cmax{x(i), i=1,...,n}. */ + +/* Computing MIN */ + r__1 = 1.f, r__2 = 1.f / f2cmax(xbnd,smlnum); + grow = f2cmin(r__1,r__2); + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L50; + } + +/* G(j) = G(j-1)*( 1 + CNORM(j) ) */ + + grow *= 1.f / (cnorm[j] + 1.f); +/* L40: */ + } + } +L50: + + ; + } else { + +/* Compute the growth in A**T * x = b. */ + + if (upper) { + jfirst = 1; + jlast = *n; + jinc = 1; + } else { + jfirst = *n; + jlast = 1; + jinc = -1; + } + + if (tscal != 1.f) { + grow = 0.f; + goto L80; + } + + if (nounit) { + +/* A is non-unit triangular. */ + +/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ +/* Initially, M(0) = f2cmax{x(i), i=1,...,n}. */ + + grow = 1.f / f2cmax(xbnd,smlnum); + xbnd = grow; + ip = jfirst * (jfirst + 1) / 2; + jlen = 1; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L80; + } + +/* G(j) = f2cmax( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */ + + xj = cnorm[j] + 1.f; +/* Computing MIN */ + r__1 = grow, r__2 = xbnd / xj; + grow = f2cmin(r__1,r__2); + +/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */ + + tjj = (r__1 = ap[ip], abs(r__1)); + if (xj > tjj) { + xbnd *= tjj / xj; + } + ++jlen; + ip += jinc * jlen; +/* L60: */ + } + grow = f2cmin(grow,xbnd); + } else { + +/* A is unit triangular. */ + +/* Compute GROW = 1/G(j), where G(0) = f2cmax{x(i), i=1,...,n}. */ + +/* Computing MIN */ + r__1 = 1.f, r__2 = 1.f / f2cmax(xbnd,smlnum); + grow = f2cmin(r__1,r__2); + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L80; + } + +/* G(j) = ( 1 + CNORM(j) )*G(j-1) */ + + xj = cnorm[j] + 1.f; + grow /= xj; +/* L70: */ + } + } +L80: + ; + } + + if (grow * tscal > smlnum) { + +/* Use the Level 2 BLAS solve if the reciprocal of the bound on */ +/* elements of X is not too small. */ + + stpsv_(uplo, trans, diag, n, &ap[1], &x[1], &c__1); + } else { + +/* Use a Level 1 BLAS solve, scaling intermediate results. */ + + if (xmax > bignum) { + +/* Scale X so that its components are less than or equal to */ +/* BIGNUM in absolute value. */ + + *scale = bignum / xmax; + sscal_(n, scale, &x[1], &c__1); + xmax = bignum; + } + + if (notran) { + +/* Solve A * x = b */ + + ip = jfirst * (jfirst + 1) / 2; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */ + + xj = (r__1 = x[j], abs(r__1)); + if (nounit) { + tjjs = ap[ip] * tscal; + } else { + tjjs = tscal; + if (tscal == 1.f) { + goto L95; + } + } + tjj = abs(tjjs); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.f) { + if (xj > tjj * bignum) { + +/* Scale x by 1/b(j). */ + + rec = 1.f / xj; + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + x[j] /= tjjs; + xj = (r__1 = x[j], abs(r__1)); + } else if (tjj > 0.f) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */ +/* to avoid overflow when dividing by A(j,j). */ + + rec = tjj * bignum / xj; + if (cnorm[j] > 1.f) { + +/* Scale by 1/CNORM(j) to avoid overflow when */ +/* multiplying x(j) times column j. */ + + rec /= cnorm[j]; + } + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + x[j] /= tjjs; + xj = (r__1 = x[j], abs(r__1)); + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0, and compute a solution to A*x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + x[i__] = 0.f; +/* L90: */ + } + x[j] = 1.f; + xj = 1.f; + *scale = 0.f; + xmax = 0.f; + } +L95: + +/* Scale x if necessary to avoid overflow when adding a */ +/* multiple of column j of A. */ + + if (xj > 1.f) { + rec = 1.f / xj; + if (cnorm[j] > (bignum - xmax) * rec) { + +/* Scale x by 1/(2*abs(x(j))). */ + + rec *= .5f; + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + } + } else if (xj * cnorm[j] > bignum - xmax) { + +/* Scale x by 1/2. */ + + sscal_(n, &c_b36, &x[1], &c__1); + *scale *= .5f; + } + + if (upper) { + if (j > 1) { + +/* Compute the update */ +/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */ + + i__3 = j - 1; + r__1 = -x[j] * tscal; + saxpy_(&i__3, &r__1, &ap[ip - j + 1], &c__1, &x[1], & + c__1); + i__3 = j - 1; + i__ = isamax_(&i__3, &x[1], &c__1); + xmax = (r__1 = x[i__], abs(r__1)); + } + ip -= j; + } else { + if (j < *n) { + +/* Compute the update */ +/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */ + + i__3 = *n - j; + r__1 = -x[j] * tscal; + saxpy_(&i__3, &r__1, &ap[ip + 1], &c__1, &x[j + 1], & + c__1); + i__3 = *n - j; + i__ = j + isamax_(&i__3, &x[j + 1], &c__1); + xmax = (r__1 = x[i__], abs(r__1)); + } + ip = ip + *n - j + 1; + } +/* L100: */ + } + + } else { + +/* Solve A**T * x = b */ + + ip = jfirst * (jfirst + 1) / 2; + jlen = 1; + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Compute x(j) = b(j) - sum A(k,j)*x(k). */ +/* k<>j */ + + xj = (r__1 = x[j], abs(r__1)); + uscal = tscal; + rec = 1.f / f2cmax(xmax,1.f); + if (cnorm[j] > (bignum - xj) * rec) { + +/* If x(j) could overflow, scale x by 1/(2*XMAX). */ + + rec *= .5f; + if (nounit) { + tjjs = ap[ip] * tscal; + } else { + tjjs = tscal; + } + tjj = abs(tjjs); + if (tjj > 1.f) { + +/* Divide by A(j,j) when scaling x if A(j,j) > 1. */ + +/* Computing MIN */ + r__1 = 1.f, r__2 = rec * tjj; + rec = f2cmin(r__1,r__2); + uscal /= tjjs; + } + if (rec < 1.f) { + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + + sumj = 0.f; + if (uscal == 1.f) { + +/* If the scaling needed for A in the dot product is 1, */ +/* call SDOT to perform the dot product. */ + + if (upper) { + i__3 = j - 1; + sumj = sdot_(&i__3, &ap[ip - j + 1], &c__1, &x[1], & + c__1); + } else if (j < *n) { + i__3 = *n - j; + sumj = sdot_(&i__3, &ap[ip + 1], &c__1, &x[j + 1], & + c__1); + } + } else { + +/* Otherwise, use in-line code for the dot product. */ + + if (upper) { + i__3 = j - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + sumj += ap[ip - j + i__] * uscal * x[i__]; +/* L110: */ + } + } else if (j < *n) { + i__3 = *n - j; + for (i__ = 1; i__ <= i__3; ++i__) { + sumj += ap[ip + i__] * uscal * x[j + i__]; +/* L120: */ + } + } + } + + if (uscal == tscal) { + +/* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) */ +/* was not used to scale the dotproduct. */ + + x[j] -= sumj; + xj = (r__1 = x[j], abs(r__1)); + if (nounit) { + +/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ + + tjjs = ap[ip] * tscal; + } else { + tjjs = tscal; + if (tscal == 1.f) { + goto L135; + } + } + tjj = abs(tjjs); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.f) { + if (xj > tjj * bignum) { + +/* Scale X by 1/abs(x(j)). */ + + rec = 1.f / xj; + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + x[j] /= tjjs; + } else if (tjj > 0.f) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ + + rec = tjj * bignum / xj; + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + x[j] /= tjjs; + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0, and compute a solution to A**T*x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + x[i__] = 0.f; +/* L130: */ + } + x[j] = 1.f; + *scale = 0.f; + xmax = 0.f; + } +L135: + ; + } else { + +/* Compute x(j) := x(j) / A(j,j) - sumj if the dot */ +/* product has already been divided by 1/A(j,j). */ + + x[j] = x[j] / tjjs - sumj; + } +/* Computing MAX */ + r__2 = xmax, r__3 = (r__1 = x[j], abs(r__1)); + xmax = f2cmax(r__2,r__3); + ++jlen; + ip += jinc * jlen; +/* L140: */ + } + } + *scale /= tscal; + } + +/* Scale the column norms by 1/TSCAL for return. */ + + if (tscal != 1.f) { + r__1 = 1.f / tscal; + sscal_(n, &r__1, &cnorm[1], &c__1); + } + + return 0; + +/* End of SLATPS */ + +} /* slatps_ */ + diff --git a/lapack-netlib/SRC/slatrd.c b/lapack-netlib/SRC/slatrd.c new file mode 100644 index 000000000..72ea452f8 --- /dev/null +++ b/lapack-netlib/SRC/slatrd.c @@ -0,0 +1,790 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiago +nal form by an orthogonal similarity transformation. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLATRD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW ) */ + +/* CHARACTER UPLO */ +/* INTEGER LDA, LDW, N, NB */ +/* REAL A( LDA, * ), E( * ), TAU( * ), W( LDW, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLATRD reduces NB rows and columns of a real symmetric matrix A to */ +/* > symmetric tridiagonal form by an orthogonal similarity */ +/* > transformation Q**T * A * Q, and returns the matrices V and W which are */ +/* > needed to apply the transformation to the unreduced part of A. */ +/* > */ +/* > If UPLO = 'U', SLATRD reduces the last NB rows and columns of a */ +/* > matrix, of which the upper triangle is supplied; */ +/* > if UPLO = 'L', SLATRD reduces the first NB rows and columns of a */ +/* > matrix, of which the lower triangle is supplied. */ +/* > */ +/* > This is an auxiliary routine called by SSYTRD. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The number of rows and columns to be reduced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > n-by-n upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading n-by-n lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > On exit: */ +/* > if UPLO = 'U', the last NB columns have been reduced to */ +/* > tridiagonal form, with the diagonal elements overwriting */ +/* > the diagonal elements of A; the elements above the diagonal */ +/* > with the array TAU, represent the orthogonal matrix Q as a */ +/* > product of elementary reflectors; */ +/* > if UPLO = 'L', the first NB columns have been reduced to */ +/* > tridiagonal form, with the diagonal elements overwriting */ +/* > the diagonal elements of A; the elements below the diagonal */ +/* > with the array TAU, represent the orthogonal matrix Q as a */ +/* > product of elementary reflectors. */ +/* > See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= (1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (N-1) */ +/* > If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal */ +/* > elements of the last NB columns of the reduced matrix; */ +/* > if UPLO = 'L', E(1:nb) contains the subdiagonal elements of */ +/* > the first NB columns of the reduced matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is REAL array, dimension (N-1) */ +/* > The scalar factors of the elementary reflectors, stored in */ +/* > TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'. */ +/* > See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is REAL array, dimension (LDW,NB) */ +/* > The n-by-nb matrix W required to update the unreduced part */ +/* > of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDW */ +/* > \verbatim */ +/* > LDW is INTEGER */ +/* > The leading dimension of the array W. LDW >= f2cmax(1,N). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > If UPLO = 'U', the matrix Q is represented as a product of elementary */ +/* > reflectors */ +/* > */ +/* > Q = H(n) H(n-1) . . . H(n-nb+1). */ +/* > */ +/* > Each H(i) has the form */ +/* > */ +/* > H(i) = I - tau * v * v**T */ +/* > */ +/* > where tau is a real scalar, and v is a real vector with */ +/* > v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i), */ +/* > and tau in TAU(i-1). */ +/* > */ +/* > If UPLO = 'L', the matrix Q is represented as a product of elementary */ +/* > reflectors */ +/* > */ +/* > Q = H(1) H(2) . . . H(nb). */ +/* > */ +/* > Each H(i) has the form */ +/* > */ +/* > H(i) = I - tau * v * v**T */ +/* > */ +/* > where tau is a real scalar, and v is a real vector with */ +/* > v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i), */ +/* > and tau in TAU(i). */ +/* > */ +/* > The elements of the vectors v together form the n-by-nb matrix V */ +/* > which is needed, with W, to apply the transformation to the unreduced */ +/* > part of the matrix, using a symmetric rank-2k update of the form: */ +/* > A := A - V*W**T - W*V**T. */ +/* > */ +/* > The contents of A on exit are illustrated by the following examples */ +/* > with n = 5 and nb = 2: */ +/* > */ +/* > if UPLO = 'U': if UPLO = 'L': */ +/* > */ +/* > ( a a a v4 v5 ) ( d ) */ +/* > ( a a v4 v5 ) ( 1 d ) */ +/* > ( a 1 v5 ) ( v1 1 a ) */ +/* > ( d 1 ) ( v1 v2 a a ) */ +/* > ( d ) ( v1 v2 a a a ) */ +/* > */ +/* > where d denotes a diagonal element of the reduced matrix, a denotes */ +/* > an element of the original matrix that is unchanged, and vi denotes */ +/* > an element of the vector defining H(i). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slatrd_(char *uplo, integer *n, integer *nb, real *a, + integer *lda, real *e, real *tau, real *w, integer *ldw) +{ + /* System generated locals */ + integer a_dim1, a_offset, w_dim1, w_offset, i__1, i__2, i__3; + + /* Local variables */ + extern real sdot_(integer *, real *, integer *, real *, integer *); + integer i__; + real alpha; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), + sgemv_(char *, integer *, integer *, real *, real *, integer *, + real *, integer *, real *, real *, integer *), saxpy_( + integer *, real *, real *, integer *, real *, integer *), ssymv_( + char *, integer *, real *, real *, integer *, real *, integer *, + real *, real *, integer *); + integer iw; + extern /* Subroutine */ int slarfg_(integer *, real *, real *, integer *, + real *); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --e; + --tau; + w_dim1 = *ldw; + w_offset = 1 + w_dim1 * 1; + w -= w_offset; + + /* Function Body */ + if (*n <= 0) { + return 0; + } + + if (lsame_(uplo, "U")) { + +/* Reduce last NB columns of upper triangle */ + + i__1 = *n - *nb + 1; + for (i__ = *n; i__ >= i__1; --i__) { + iw = i__ - *n + *nb; + if (i__ < *n) { + +/* Update A(1:i,i) */ + + i__2 = *n - i__; + sgemv_("No transpose", &i__, &i__2, &c_b5, &a[(i__ + 1) * + a_dim1 + 1], lda, &w[i__ + (iw + 1) * w_dim1], ldw, & + c_b6, &a[i__ * a_dim1 + 1], &c__1); + i__2 = *n - i__; + sgemv_("No transpose", &i__, &i__2, &c_b5, &w[(iw + 1) * + w_dim1 + 1], ldw, &a[i__ + (i__ + 1) * a_dim1], lda, & + c_b6, &a[i__ * a_dim1 + 1], &c__1); + } + if (i__ > 1) { + +/* Generate elementary reflector H(i) to annihilate */ +/* A(1:i-2,i) */ + + i__2 = i__ - 1; + slarfg_(&i__2, &a[i__ - 1 + i__ * a_dim1], &a[i__ * a_dim1 + + 1], &c__1, &tau[i__ - 1]); + e[i__ - 1] = a[i__ - 1 + i__ * a_dim1]; + a[i__ - 1 + i__ * a_dim1] = 1.f; + +/* Compute W(1:i-1,i) */ + + i__2 = i__ - 1; + ssymv_("Upper", &i__2, &c_b6, &a[a_offset], lda, &a[i__ * + a_dim1 + 1], &c__1, &c_b16, &w[iw * w_dim1 + 1], & + c__1); + if (i__ < *n) { + i__2 = i__ - 1; + i__3 = *n - i__; + sgemv_("Transpose", &i__2, &i__3, &c_b6, &w[(iw + 1) * + w_dim1 + 1], ldw, &a[i__ * a_dim1 + 1], &c__1, & + c_b16, &w[i__ + 1 + iw * w_dim1], &c__1); + i__2 = i__ - 1; + i__3 = *n - i__; + sgemv_("No transpose", &i__2, &i__3, &c_b5, &a[(i__ + 1) * + a_dim1 + 1], lda, &w[i__ + 1 + iw * w_dim1], & + c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1); + i__2 = i__ - 1; + i__3 = *n - i__; + sgemv_("Transpose", &i__2, &i__3, &c_b6, &a[(i__ + 1) * + a_dim1 + 1], lda, &a[i__ * a_dim1 + 1], &c__1, & + c_b16, &w[i__ + 1 + iw * w_dim1], &c__1); + i__2 = i__ - 1; + i__3 = *n - i__; + sgemv_("No transpose", &i__2, &i__3, &c_b5, &w[(iw + 1) * + w_dim1 + 1], ldw, &w[i__ + 1 + iw * w_dim1], & + c__1, &c_b6, &w[iw * w_dim1 + 1], &c__1); + } + i__2 = i__ - 1; + sscal_(&i__2, &tau[i__ - 1], &w[iw * w_dim1 + 1], &c__1); + i__2 = i__ - 1; + alpha = tau[i__ - 1] * -.5f * sdot_(&i__2, &w[iw * w_dim1 + 1] + , &c__1, &a[i__ * a_dim1 + 1], &c__1); + i__2 = i__ - 1; + saxpy_(&i__2, &alpha, &a[i__ * a_dim1 + 1], &c__1, &w[iw * + w_dim1 + 1], &c__1); + } + +/* L10: */ + } + } else { + +/* Reduce first NB columns of lower triangle */ + + i__1 = *nb; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Update A(i:n,i) */ + + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + sgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + a_dim1], lda, + &w[i__ + w_dim1], ldw, &c_b6, &a[i__ + i__ * a_dim1], & + c__1); + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + sgemv_("No transpose", &i__2, &i__3, &c_b5, &w[i__ + w_dim1], ldw, + &a[i__ + a_dim1], lda, &c_b6, &a[i__ + i__ * a_dim1], & + c__1); + if (i__ < *n) { + +/* Generate elementary reflector H(i) to annihilate */ +/* A(i+2:n,i) */ + + i__2 = *n - i__; +/* Computing MIN */ + i__3 = i__ + 2; + slarfg_(&i__2, &a[i__ + 1 + i__ * a_dim1], &a[f2cmin(i__3,*n) + + i__ * a_dim1], &c__1, &tau[i__]); + e[i__] = a[i__ + 1 + i__ * a_dim1]; + a[i__ + 1 + i__ * a_dim1] = 1.f; + +/* Compute W(i+1:n,i) */ + + i__2 = *n - i__; + ssymv_("Lower", &i__2, &c_b6, &a[i__ + 1 + (i__ + 1) * a_dim1] + , lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ + i__ + 1 + i__ * w_dim1], &c__1); + i__2 = *n - i__; + i__3 = i__ - 1; + sgemv_("Transpose", &i__2, &i__3, &c_b6, &w[i__ + 1 + w_dim1], + ldw, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ + i__ * w_dim1 + 1], &c__1); + i__2 = *n - i__; + i__3 = i__ - 1; + sgemv_("No transpose", &i__2, &i__3, &c_b5, &a[i__ + 1 + + a_dim1], lda, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[ + i__ + 1 + i__ * w_dim1], &c__1); + i__2 = *n - i__; + i__3 = i__ - 1; + sgemv_("Transpose", &i__2, &i__3, &c_b6, &a[i__ + 1 + a_dim1], + lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &c_b16, &w[ + i__ * w_dim1 + 1], &c__1); + i__2 = *n - i__; + i__3 = i__ - 1; + sgemv_("No transpose", &i__2, &i__3, &c_b5, &w[i__ + 1 + + w_dim1], ldw, &w[i__ * w_dim1 + 1], &c__1, &c_b6, &w[ + i__ + 1 + i__ * w_dim1], &c__1); + i__2 = *n - i__; + sscal_(&i__2, &tau[i__], &w[i__ + 1 + i__ * w_dim1], &c__1); + i__2 = *n - i__; + alpha = tau[i__] * -.5f * sdot_(&i__2, &w[i__ + 1 + i__ * + w_dim1], &c__1, &a[i__ + 1 + i__ * a_dim1], &c__1); + i__2 = *n - i__; + saxpy_(&i__2, &alpha, &a[i__ + 1 + i__ * a_dim1], &c__1, &w[ + i__ + 1 + i__ * w_dim1], &c__1); + } + +/* L20: */ + } + } + + return 0; + +/* End of SLATRD */ + +} /* slatrd_ */ + diff --git a/lapack-netlib/SRC/slatrs.c b/lapack-netlib/SRC/slatrs.c new file mode 100644 index 000000000..38cc78bdd --- /dev/null +++ b/lapack-netlib/SRC/slatrs.c @@ -0,0 +1,1259 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLATRS solves a triangular system of equations with the scale factor set to prevent overflow. +*/ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLATRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE, */ +/* CNORM, INFO ) */ + +/* CHARACTER DIAG, NORMIN, TRANS, UPLO */ +/* INTEGER INFO, LDA, N */ +/* REAL SCALE */ +/* REAL A( LDA, * ), CNORM( * ), X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLATRS solves one of the triangular systems */ +/* > */ +/* > A *x = s*b or A**T*x = s*b */ +/* > */ +/* > with scaling to prevent overflow. Here A is an upper or lower */ +/* > triangular matrix, A**T denotes the transpose of A, x and b are */ +/* > n-element vectors, and s is a scaling factor, usually less than */ +/* > or equal to 1, chosen so that the components of x will be less than */ +/* > the overflow threshold. If the unscaled problem will not cause */ +/* > overflow, the Level 2 BLAS routine STRSV is called. If the matrix A */ +/* > is singular (A(j,j) = 0 for some j), then s is set to 0 and a */ +/* > non-trivial solution to A*x = 0 is returned. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the matrix A is upper or lower triangular. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the operation applied to A. */ +/* > = 'N': Solve A * x = s*b (No transpose) */ +/* > = 'T': Solve A**T* x = s*b (Transpose) */ +/* > = 'C': Solve A**T* x = s*b (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > Specifies whether or not the matrix A is unit triangular. */ +/* > = 'N': Non-unit triangular */ +/* > = 'U': Unit triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NORMIN */ +/* > \verbatim */ +/* > NORMIN is CHARACTER*1 */ +/* > Specifies whether CNORM has been set or not. */ +/* > = 'Y': CNORM contains the column norms on entry */ +/* > = 'N': CNORM is not set on entry. On exit, the norms will */ +/* > be computed and stored in CNORM. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] 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] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (N) */ +/* > On entry, the right hand side b of the triangular system. */ +/* > On exit, X is overwritten by the solution vector x. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE */ +/* > \verbatim */ +/* > SCALE is REAL */ +/* > The scaling factor s for the triangular system */ +/* > A * x = s*b or A**T* x = s*b. */ +/* > If SCALE = 0, the matrix A is singular or badly scaled, and */ +/* > the vector x is an exact or approximate solution to A*x = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] CNORM */ +/* > \verbatim */ +/* > CNORM is REAL array, dimension (N) */ +/* > */ +/* > If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */ +/* > contains the norm of the off-diagonal part of the j-th column */ +/* > of A. If TRANS = 'N', CNORM(j) must be greater than or equal */ +/* > to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */ +/* > must be greater than or equal to the 1-norm. */ +/* > */ +/* > If NORMIN = 'N', CNORM is an output argument and CNORM(j) */ +/* > returns the 1-norm of the offdiagonal part of the j-th column */ +/* > of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > A rough bound on x is computed; if that is less than overflow, STRSV */ +/* > is called, otherwise, specific code is used which checks for possible */ +/* > overflow or divide-by-zero at every operation. */ +/* > */ +/* > A columnwise scheme is used for solving A*x = b. The basic algorithm */ +/* > if A is lower triangular is */ +/* > */ +/* > x[1:n] := b[1:n] */ +/* > for j = 1, ..., n */ +/* > x(j) := x(j) / A(j,j) */ +/* > x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */ +/* > end */ +/* > */ +/* > Define bounds on the components of x after j iterations of the loop: */ +/* > M(j) = bound on x[1:j] */ +/* > G(j) = bound on x[j+1:n] */ +/* > Initially, let M(0) = 0 and G(0) = f2cmax{x(i), i=1,...,n}. */ +/* > */ +/* > Then for iteration j+1 we have */ +/* > M(j+1) <= G(j) / | A(j+1,j+1) | */ +/* > G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */ +/* > <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */ +/* > */ +/* > where CNORM(j+1) is greater than or equal to the infinity-norm of */ +/* > column j+1 of A, not counting the diagonal. Hence */ +/* > */ +/* > G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */ +/* > 1<=i<=j */ +/* > and */ +/* > */ +/* > |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */ +/* > 1<=i< j */ +/* > */ +/* > Since |x(j)| <= M(j), we use the Level 2 BLAS routine STRSV if the */ +/* > reciprocal of the largest M(j), j=1,..,n, is larger than */ +/* > f2cmax(underflow, 1/overflow). */ +/* > */ +/* > The bound on x(j) is also used to determine when a step in the */ +/* > columnwise method can be performed without fear of overflow. If */ +/* > the computed bound is greater than a large constant, x is scaled to */ +/* > prevent overflow, but if the bound overflows, x is set to 0, x(j) to */ +/* > 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */ +/* > */ +/* > Similarly, a row-wise scheme is used to solve A**T*x = b. The basic */ +/* > algorithm for A upper triangular is */ +/* > */ +/* > for j = 1, ..., n */ +/* > x(j) := ( b(j) - A[1:j-1,j]**T * x[1:j-1] ) / A(j,j) */ +/* > end */ +/* > */ +/* > We simultaneously compute two bounds */ +/* > G(j) = bound on ( b(i) - A[1:i-1,i]**T * x[1:i-1] ), 1<=i<=j */ +/* > M(j) = bound on x(i), 1<=i<=j */ +/* > */ +/* > The initial values are G(0) = 0, M(0) = f2cmax{b(i), i=1,..,n}, and we */ +/* > add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */ +/* > Then the bound on x(j) is */ +/* > */ +/* > M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */ +/* > */ +/* > <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */ +/* > 1<=i<=j */ +/* > */ +/* > and we can safely call STRSV if 1/M(n) and 1/G(n) are both greater */ +/* > than f2cmax(underflow, 1/overflow). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slatrs_(char *uplo, char *trans, char *diag, char * + normin, integer *n, real *a, integer *lda, real *x, real *scale, real + *cnorm, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + real r__1, r__2, r__3; + + /* Local variables */ + integer jinc; + real xbnd; + integer imax; + real tmax, tjjs; + extern real sdot_(integer *, real *, integer *, real *, integer *); + real xmax, grow, sumj; + integer i__, j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + real tscal, uscal; + integer jlast; + extern real sasum_(integer *, real *, integer *); + logical upper; + extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, + real *, integer *), strsv_(char *, char *, char *, integer *, + real *, integer *, real *, integer *); + real xj; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real bignum; + extern integer isamax_(integer *, real *, integer *); + logical notran; + integer jfirst; + real smlnum; + logical nounit; + real rec, tjj; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --x; + --cnorm; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + notran = lsame_(trans, "N"); + nounit = lsame_(diag, "N"); + +/* Test the input parameters. */ + + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (! lsame_(normin, "Y") && ! lsame_(normin, + "N")) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < f2cmax(1,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLATRS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Determine machine dependent parameters to control overflow. */ + + smlnum = slamch_("Safe minimum") / slamch_("Precision"); + bignum = 1.f / smlnum; + *scale = 1.f; + + if (lsame_(normin, "N")) { + +/* Compute the 1-norm of each column, not including the diagonal. */ + + if (upper) { + +/* A is upper triangular. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + cnorm[j] = sasum_(&i__2, &a[j * a_dim1 + 1], &c__1); +/* L10: */ + } + } else { + +/* A is lower triangular. */ + + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = *n - j; + cnorm[j] = sasum_(&i__2, &a[j + 1 + j * a_dim1], &c__1); +/* L20: */ + } + cnorm[*n] = 0.f; + } + } + +/* Scale the column norms by TSCAL if the maximum element in CNORM is */ +/* greater than BIGNUM. */ + + imax = isamax_(n, &cnorm[1], &c__1); + tmax = cnorm[imax]; + if (tmax <= bignum) { + tscal = 1.f; + } else { + tscal = 1.f / (smlnum * tmax); + sscal_(n, &tscal, &cnorm[1], &c__1); + } + +/* Compute a bound on the computed solution vector to see if the */ +/* Level 2 BLAS routine STRSV can be used. */ + + j = isamax_(n, &x[1], &c__1); + xmax = (r__1 = x[j], abs(r__1)); + xbnd = xmax; + if (notran) { + +/* Compute the growth in A * x = b. */ + + if (upper) { + jfirst = *n; + jlast = 1; + jinc = -1; + } else { + jfirst = 1; + jlast = *n; + jinc = 1; + } + + if (tscal != 1.f) { + grow = 0.f; + goto L50; + } + + if (nounit) { + +/* A is non-unit triangular. */ + +/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ +/* Initially, G(0) = f2cmax{x(i), i=1,...,n}. */ + + grow = 1.f / f2cmax(xbnd,smlnum); + xbnd = grow; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L50; + } + +/* M(j) = G(j-1) / abs(A(j,j)) */ + + tjj = (r__1 = a[j + j * a_dim1], abs(r__1)); +/* Computing MIN */ + r__1 = xbnd, r__2 = f2cmin(1.f,tjj) * grow; + xbnd = f2cmin(r__1,r__2); + if (tjj + cnorm[j] >= smlnum) { + +/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */ + + grow *= tjj / (tjj + cnorm[j]); + } else { + +/* G(j) could overflow, set GROW to 0. */ + + grow = 0.f; + } +/* L30: */ + } + grow = xbnd; + } else { + +/* A is unit triangular. */ + +/* Compute GROW = 1/G(j), where G(0) = f2cmax{x(i), i=1,...,n}. */ + +/* Computing MIN */ + r__1 = 1.f, r__2 = 1.f / f2cmax(xbnd,smlnum); + grow = f2cmin(r__1,r__2); + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L50; + } + +/* G(j) = G(j-1)*( 1 + CNORM(j) ) */ + + grow *= 1.f / (cnorm[j] + 1.f); +/* L40: */ + } + } +L50: + + ; + } else { + +/* Compute the growth in A**T * x = b. */ + + if (upper) { + jfirst = 1; + jlast = *n; + jinc = 1; + } else { + jfirst = *n; + jlast = 1; + jinc = -1; + } + + if (tscal != 1.f) { + grow = 0.f; + goto L80; + } + + if (nounit) { + +/* A is non-unit triangular. */ + +/* Compute GROW = 1/G(j) and XBND = 1/M(j). */ +/* Initially, M(0) = f2cmax{x(i), i=1,...,n}. */ + + grow = 1.f / f2cmax(xbnd,smlnum); + xbnd = grow; + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L80; + } + +/* G(j) = f2cmax( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */ + + xj = cnorm[j] + 1.f; +/* Computing MIN */ + r__1 = grow, r__2 = xbnd / xj; + grow = f2cmin(r__1,r__2); + +/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */ + + tjj = (r__1 = a[j + j * a_dim1], abs(r__1)); + if (xj > tjj) { + xbnd *= tjj / xj; + } +/* L60: */ + } + grow = f2cmin(grow,xbnd); + } else { + +/* A is unit triangular. */ + +/* Compute GROW = 1/G(j), where G(0) = f2cmax{x(i), i=1,...,n}. */ + +/* Computing MIN */ + r__1 = 1.f, r__2 = 1.f / f2cmax(xbnd,smlnum); + grow = f2cmin(r__1,r__2); + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Exit the loop if the growth factor is too small. */ + + if (grow <= smlnum) { + goto L80; + } + +/* G(j) = ( 1 + CNORM(j) )*G(j-1) */ + + xj = cnorm[j] + 1.f; + grow /= xj; +/* L70: */ + } + } +L80: + ; + } + + if (grow * tscal > smlnum) { + +/* Use the Level 2 BLAS solve if the reciprocal of the bound on */ +/* elements of X is not too small. */ + + strsv_(uplo, trans, diag, n, &a[a_offset], lda, &x[1], &c__1); + } else { + +/* Use a Level 1 BLAS solve, scaling intermediate results. */ + + if (xmax > bignum) { + +/* Scale X so that its components are less than or equal to */ +/* BIGNUM in absolute value. */ + + *scale = bignum / xmax; + sscal_(n, scale, &x[1], &c__1); + xmax = bignum; + } + + if (notran) { + +/* Solve A * x = b */ + + i__1 = jlast; + i__2 = jinc; + for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { + +/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */ + + xj = (r__1 = x[j], abs(r__1)); + if (nounit) { + tjjs = a[j + j * a_dim1] * tscal; + } else { + tjjs = tscal; + if (tscal == 1.f) { + goto L95; + } + } + tjj = abs(tjjs); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.f) { + if (xj > tjj * bignum) { + +/* Scale x by 1/b(j). */ + + rec = 1.f / xj; + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + x[j] /= tjjs; + xj = (r__1 = x[j], abs(r__1)); + } else if (tjj > 0.f) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */ +/* to avoid overflow when dividing by A(j,j). */ + + rec = tjj * bignum / xj; + if (cnorm[j] > 1.f) { + +/* Scale by 1/CNORM(j) to avoid overflow when */ +/* multiplying x(j) times column j. */ + + rec /= cnorm[j]; + } + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + x[j] /= tjjs; + xj = (r__1 = x[j], abs(r__1)); + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0, and compute a solution to A*x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + x[i__] = 0.f; +/* L90: */ + } + x[j] = 1.f; + xj = 1.f; + *scale = 0.f; + xmax = 0.f; + } +L95: + +/* Scale x if necessary to avoid overflow when adding a */ +/* multiple of column j of A. */ + + if (xj > 1.f) { + rec = 1.f / xj; + if (cnorm[j] > (bignum - xmax) * rec) { + +/* Scale x by 1/(2*abs(x(j))). */ + + rec *= .5f; + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + } + } else if (xj * cnorm[j] > bignum - xmax) { + +/* Scale x by 1/2. */ + + sscal_(n, &c_b36, &x[1], &c__1); + *scale *= .5f; + } + + if (upper) { + if (j > 1) { + +/* Compute the update */ +/* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j) */ + + i__3 = j - 1; + r__1 = -x[j] * tscal; + saxpy_(&i__3, &r__1, &a[j * a_dim1 + 1], &c__1, &x[1], + &c__1); + i__3 = j - 1; + i__ = isamax_(&i__3, &x[1], &c__1); + xmax = (r__1 = x[i__], abs(r__1)); + } + } else { + if (j < *n) { + +/* Compute the update */ +/* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j) */ + + i__3 = *n - j; + r__1 = -x[j] * tscal; + saxpy_(&i__3, &r__1, &a[j + 1 + j * a_dim1], &c__1, & + x[j + 1], &c__1); + i__3 = *n - j; + i__ = j + isamax_(&i__3, &x[j + 1], &c__1); + xmax = (r__1 = x[i__], abs(r__1)); + } + } +/* L100: */ + } + + } else { + +/* Solve A**T * x = b */ + + i__2 = jlast; + i__1 = jinc; + for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) { + +/* Compute x(j) = b(j) - sum A(k,j)*x(k). */ +/* k<>j */ + + xj = (r__1 = x[j], abs(r__1)); + uscal = tscal; + rec = 1.f / f2cmax(xmax,1.f); + if (cnorm[j] > (bignum - xj) * rec) { + +/* If x(j) could overflow, scale x by 1/(2*XMAX). */ + + rec *= .5f; + if (nounit) { + tjjs = a[j + j * a_dim1] * tscal; + } else { + tjjs = tscal; + } + tjj = abs(tjjs); + if (tjj > 1.f) { + +/* Divide by A(j,j) when scaling x if A(j,j) > 1. */ + +/* Computing MIN */ + r__1 = 1.f, r__2 = rec * tjj; + rec = f2cmin(r__1,r__2); + uscal /= tjjs; + } + if (rec < 1.f) { + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + + sumj = 0.f; + if (uscal == 1.f) { + +/* If the scaling needed for A in the dot product is 1, */ +/* call SDOT to perform the dot product. */ + + if (upper) { + i__3 = j - 1; + sumj = sdot_(&i__3, &a[j * a_dim1 + 1], &c__1, &x[1], + &c__1); + } else if (j < *n) { + i__3 = *n - j; + sumj = sdot_(&i__3, &a[j + 1 + j * a_dim1], &c__1, &x[ + j + 1], &c__1); + } + } else { + +/* Otherwise, use in-line code for the dot product. */ + + if (upper) { + i__3 = j - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + sumj += a[i__ + j * a_dim1] * uscal * x[i__]; +/* L110: */ + } + } else if (j < *n) { + i__3 = *n; + for (i__ = j + 1; i__ <= i__3; ++i__) { + sumj += a[i__ + j * a_dim1] * uscal * x[i__]; +/* L120: */ + } + } + } + + if (uscal == tscal) { + +/* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) */ +/* was not used to scale the dotproduct. */ + + x[j] -= sumj; + xj = (r__1 = x[j], abs(r__1)); + if (nounit) { + tjjs = a[j + j * a_dim1] * tscal; + } else { + tjjs = tscal; + if (tscal == 1.f) { + goto L135; + } + } + +/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */ + + tjj = abs(tjjs); + if (tjj > smlnum) { + +/* abs(A(j,j)) > SMLNUM: */ + + if (tjj < 1.f) { + if (xj > tjj * bignum) { + +/* Scale X by 1/abs(x(j)). */ + + rec = 1.f / xj; + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + } + x[j] /= tjjs; + } else if (tjj > 0.f) { + +/* 0 < abs(A(j,j)) <= SMLNUM: */ + + if (xj > tjj * bignum) { + +/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */ + + rec = tjj * bignum / xj; + sscal_(n, &rec, &x[1], &c__1); + *scale *= rec; + xmax *= rec; + } + x[j] /= tjjs; + } else { + +/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */ +/* scale = 0, and compute a solution to A**T*x = 0. */ + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + x[i__] = 0.f; +/* L130: */ + } + x[j] = 1.f; + *scale = 0.f; + xmax = 0.f; + } +L135: + ; + } else { + +/* Compute x(j) := x(j) / A(j,j) - sumj if the dot */ +/* product has already been divided by 1/A(j,j). */ + + x[j] = x[j] / tjjs - sumj; + } +/* Computing MAX */ + r__2 = xmax, r__3 = (r__1 = x[j], abs(r__1)); + xmax = f2cmax(r__2,r__3); +/* L140: */ + } + } + *scale /= tscal; + } + +/* Scale the column norms by 1/TSCAL for return. */ + + if (tscal != 1.f) { + r__1 = 1.f / tscal; + sscal_(n, &r__1, &cnorm[1], &c__1); + } + + return 0; + +/* End of SLATRS */ + +} /* slatrs_ */ + diff --git a/lapack-netlib/SRC/slatrz.c b/lapack-netlib/SRC/slatrz.c new file mode 100644 index 000000000..bfc521dfd --- /dev/null +++ b/lapack-netlib/SRC/slatrz.c @@ -0,0 +1,597 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLATRZ factors an upper trapezoidal matrix by means of orthogonal transformations. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLATRZ + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLATRZ( M, N, L, A, LDA, TAU, WORK ) */ + +/* INTEGER L, LDA, M, N */ +/* REAL A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLATRZ factors the M-by-(M+L) real upper trapezoidal matrix */ +/* > [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z, by means */ +/* > of orthogonal transformations. Z is an (M+L)-by-(M+L) orthogonal */ +/* > matrix and, R and A1 are M-by-M upper triangular matrices. */ +/* > \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] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The number of columns of the matrix A containing the */ +/* > meaningful part of the Householder vectors. N-M >= L >= 0. */ +/* > \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 N-L+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 (M) */ +/* > \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 Contributors: */ +/* ================== */ +/* > */ +/* > A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The factorization is obtained by Householder's method. The kth */ +/* > transformation matrix, Z( k ), which is used to introduce zeros into */ +/* > the ( m - k + 1 )th row of A, is given in the form */ +/* > */ +/* > Z( k ) = ( I 0 ), */ +/* > ( 0 T( k ) ) */ +/* > */ +/* > where */ +/* > */ +/* > T( k ) = I - tau*u( k )*u( k )**T, u( k ) = ( 1 ), */ +/* > ( 0 ) */ +/* > ( z( k ) ) */ +/* > */ +/* > tau is a scalar and z( k ) is an l element vector. tau and z( k ) */ +/* > are chosen to annihilate the elements of the kth row of A2. */ +/* > */ +/* > The scalar tau is returned in the kth element of TAU and the vector */ +/* > u( k ) in the kth row of A2, such that the elements of z( k ) are */ +/* > in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in */ +/* > the upper triangular part of A1. */ +/* > */ +/* > Z is given by */ +/* > */ +/* > Z = Z( 1 ) * Z( 2 ) * ... * Z( m ). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slatrz_(integer *m, integer *n, integer *l, real *a, + integer *lda, real *tau, real *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__; + extern /* Subroutine */ int slarz_(char *, integer *, integer *, integer * + , real *, integer *, real *, real *, integer *, real *), + 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 */ + +/* Quick return if possible */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + 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; + } + + for (i__ = *m; i__ >= 1; --i__) { + +/* Generate elementary reflector H(i) to annihilate */ +/* [ A(i,i) A(i,n-l+1:n) ] */ + + i__1 = *l + 1; + slarfg_(&i__1, &a[i__ + i__ * a_dim1], &a[i__ + (*n - *l + 1) * + a_dim1], lda, &tau[i__]); + +/* Apply H(i) to A(1:i-1,i:n) from the right */ + + i__1 = i__ - 1; + i__2 = *n - i__ + 1; + slarz_("Right", &i__1, &i__2, l, &a[i__ + (*n - *l + 1) * a_dim1], + lda, &tau[i__], &a[i__ * a_dim1 + 1], lda, &work[1]); + +/* L20: */ + } + + return 0; + +/* End of SLATRZ */ + +} /* slatrz_ */ + diff --git a/lapack-netlib/SRC/slatsqr.c b/lapack-netlib/SRC/slatsqr.c new file mode 100644 index 000000000..ab8c188b4 --- /dev/null +++ b/lapack-netlib/SRC/slatsqr.c @@ -0,0 +1,669 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLATSQR */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLATSQR( M, N, MB, NB, A, LDA, T, LDT, WORK, */ +/* LWORK, INFO) */ + +/* INTEGER INFO, LDA, M, N, MB, NB, LDT, LWORK */ +/* REAL A( LDA, * ), T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLATSQR computes a blocked Tall-Skinny QR factorization of */ +/* > a real M-by-N matrix A for M >= N: */ +/* > */ +/* > A = Q * ( R ), */ +/* > ( 0 ) */ +/* > */ +/* > where: */ +/* > */ +/* > Q is a M-by-M orthogonal matrix, stored on exit in an implicit */ +/* > form in the elements below the digonal of the array A and in */ +/* > the elemenst of the array T; */ +/* > */ +/* > R is an upper-triangular N-by-N matrix, stored on exit in */ +/* > the elements on and above the diagonal of the array A. */ +/* > */ +/* > 0 is a (M-N)-by-N zero matrix, and is not stored. */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. M >= N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MB */ +/* > \verbatim */ +/* > MB is INTEGER */ +/* > The row block size to be used in the blocked QR. */ +/* > MB > N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The column block size to be used in the blocked QR. */ +/* > N >= NB >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL 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 N-by-N upper triangular matrix R; */ +/* > the elements below the diagonal represent Q by the columns */ +/* > of blocked V (see Further Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is REAL array, */ +/* > dimension (LDT, N * Number_of_row_blocks) */ +/* > where Number_of_row_blocks = CEIL((M-N)/(MB-N)) */ +/* > The blocked upper triangular block reflectors stored in compact form */ +/* > as a sequence of upper triangular blocks. */ +/* > See Further Details below. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > (workspace) REAL array, dimension (MAX(1,LWORK)) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > The dimension of the array WORK. LWORK >= NB*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] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > Tall-Skinny QR (TSQR) performs QR by a sequence of orthogonal transformations, */ +/* > representing Q as a product of other orthogonal matrices */ +/* > Q = Q(1) * Q(2) * . . . * Q(k) */ +/* > where each Q(i) zeros out subdiagonal entries of a block of MB rows of A: */ +/* > Q(1) zeros out the subdiagonal entries of rows 1:MB of A */ +/* > Q(2) zeros out the bottom MB-N rows of rows [1:N,MB+1:2*MB-N] of A */ +/* > Q(3) zeros out the bottom MB-N rows of rows [1:N,2*MB-N+1:3*MB-2*N] of A */ +/* > . . . */ +/* > */ +/* > Q(1) is computed by GEQRT, which represents Q(1) by Householder vectors */ +/* > stored under the diagonal of rows 1:MB of A, and by upper triangular */ +/* > block reflectors, stored in array T(1:LDT,1:N). */ +/* > For more information see Further Details in GEQRT. */ +/* > */ +/* > Q(i) for i>1 is computed by TPQRT, which represents Q(i) by Householder vectors */ +/* > stored in rows [(i-1)*(MB-N)+N+1:i*(MB-N)+N] of A, and by upper triangular */ +/* > block reflectors, stored in array T(1:LDT,(i-1)*N+1:i*N). */ +/* > The last Q(k) may use fewer rows. */ +/* > For more information see Further Details in TPQRT. */ +/* > */ +/* > For more details of the overall algorithm, see the description of */ +/* > Sequential TSQR in Section 2.2 of [1]. */ +/* > */ +/* > [1] “Communication-Optimal Parallel and Sequential QR and LU Factorizations, */ +/* > J. Demmel, L. Grigori, M. Hoemmen, J. Langou, */ +/* > SIAM J. Sci. Comput, vol. 34, no. 1, 2012 */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int slatsqr_(integer *m, integer *n, integer *mb, integer * + nb, real *a, integer *lda, real *t, integer *ldt, real *work, integer + *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, t_dim1, t_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, ii, kk; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), sgeqrt_( + integer *, integer *, integer *, real *, integer *, real *, + integer *, real *, integer *); + logical lquery; + extern /* Subroutine */ int stpqrt_(integer *, integer *, integer *, + integer *, real *, integer *, real *, integer *, real *, integer * + , real *, integer *); + integer ctr; + + +/* -- LAPACK computational routine (version 3.9.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd. -- */ +/* November 2019 */ + + +/* ===================================================================== */ + + +/* TEST THE INPUT ARGUMENTS */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + --work; + + /* Function Body */ + *info = 0; + + lquery = *lwork == -1; + + if (*m < 0) { + *info = -1; + } else if (*n < 0 || *m < *n) { + *info = -2; + } else if (*mb <= *n) { + *info = -3; + } else if (*nb < 1 || *nb > *n && *n > 0) { + *info = -4; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } else if (*ldt < *nb) { + *info = -8; + } else if (*lwork < *n * *nb && ! lquery) { + *info = -10; + } + if (*info == 0) { + work[1] = (real) (*nb * *n); + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLATSQR", &i__1, (ftnlen)7); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (f2cmin(*m,*n) == 0) { + return 0; + } + +/* The QR Decomposition */ + + if (*mb <= *n || *mb >= *m) { + sgeqrt_(m, n, nb, &a[a_offset], lda, &t[t_offset], ldt, &work[1], + info); + return 0; + } + kk = (*m - *n) % (*mb - *n); + ii = *m - kk + 1; + +/* Compute the QR factorization of the first block A(1:MB,1:N) */ + + sgeqrt_(mb, n, nb, &a[a_dim1 + 1], lda, &t[t_offset], ldt, &work[1], info) + ; + + ctr = 1; + i__1 = ii - *mb + *n; + i__2 = *mb - *n; + for (i__ = *mb + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + +/* Compute the QR factorization of the current block A(I:I+MB-N,1:N) */ + + i__3 = *mb - *n; + stpqrt_(&i__3, n, &c__0, nb, &a[a_dim1 + 1], lda, &a[i__ + a_dim1], + lda, &t[(ctr * *n + 1) * t_dim1 + 1], ldt, &work[1], info); + ++ctr; + } + +/* Compute the QR factorization of the last block A(II:M,1:N) */ + + if (ii <= *m) { + stpqrt_(&kk, n, &c__0, nb, &a[a_dim1 + 1], lda, &a[ii + a_dim1], lda, + &t[(ctr * *n + 1) * t_dim1 + 1], ldt, &work[1], info); + } + + work[1] = (real) (*n * *nb); + return 0; + +/* End of SLATSQR */ + +} /* slatsqr_ */ + diff --git a/lapack-netlib/SRC/slauu2.c b/lapack-netlib/SRC/slauu2.c new file mode 100644 index 000000000..0dbcc0f78 --- /dev/null +++ b/lapack-netlib/SRC/slauu2.c @@ -0,0 +1,602 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SLAUU2 computes the product UUH or LHL, where U and L are upper or lower triangular matrices (u +nblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAUU2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAUU2( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* REAL A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAUU2 computes the product U * U**T or L**T * L, where the triangular */ +/* > factor U or L is stored in the upper or lower triangular part of */ +/* > the array A. */ +/* > */ +/* > If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ +/* > overwriting the factor U in A. */ +/* > If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ +/* > overwriting the factor L in A. */ +/* > */ +/* > This is the unblocked form of the algorithm, calling Level 2 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the triangular factor stored in the array A */ +/* > is upper or lower triangular: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the triangular factor U or L. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the triangular factor U or L. */ +/* > On exit, if UPLO = 'U', the upper triangle of A is */ +/* > overwritten with the upper triangle of the product U * U**T; */ +/* > if UPLO = 'L', the lower triangle of A is overwritten with */ +/* > the lower triangle of the product L**T * L. */ +/* > \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 realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slauu2_(char *uplo, integer *n, real *a, integer *lda, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + + /* Local variables */ + extern real sdot_(integer *, real *, integer *, real *, integer *); + integer i__; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), + sgemv_(char *, integer *, integer *, real *, real *, integer *, + real *, integer *, real *, real *, integer *); + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real aii; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAUU2", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (upper) { + +/* Compute the product U * U**T. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + aii = a[i__ + i__ * a_dim1]; + if (i__ < *n) { + i__2 = *n - i__ + 1; + a[i__ + i__ * a_dim1] = sdot_(&i__2, &a[i__ + i__ * a_dim1], + lda, &a[i__ + i__ * a_dim1], lda); + i__2 = i__ - 1; + i__3 = *n - i__; + sgemv_("No transpose", &i__2, &i__3, &c_b7, &a[(i__ + 1) * + a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, & + aii, &a[i__ * a_dim1 + 1], &c__1); + } else { + sscal_(&i__, &aii, &a[i__ * a_dim1 + 1], &c__1); + } +/* L10: */ + } + + } else { + +/* Compute the product L**T * L. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + aii = a[i__ + i__ * a_dim1]; + if (i__ < *n) { + i__2 = *n - i__ + 1; + a[i__ + i__ * a_dim1] = sdot_(&i__2, &a[i__ + i__ * a_dim1], & + c__1, &a[i__ + i__ * a_dim1], &c__1); + i__2 = *n - i__; + i__3 = i__ - 1; + sgemv_("Transpose", &i__2, &i__3, &c_b7, &a[i__ + 1 + a_dim1], + lda, &a[i__ + 1 + i__ * a_dim1], &c__1, &aii, &a[i__ + + a_dim1], lda); + } else { + sscal_(&i__, &aii, &a[i__ + a_dim1], lda); + } +/* L20: */ + } + } + + return 0; + +/* End of SLAUU2 */ + +} /* slauu2_ */ + diff --git a/lapack-netlib/SRC/slauum.c b/lapack-netlib/SRC/slauum.c new file mode 100644 index 000000000..a68f7a13b --- /dev/null +++ b/lapack-netlib/SRC/slauum.c @@ -0,0 +1,642 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#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 SLAUUM computes the product UUH or LHL, where U and L are upper or lower triangular matrices (b +locked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SLAUUM + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SLAUUM( UPLO, N, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* REAL A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SLAUUM computes the product U * U**T or L**T * L, where the triangular */ +/* > factor U or L is stored in the upper or lower triangular part of */ +/* > the array A. */ +/* > */ +/* > If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */ +/* > overwriting the factor U in A. */ +/* > If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */ +/* > overwriting the factor L in A. */ +/* > */ +/* > This is the blocked form of the algorithm, calling Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the triangular factor stored in the array A */ +/* > is upper or lower triangular: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the triangular factor U or L. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > On entry, the triangular factor U or L. */ +/* > On exit, if UPLO = 'U', the upper triangle of A is */ +/* > overwritten with the upper triangle of the product U * U**T; */ +/* > if UPLO = 'L', the lower triangle of A is overwritten with */ +/* > the lower triangle of the product L**T * L. */ +/* > \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 realOTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int slauum_(char *uplo, integer *n, real *a, integer *lda, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer i__; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *); + logical upper; + extern /* Subroutine */ int strmm_(char *, char *, char *, char *, + integer *, integer *, real *, real *, integer *, real *, integer * + ), ssyrk_(char *, char *, integer + *, integer *, real *, real *, integer *, real *, real *, integer * + ); + integer ib; + extern /* Subroutine */ int slauu2_(char *, integer *, real *, integer *, + integer *); + integer nb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAUUM", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Determine the block size for this environment. */ + + nb = ilaenv_(&c__1, "SLAUUM", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + + if (nb <= 1 || nb >= *n) { + +/* Use unblocked code */ + + slauu2_(uplo, n, &a[a_offset], lda, info); + } else { + +/* Use blocked code */ + + if (upper) { + +/* Compute the product U * U**T. */ + + i__1 = *n; + 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 = *n - i__ + 1; + ib = f2cmin(i__3,i__4); + i__3 = i__ - 1; + strmm_("Right", "Upper", "Transpose", "Non-unit", &i__3, &ib, + &c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ * a_dim1 + + 1], lda) + ; + slauu2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info); + if (i__ + ib <= *n) { + i__3 = i__ - 1; + i__4 = *n - i__ - ib + 1; + sgemm_("No transpose", "Transpose", &i__3, &ib, &i__4, & + c_b15, &a[(i__ + ib) * a_dim1 + 1], lda, &a[i__ + + (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ * + a_dim1 + 1], lda); + i__3 = *n - i__ - ib + 1; + ssyrk_("Upper", "No transpose", &ib, &i__3, &c_b15, &a[ + i__ + (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ + + i__ * a_dim1], lda); + } +/* L10: */ + } + } else { + +/* Compute the product L**T * L. */ + + i__2 = *n; + 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 = *n - i__ + 1; + ib = f2cmin(i__3,i__4); + i__3 = i__ - 1; + strmm_("Left", "Lower", "Transpose", "Non-unit", &ib, &i__3, & + c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ + a_dim1], + lda); + slauu2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info); + if (i__ + ib <= *n) { + i__3 = i__ - 1; + i__4 = *n - i__ - ib + 1; + sgemm_("Transpose", "No transpose", &ib, &i__3, &i__4, & + c_b15, &a[i__ + ib + i__ * a_dim1], lda, &a[i__ + + ib + a_dim1], lda, &c_b15, &a[i__ + a_dim1], lda); + i__3 = *n - i__ - ib + 1; + ssyrk_("Lower", "Transpose", &ib, &i__3, &c_b15, &a[i__ + + ib + i__ * a_dim1], lda, &c_b15, &a[i__ + i__ * + a_dim1], lda); + } +/* L20: */ + } + } + } + + return 0; + +/* End of SLAUUM */ + +} /* slauum_ */ + diff --git a/lapack-netlib/SRC/sopgtr.c b/lapack-netlib/SRC/sopgtr.c new file mode 100644 index 000000000..01be01f32 --- /dev/null +++ b/lapack-netlib/SRC/sopgtr.c @@ -0,0 +1,641 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SOPGTR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SOPGTR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDQ, N */ +/* REAL AP( * ), Q( LDQ, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SOPGTR generates a real orthogonal matrix Q which is defined as the */ +/* > product of n-1 elementary reflectors H(i) of order n, as returned by */ +/* > SSPTRD using packed storage: */ +/* > */ +/* > if UPLO = 'U', Q = H(n-1) . . . H(2) H(1), */ +/* > */ +/* > if UPLO = 'L', Q = H(1) H(2) . . . H(n-1). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangular packed storage used in previous */ +/* > call to SSPTRD; */ +/* > = 'L': Lower triangular packed storage used in previous */ +/* > call to SSPTRD. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix Q. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is REAL array, dimension (N*(N+1)/2) */ +/* > The vectors which define the elementary reflectors, as */ +/* > returned by SSPTRD. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is REAL array, dimension (N-1) */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by SSPTRD. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is REAL array, dimension (LDQ,N) */ +/* > The N-by-N orthogonal matrix Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (N-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 December 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int sopgtr_(char *uplo, integer *n, real *ap, real *tau, + real *q, integer *ldq, real *work, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, i__1, i__2, i__3; + + /* Local variables */ + integer i__, j; + extern logical lsame_(char *, char *); + integer iinfo; + logical upper; + extern /* Subroutine */ int sorg2l_(integer *, integer *, integer *, real + *, integer *, real *, real *, integer *), sorg2r_(integer *, + integer *, integer *, real *, integer *, real *, real *, integer * + ); + integer ij; + 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 arguments */ + + /* Parameter adjustments */ + --ap; + --tau; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldq < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SOPGTR", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (upper) { + +/* Q was determined by a call to SSPTRD with UPLO = 'U' */ + +/* Unpack the vectors which define the elementary reflectors and */ +/* set the last row and column of Q equal to those of the unit */ +/* matrix */ + + ij = 2; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + q[i__ + j * q_dim1] = ap[ij]; + ++ij; +/* L10: */ + } + ij += 2; + q[*n + j * q_dim1] = 0.f; +/* L20: */ + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + q[i__ + *n * q_dim1] = 0.f; +/* L30: */ + } + q[*n + *n * q_dim1] = 1.f; + +/* Generate Q(1:n-1,1:n-1) */ + + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + sorg2l_(&i__1, &i__2, &i__3, &q[q_offset], ldq, &tau[1], &work[1], & + iinfo); + + } else { + +/* Q was determined by a call to SSPTRD with UPLO = 'L'. */ + +/* Unpack the vectors which define the elementary reflectors and */ +/* set the first row and column of Q equal to those of the unit */ +/* matrix */ + + q[q_dim1 + 1] = 1.f; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + q[i__ + q_dim1] = 0.f; +/* L40: */ + } + ij = 3; + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + q[j * q_dim1 + 1] = 0.f; + i__2 = *n; + for (i__ = j + 1; i__ <= i__2; ++i__) { + q[i__ + j * q_dim1] = ap[ij]; + ++ij; +/* L50: */ + } + ij += 2; +/* L60: */ + } + if (*n > 1) { + +/* Generate Q(2:n,2:n) */ + + i__1 = *n - 1; + i__2 = *n - 1; + i__3 = *n - 1; + sorg2r_(&i__1, &i__2, &i__3, &q[(q_dim1 << 1) + 2], ldq, &tau[1], + &work[1], &iinfo); + } + } + return 0; + +/* End of SOPGTR */ + +} /* sopgtr_ */ + diff --git a/lapack-netlib/SRC/sopmtr.c b/lapack-netlib/SRC/sopmtr.c new file mode 100644 index 000000000..1705dd3bd --- /dev/null +++ b/lapack-netlib/SRC/sopmtr.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 SOPMTR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SOPMTR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, */ +/* INFO ) */ + +/* CHARACTER SIDE, TRANS, UPLO */ +/* INTEGER INFO, LDC, M, N */ +/* REAL AP( * ), C( LDC, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SOPMTR overwrites the general real M-by-N matrix C with */ +/* > */ +/* > SIDE = 'L' SIDE = 'R' */ +/* > TRANS = 'N': Q * C C * Q */ +/* > TRANS = 'T': Q**T * C C * Q**T */ +/* > */ +/* > where Q is a real orthogonal matrix of order nq, with nq = m if */ +/* > SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of */ +/* > nq-1 elementary reflectors, as returned by SSPTRD using packed */ +/* > storage: */ +/* > */ +/* > if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); */ +/* > */ +/* > if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). */ +/* > \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] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangular packed storage used in previous */ +/* > call to SSPTRD; */ +/* > = 'L': Lower triangular packed storage used in previous */ +/* > call to SSPTRD. */ +/* > \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 C. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix C. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is REAL array, dimension */ +/* > (M*(M+1)/2) if SIDE = 'L' */ +/* > (N*(N+1)/2) if SIDE = 'R' */ +/* > The vectors which define the elementary reflectors, as */ +/* > returned by SSPTRD. AP is modified by the routine but */ +/* > restored on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TAU */ +/* > \verbatim */ +/* > TAU is REAL array, dimension (M-1) if SIDE = 'L' */ +/* > or (N-1) if SIDE = 'R' */ +/* > TAU(i) must contain the scalar factor of the elementary */ +/* > reflector H(i), as returned by SSPTRD. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is REAL 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 */ +/* > WORK is REAL array, dimension */ +/* > (N) if SIDE = 'L' */ +/* > (M) 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 realOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int sopmtr_(char *side, char *uplo, char *trans, integer *m, + integer *n, real *ap, real *tau, real *c__, integer *ldc, real *work, + integer *info) +{ + /* System generated locals */ + integer c_dim1, c_offset, i__1, i__2; + + /* Local variables */ + logical left; + integer i__; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *, + integer *, real *, real *, integer *, real *); + integer i1; + logical upper; + integer i2, i3, ic, jc, ii, mi, ni, nq; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical notran, forwrd; + real aii; + + +/* -- 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 */ + --ap; + --tau; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + notran = lsame_(trans, "N"); + upper = lsame_(uplo, "U"); + +/* NQ is the order of Q */ + + if (left) { + nq = *m; + } else { + nq = *n; + } + if (! left && ! lsame_(side, "R")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (! notran && ! lsame_(trans, "T")) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*ldc < f2cmax(1,*m)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SOPMTR", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + + if (upper) { + +/* Q was determined by a call to SSPTRD with UPLO = 'U' */ + + forwrd = left && notran || ! left && ! notran; + + if (forwrd) { + i1 = 1; + i2 = nq - 1; + i3 = 1; + ii = 2; + } else { + i1 = nq - 1; + i2 = 1; + i3 = -1; + ii = nq * (nq + 1) / 2 - 1; + } + + if (left) { + ni = *n; + } else { + mi = *m; + } + + i__1 = i2; + i__2 = i3; + for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + if (left) { + +/* H(i) is applied to C(1:i,1:n) */ + + mi = i__; + } else { + +/* H(i) is applied to C(1:m,1:i) */ + + ni = i__; + } + +/* Apply H(i) */ + + aii = ap[ii]; + ap[ii] = 1.f; + slarf_(side, &mi, &ni, &ap[ii - i__ + 1], &c__1, &tau[i__], &c__[ + c_offset], ldc, &work[1]); + ap[ii] = aii; + + if (forwrd) { + ii = ii + i__ + 2; + } else { + ii = ii - i__ - 1; + } +/* L10: */ + } + } else { + +/* Q was determined by a call to SSPTRD with UPLO = 'L'. */ + + forwrd = left && ! notran || ! left && notran; + + if (forwrd) { + i1 = 1; + i2 = nq - 1; + i3 = 1; + ii = 2; + } else { + i1 = nq - 1; + i2 = 1; + i3 = -1; + ii = nq * (nq + 1) / 2 - 1; + } + + if (left) { + ni = *n; + jc = 1; + } else { + mi = *m; + ic = 1; + } + + i__2 = i2; + i__1 = i3; + for (i__ = i1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { + aii = ap[ii]; + ap[ii] = 1.f; + if (left) { + +/* H(i) is applied to C(i+1:m,1:n) */ + + mi = *m - i__; + ic = i__ + 1; + } else { + +/* H(i) is applied to C(1:m,i+1:n) */ + + ni = *n - i__; + jc = i__ + 1; + } + +/* Apply H(i) */ + + slarf_(side, &mi, &ni, &ap[ii], &c__1, &tau[i__], &c__[ic + jc * + c_dim1], ldc, &work[1]); + ap[ii] = aii; + + if (forwrd) { + ii = ii + nq - i__ + 1; + } else { + ii = ii - nq + i__ - 2; + } +/* L20: */ + } + } + return 0; + +/* End of SOPMTR */ + +} /* sopmtr_ */ + diff --git a/lapack-netlib/SRC/sorbdb.c b/lapack-netlib/SRC/sorbdb.c new file mode 100644 index 000000000..aad6d7f1a --- /dev/null +++ b/lapack-netlib/SRC/sorbdb.c @@ -0,0 +1,1270 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 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 SORBDB */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SORBDB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SORBDB( TRANS, SIGNS, M, P, Q, X11, LDX11, X12, LDX12, */ +/* X21, LDX21, X22, LDX22, THETA, PHI, TAUP1, */ +/* TAUP2, TAUQ1, TAUQ2, WORK, LWORK, INFO ) */ + +/* CHARACTER SIGNS, TRANS */ +/* INTEGER INFO, LDX11, LDX12, LDX21, LDX22, LWORK, M, P, */ +/* $ Q */ +/* REAL PHI( * ), THETA( * ) */ +/* REAL TAUP1( * ), TAUP2( * ), TAUQ1( * ), TAUQ2( * ), */ +/* $ WORK( * ), X11( LDX11, * ), X12( LDX12, * ), */ +/* $ X21( LDX21, * ), X22( LDX22, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SORBDB simultaneously bidiagonalizes the blocks of an M-by-M */ +/* > partitioned orthogonal matrix X: */ +/* > */ +/* > [ B11 | B12 0 0 ] */ +/* > [ X11 | X12 ] [ P1 | ] [ 0 | 0 -I 0 ] [ Q1 | ]**T */ +/* > X = [-----------] = [---------] [----------------] [---------] . */ +/* > [ X21 | X22 ] [ | P2 ] [ B21 | B22 0 0 ] [ | Q2 ] */ +/* > [ 0 | 0 0 I ] */ +/* > */ +/* > X11 is P-by-Q. Q must be no larger than P, M-P, or M-Q. (If this is */ +/* > not the case, then X must be transposed and/or permuted. This can be */ +/* > done in constant time using the TRANS and SIGNS options. See SORCSD */ +/* > for details.) */ +/* > */ +/* > The orthogonal matrices P1, P2, Q1, and Q2 are P-by-P, (M-P)-by- */ +/* > (M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. They are */ +/* > represented implicitly by Householder vectors. */ +/* > */ +/* > B11, B12, B21, and B22 are Q-by-Q bidiagonal matrices represented */ +/* > implicitly by angles THETA, PHI. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \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] SIGNS */ +/* > \verbatim */ +/* > SIGNS is CHARACTER */ +/* > = 'O': The lower-left block is made nonpositive (the */ +/* > "other" convention); */ +/* > otherwise: The upper-right block is made nonpositive (the */ +/* > "default" convention). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows and columns in X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows in X11 and X12. 0 <= P <= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Q */ +/* > \verbatim */ +/* > Q is INTEGER */ +/* > The number of columns in X11 and X21. 0 <= Q <= */ +/* > MIN(P,M-P,M-Q). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X11 */ +/* > \verbatim */ +/* > X11 is REAL array, dimension (LDX11,Q) */ +/* > On entry, the top-left block of the orthogonal matrix to be */ +/* > reduced. On exit, the form depends on TRANS: */ +/* > If TRANS = 'N', then */ +/* > the columns of tril(X11) specify reflectors for P1, */ +/* > the rows of triu(X11,1) specify reflectors for Q1; */ +/* > else TRANS = 'T', and */ +/* > the rows of triu(X11) specify reflectors for P1, */ +/* > the columns of tril(X11,-1) specify reflectors for Q1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX11 */ +/* > \verbatim */ +/* > LDX11 is INTEGER */ +/* > The leading dimension of X11. If TRANS = 'N', then LDX11 >= */ +/* > P; else LDX11 >= Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X12 */ +/* > \verbatim */ +/* > X12 is REAL array, dimension (LDX12,M-Q) */ +/* > On entry, the top-right block of the orthogonal matrix to */ +/* > be reduced. On exit, the form depends on TRANS: */ +/* > If TRANS = 'N', then */ +/* > the rows of triu(X12) specify the first P reflectors for */ +/* > Q2; */ +/* > else TRANS = 'T', and */ +/* > the columns of tril(X12) specify the first P reflectors */ +/* > for Q2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX12 */ +/* > \verbatim */ +/* > LDX12 is INTEGER */ +/* > The leading dimension of X12. If TRANS = 'N', then LDX12 >= */ +/* > P; else LDX11 >= M-Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X21 */ +/* > \verbatim */ +/* > X21 is REAL array, dimension (LDX21,Q) */ +/* > On entry, the bottom-left block of the orthogonal matrix to */ +/* > be reduced. On exit, the form depends on TRANS: */ +/* > If TRANS = 'N', then */ +/* > the columns of tril(X21) specify reflectors for P2; */ +/* > else TRANS = 'T', and */ +/* > the rows of triu(X21) specify reflectors for P2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX21 */ +/* > \verbatim */ +/* > LDX21 is INTEGER */ +/* > The leading dimension of X21. If TRANS = 'N', then LDX21 >= */ +/* > M-P; else LDX21 >= Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X22 */ +/* > \verbatim */ +/* > X22 is REAL array, dimension (LDX22,M-Q) */ +/* > On entry, the bottom-right block of the orthogonal matrix to */ +/* > be reduced. On exit, the form depends on TRANS: */ +/* > If TRANS = 'N', then */ +/* > the rows of triu(X22(Q+1:M-P,P+1:M-Q)) specify the last */ +/* > M-P-Q reflectors for Q2, */ +/* > else TRANS = 'T', and */ +/* > the columns of tril(X22(P+1:M-Q,Q+1:M-P)) specify the last */ +/* > M-P-Q reflectors for P2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX22 */ +/* > \verbatim */ +/* > LDX22 is INTEGER */ +/* > The leading dimension of X22. If TRANS = 'N', then LDX22 >= */ +/* > M-P; else LDX22 >= M-Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] THETA */ +/* > \verbatim */ +/* > THETA is REAL array, dimension (Q) */ +/* > The entries of the bidiagonal blocks B11, B12, B21, B22 can */ +/* > be computed from the angles THETA and PHI. See Further */ +/* > Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PHI */ +/* > \verbatim */ +/* > PHI is REAL array, dimension (Q-1) */ +/* > The entries of the bidiagonal blocks B11, B12, B21, B22 can */ +/* > be computed from the angles THETA and PHI. See Further */ +/* > Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUP1 */ +/* > \verbatim */ +/* > TAUP1 is REAL array, dimension (P) */ +/* > The scalar factors of the elementary reflectors that define */ +/* > P1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUP2 */ +/* > \verbatim */ +/* > TAUP2 is REAL array, dimension (M-P) */ +/* > The scalar factors of the elementary reflectors that define */ +/* > P2. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUQ1 */ +/* > \verbatim */ +/* > TAUQ1 is REAL array, dimension (Q) */ +/* > The scalar factors of the elementary reflectors that define */ +/* > Q1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUQ2 */ +/* > \verbatim */ +/* > TAUQ2 is REAL array, dimension (M-Q) */ +/* > The scalar factors of the elementary reflectors that define */ +/* > Q2. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (LWORK) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= M-Q. */ +/* > */ +/* > 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 realOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The bidiagonal blocks B11, B12, B21, and B22 are represented */ +/* > implicitly by angles THETA(1), ..., THETA(Q) and PHI(1), ..., */ +/* > PHI(Q-1). B11 and B21 are upper bidiagonal, while B21 and B22 are */ +/* > lower bidiagonal. Every entry in each bidiagonal band is a product */ +/* > of a sine or cosine of a THETA with a sine or cosine of a PHI. See */ +/* > [1] or SORCSD for details. */ +/* > */ +/* > P1, P2, Q1, and Q2 are represented as products of elementary */ +/* > reflectors. See SORCSD for details on generating P1, P2, Q1, and Q2 */ +/* > using SORGQR and SORGLQ. */ +/* > \endverbatim */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. */ +/* > Algorithms, 50(1):33-65, 2009. */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int sorbdb_(char *trans, char *signs, integer *m, integer *p, + integer *q, real *x11, integer *ldx11, real *x12, integer *ldx12, + real *x21, integer *ldx21, real *x22, integer *ldx22, real *theta, + real *phi, real *taup1, real *taup2, real *tauq1, real *tauq2, real * + work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer x11_dim1, x11_offset, x12_dim1, x12_offset, x21_dim1, x21_offset, + x22_dim1, x22_offset, i__1, i__2, i__3; + real r__1; + + /* Local variables */ + logical colmajor; + integer lworkmin, lworkopt; + extern real snrm2_(integer *, real *, integer *); + integer i__; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), + slarf_(char *, integer *, integer *, real *, integer *, real *, + real *, integer *, real *), saxpy_(integer *, real *, + real *, integer *, real *, integer *); + real z1, z2, z3, z4; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical lquery; + extern /* Subroutine */ int slarfgp_(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 input arguments */ + + /* Parameter adjustments */ + x11_dim1 = *ldx11; + x11_offset = 1 + x11_dim1 * 1; + x11 -= x11_offset; + x12_dim1 = *ldx12; + x12_offset = 1 + x12_dim1 * 1; + x12 -= x12_offset; + x21_dim1 = *ldx21; + x21_offset = 1 + x21_dim1 * 1; + x21 -= x21_offset; + x22_dim1 = *ldx22; + x22_offset = 1 + x22_dim1 * 1; + x22 -= x22_offset; + --theta; + --phi; + --taup1; + --taup2; + --tauq1; + --tauq2; + --work; + + /* Function Body */ + *info = 0; + colmajor = ! lsame_(trans, "T"); + if (! lsame_(signs, "O")) { + z1 = 1.f; + z2 = 1.f; + z3 = 1.f; + z4 = 1.f; + } else { + z1 = 1.f; + z2 = -1.f; + z3 = 1.f; + z4 = -1.f; + } + lquery = *lwork == -1; + + if (*m < 0) { + *info = -3; + } else if (*p < 0 || *p > *m) { + *info = -4; + } else if (*q < 0 || *q > *p || *q > *m - *p || *q > *m - *q) { + *info = -5; + } else if (colmajor && *ldx11 < f2cmax(1,*p)) { + *info = -7; + } else if (! colmajor && *ldx11 < f2cmax(1,*q)) { + *info = -7; + } else if (colmajor && *ldx12 < f2cmax(1,*p)) { + *info = -9; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *m - *q; + if (! colmajor && *ldx12 < f2cmax(i__1,i__2)) { + *info = -9; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *m - *p; + if (colmajor && *ldx21 < f2cmax(i__1,i__2)) { + *info = -11; + } else if (! colmajor && *ldx21 < f2cmax(1,*q)) { + *info = -11; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *m - *p; + if (colmajor && *ldx22 < f2cmax(i__1,i__2)) { + *info = -13; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *m - *q; + if (! colmajor && *ldx22 < f2cmax(i__1,i__2)) { + *info = -13; + } + } + } + } + } + +/* Compute workspace */ + + if (*info == 0) { + lworkopt = *m - *q; + lworkmin = *m - *q; + work[1] = (real) lworkopt; + if (*lwork < lworkmin && ! lquery) { + *info = -21; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("xORBDB", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Handle column-major and row-major separately */ + + if (colmajor) { + +/* Reduce columns 1, ..., Q of X11, X12, X21, and X22 */ + + i__1 = *q; + for (i__ = 1; i__ <= i__1; ++i__) { + + if (i__ == 1) { + i__2 = *p - i__ + 1; + sscal_(&i__2, &z1, &x11[i__ + i__ * x11_dim1], &c__1); + } else { + i__2 = *p - i__ + 1; + r__1 = z1 * cos(phi[i__ - 1]); + sscal_(&i__2, &r__1, &x11[i__ + i__ * x11_dim1], &c__1); + i__2 = *p - i__ + 1; + r__1 = -z1 * z3 * z4 * sin(phi[i__ - 1]); + saxpy_(&i__2, &r__1, &x12[i__ + (i__ - 1) * x12_dim1], &c__1, + &x11[i__ + i__ * x11_dim1], &c__1); + } + if (i__ == 1) { + i__2 = *m - *p - i__ + 1; + sscal_(&i__2, &z2, &x21[i__ + i__ * x21_dim1], &c__1); + } else { + i__2 = *m - *p - i__ + 1; + r__1 = z2 * cos(phi[i__ - 1]); + sscal_(&i__2, &r__1, &x21[i__ + i__ * x21_dim1], &c__1); + i__2 = *m - *p - i__ + 1; + r__1 = -z2 * z3 * z4 * sin(phi[i__ - 1]); + saxpy_(&i__2, &r__1, &x22[i__ + (i__ - 1) * x22_dim1], &c__1, + &x21[i__ + i__ * x21_dim1], &c__1); + } + + i__2 = *m - *p - i__ + 1; + i__3 = *p - i__ + 1; + theta[i__] = atan2(snrm2_(&i__2, &x21[i__ + i__ * x21_dim1], & + c__1), snrm2_(&i__3, &x11[i__ + i__ * x11_dim1], &c__1)); + + if (*p > i__) { + i__2 = *p - i__ + 1; + slarfgp_(&i__2, &x11[i__ + i__ * x11_dim1], &x11[i__ + 1 + + i__ * x11_dim1], &c__1, &taup1[i__]); + } else if (*p == i__) { + i__2 = *p - i__ + 1; + slarfgp_(&i__2, &x11[i__ + i__ * x11_dim1], &x11[i__ + i__ * + x11_dim1], &c__1, &taup1[i__]); + } + x11[i__ + i__ * x11_dim1] = 1.f; + if (*m - *p > i__) { + i__2 = *m - *p - i__ + 1; + slarfgp_(&i__2, &x21[i__ + i__ * x21_dim1], &x21[i__ + 1 + + i__ * x21_dim1], &c__1, &taup2[i__]); + } else if (*m - *p == i__) { + i__2 = *m - *p - i__ + 1; + slarfgp_(&i__2, &x21[i__ + i__ * x21_dim1], &x21[i__ + i__ * + x21_dim1], &c__1, &taup2[i__]); + } + x21[i__ + i__ * x21_dim1] = 1.f; + + if (*q > i__) { + i__2 = *p - i__ + 1; + i__3 = *q - i__; + slarf_("L", &i__2, &i__3, &x11[i__ + i__ * x11_dim1], &c__1, & + taup1[i__], &x11[i__ + (i__ + 1) * x11_dim1], ldx11, & + work[1]); + } + if (*m - *q + 1 > i__) { + i__2 = *p - i__ + 1; + i__3 = *m - *q - i__ + 1; + slarf_("L", &i__2, &i__3, &x11[i__ + i__ * x11_dim1], &c__1, & + taup1[i__], &x12[i__ + i__ * x12_dim1], ldx12, &work[ + 1]); + } + if (*q > i__) { + i__2 = *m - *p - i__ + 1; + i__3 = *q - i__; + slarf_("L", &i__2, &i__3, &x21[i__ + i__ * x21_dim1], &c__1, & + taup2[i__], &x21[i__ + (i__ + 1) * x21_dim1], ldx21, & + work[1]); + } + if (*m - *q + 1 > i__) { + i__2 = *m - *p - i__ + 1; + i__3 = *m - *q - i__ + 1; + slarf_("L", &i__2, &i__3, &x21[i__ + i__ * x21_dim1], &c__1, & + taup2[i__], &x22[i__ + i__ * x22_dim1], ldx22, &work[ + 1]); + } + + if (i__ < *q) { + i__2 = *q - i__; + r__1 = -z1 * z3 * sin(theta[i__]); + sscal_(&i__2, &r__1, &x11[i__ + (i__ + 1) * x11_dim1], ldx11); + i__2 = *q - i__; + r__1 = z2 * z3 * cos(theta[i__]); + saxpy_(&i__2, &r__1, &x21[i__ + (i__ + 1) * x21_dim1], ldx21, + &x11[i__ + (i__ + 1) * x11_dim1], ldx11); + } + i__2 = *m - *q - i__ + 1; + r__1 = -z1 * z4 * sin(theta[i__]); + sscal_(&i__2, &r__1, &x12[i__ + i__ * x12_dim1], ldx12); + i__2 = *m - *q - i__ + 1; + r__1 = z2 * z4 * cos(theta[i__]); + saxpy_(&i__2, &r__1, &x22[i__ + i__ * x22_dim1], ldx22, &x12[i__ + + i__ * x12_dim1], ldx12); + + if (i__ < *q) { + i__2 = *q - i__; + i__3 = *m - *q - i__ + 1; + phi[i__] = atan2(snrm2_(&i__2, &x11[i__ + (i__ + 1) * + x11_dim1], ldx11), snrm2_(&i__3, &x12[i__ + i__ * + x12_dim1], ldx12)); + } + + if (i__ < *q) { + if (*q - i__ == 1) { + i__2 = *q - i__; + slarfgp_(&i__2, &x11[i__ + (i__ + 1) * x11_dim1], &x11[ + i__ + (i__ + 1) * x11_dim1], ldx11, &tauq1[i__]); + } else { + i__2 = *q - i__; + slarfgp_(&i__2, &x11[i__ + (i__ + 1) * x11_dim1], &x11[ + i__ + (i__ + 2) * x11_dim1], ldx11, &tauq1[i__]); + } + x11[i__ + (i__ + 1) * x11_dim1] = 1.f; + } + if (*q + i__ - 1 < *m) { + if (*m - *q == i__) { + i__2 = *m - *q - i__ + 1; + slarfgp_(&i__2, &x12[i__ + i__ * x12_dim1], &x12[i__ + + i__ * x12_dim1], ldx12, &tauq2[i__]); + } else { + i__2 = *m - *q - i__ + 1; + slarfgp_(&i__2, &x12[i__ + i__ * x12_dim1], &x12[i__ + ( + i__ + 1) * x12_dim1], ldx12, &tauq2[i__]); + } + } + x12[i__ + i__ * x12_dim1] = 1.f; + + if (i__ < *q) { + i__2 = *p - i__; + i__3 = *q - i__; + slarf_("R", &i__2, &i__3, &x11[i__ + (i__ + 1) * x11_dim1], + ldx11, &tauq1[i__], &x11[i__ + 1 + (i__ + 1) * + x11_dim1], ldx11, &work[1]); + i__2 = *m - *p - i__; + i__3 = *q - i__; + slarf_("R", &i__2, &i__3, &x11[i__ + (i__ + 1) * x11_dim1], + ldx11, &tauq1[i__], &x21[i__ + 1 + (i__ + 1) * + x21_dim1], ldx21, &work[1]); + } + if (*p > i__) { + i__2 = *p - i__; + i__3 = *m - *q - i__ + 1; + slarf_("R", &i__2, &i__3, &x12[i__ + i__ * x12_dim1], ldx12, & + tauq2[i__], &x12[i__ + 1 + i__ * x12_dim1], ldx12, & + work[1]); + } + if (*m - *p > i__) { + i__2 = *m - *p - i__; + i__3 = *m - *q - i__ + 1; + slarf_("R", &i__2, &i__3, &x12[i__ + i__ * x12_dim1], ldx12, & + tauq2[i__], &x22[i__ + 1 + i__ * x22_dim1], ldx22, & + work[1]); + } + + } + +/* Reduce columns Q + 1, ..., P of X12, X22 */ + + i__1 = *p; + for (i__ = *q + 1; i__ <= i__1; ++i__) { + + i__2 = *m - *q - i__ + 1; + r__1 = -z1 * z4; + sscal_(&i__2, &r__1, &x12[i__ + i__ * x12_dim1], ldx12); + if (i__ >= *m - *q) { + i__2 = *m - *q - i__ + 1; + slarfgp_(&i__2, &x12[i__ + i__ * x12_dim1], &x12[i__ + i__ * + x12_dim1], ldx12, &tauq2[i__]); + } else { + i__2 = *m - *q - i__ + 1; + slarfgp_(&i__2, &x12[i__ + i__ * x12_dim1], &x12[i__ + (i__ + + 1) * x12_dim1], ldx12, &tauq2[i__]); + } + x12[i__ + i__ * x12_dim1] = 1.f; + + if (*p > i__) { + i__2 = *p - i__; + i__3 = *m - *q - i__ + 1; + slarf_("R", &i__2, &i__3, &x12[i__ + i__ * x12_dim1], ldx12, & + tauq2[i__], &x12[i__ + 1 + i__ * x12_dim1], ldx12, & + work[1]); + } + if (*m - *p - *q >= 1) { + i__2 = *m - *p - *q; + i__3 = *m - *q - i__ + 1; + slarf_("R", &i__2, &i__3, &x12[i__ + i__ * x12_dim1], ldx12, & + tauq2[i__], &x22[*q + 1 + i__ * x22_dim1], ldx22, & + work[1]); + } + + } + +/* Reduce columns P + 1, ..., M - Q of X12, X22 */ + + i__1 = *m - *p - *q; + for (i__ = 1; i__ <= i__1; ++i__) { + + i__2 = *m - *p - *q - i__ + 1; + r__1 = z2 * z4; + sscal_(&i__2, &r__1, &x22[*q + i__ + (*p + i__) * x22_dim1], + ldx22); + if (i__ == *m - *p - *q) { + i__2 = *m - *p - *q - i__ + 1; + slarfgp_(&i__2, &x22[*q + i__ + (*p + i__) * x22_dim1], &x22[* + q + i__ + (*p + i__) * x22_dim1], ldx22, &tauq2[*p + + i__]); + } else { + i__2 = *m - *p - *q - i__ + 1; + slarfgp_(&i__2, &x22[*q + i__ + (*p + i__) * x22_dim1], &x22[* + q + i__ + (*p + i__ + 1) * x22_dim1], ldx22, &tauq2[* + p + i__]); + } + x22[*q + i__ + (*p + i__) * x22_dim1] = 1.f; + if (i__ < *m - *p - *q) { + i__2 = *m - *p - *q - i__; + i__3 = *m - *p - *q - i__ + 1; + slarf_("R", &i__2, &i__3, &x22[*q + i__ + (*p + i__) * + x22_dim1], ldx22, &tauq2[*p + i__], &x22[*q + i__ + 1 + + (*p + i__) * x22_dim1], ldx22, &work[1]); + } + + } + + } else { + +/* Reduce columns 1, ..., Q of X11, X12, X21, X22 */ + + i__1 = *q; + for (i__ = 1; i__ <= i__1; ++i__) { + + if (i__ == 1) { + i__2 = *p - i__ + 1; + sscal_(&i__2, &z1, &x11[i__ + i__ * x11_dim1], ldx11); + } else { + i__2 = *p - i__ + 1; + r__1 = z1 * cos(phi[i__ - 1]); + sscal_(&i__2, &r__1, &x11[i__ + i__ * x11_dim1], ldx11); + i__2 = *p - i__ + 1; + r__1 = -z1 * z3 * z4 * sin(phi[i__ - 1]); + saxpy_(&i__2, &r__1, &x12[i__ - 1 + i__ * x12_dim1], ldx12, & + x11[i__ + i__ * x11_dim1], ldx11); + } + if (i__ == 1) { + i__2 = *m - *p - i__ + 1; + sscal_(&i__2, &z2, &x21[i__ + i__ * x21_dim1], ldx21); + } else { + i__2 = *m - *p - i__ + 1; + r__1 = z2 * cos(phi[i__ - 1]); + sscal_(&i__2, &r__1, &x21[i__ + i__ * x21_dim1], ldx21); + i__2 = *m - *p - i__ + 1; + r__1 = -z2 * z3 * z4 * sin(phi[i__ - 1]); + saxpy_(&i__2, &r__1, &x22[i__ - 1 + i__ * x22_dim1], ldx22, & + x21[i__ + i__ * x21_dim1], ldx21); + } + + i__2 = *m - *p - i__ + 1; + i__3 = *p - i__ + 1; + theta[i__] = atan2(snrm2_(&i__2, &x21[i__ + i__ * x21_dim1], + ldx21), snrm2_(&i__3, &x11[i__ + i__ * x11_dim1], ldx11)); + + i__2 = *p - i__ + 1; + slarfgp_(&i__2, &x11[i__ + i__ * x11_dim1], &x11[i__ + (i__ + 1) * + x11_dim1], ldx11, &taup1[i__]); + x11[i__ + i__ * x11_dim1] = 1.f; + if (i__ == *m - *p) { + i__2 = *m - *p - i__ + 1; + slarfgp_(&i__2, &x21[i__ + i__ * x21_dim1], &x21[i__ + i__ * + x21_dim1], ldx21, &taup2[i__]); + } else { + i__2 = *m - *p - i__ + 1; + slarfgp_(&i__2, &x21[i__ + i__ * x21_dim1], &x21[i__ + (i__ + + 1) * x21_dim1], ldx21, &taup2[i__]); + } + x21[i__ + i__ * x21_dim1] = 1.f; + + if (*q > i__) { + i__2 = *q - i__; + i__3 = *p - i__ + 1; + slarf_("R", &i__2, &i__3, &x11[i__ + i__ * x11_dim1], ldx11, & + taup1[i__], &x11[i__ + 1 + i__ * x11_dim1], ldx11, & + work[1]); + } + if (*m - *q + 1 > i__) { + i__2 = *m - *q - i__ + 1; + i__3 = *p - i__ + 1; + slarf_("R", &i__2, &i__3, &x11[i__ + i__ * x11_dim1], ldx11, & + taup1[i__], &x12[i__ + i__ * x12_dim1], ldx12, &work[ + 1]); + } + if (*q > i__) { + i__2 = *q - i__; + i__3 = *m - *p - i__ + 1; + slarf_("R", &i__2, &i__3, &x21[i__ + i__ * x21_dim1], ldx21, & + taup2[i__], &x21[i__ + 1 + i__ * x21_dim1], ldx21, & + work[1]); + } + if (*m - *q + 1 > i__) { + i__2 = *m - *q - i__ + 1; + i__3 = *m - *p - i__ + 1; + slarf_("R", &i__2, &i__3, &x21[i__ + i__ * x21_dim1], ldx21, & + taup2[i__], &x22[i__ + i__ * x22_dim1], ldx22, &work[ + 1]); + } + + if (i__ < *q) { + i__2 = *q - i__; + r__1 = -z1 * z3 * sin(theta[i__]); + sscal_(&i__2, &r__1, &x11[i__ + 1 + i__ * x11_dim1], &c__1); + i__2 = *q - i__; + r__1 = z2 * z3 * cos(theta[i__]); + saxpy_(&i__2, &r__1, &x21[i__ + 1 + i__ * x21_dim1], &c__1, & + x11[i__ + 1 + i__ * x11_dim1], &c__1); + } + i__2 = *m - *q - i__ + 1; + r__1 = -z1 * z4 * sin(theta[i__]); + sscal_(&i__2, &r__1, &x12[i__ + i__ * x12_dim1], &c__1); + i__2 = *m - *q - i__ + 1; + r__1 = z2 * z4 * cos(theta[i__]); + saxpy_(&i__2, &r__1, &x22[i__ + i__ * x22_dim1], &c__1, &x12[i__ + + i__ * x12_dim1], &c__1); + + if (i__ < *q) { + i__2 = *q - i__; + i__3 = *m - *q - i__ + 1; + phi[i__] = atan2(snrm2_(&i__2, &x11[i__ + 1 + i__ * x11_dim1], + &c__1), snrm2_(&i__3, &x12[i__ + i__ * x12_dim1], & + c__1)); + } + + if (i__ < *q) { + if (*q - i__ == 1) { + i__2 = *q - i__; + slarfgp_(&i__2, &x11[i__ + 1 + i__ * x11_dim1], &x11[i__ + + 1 + i__ * x11_dim1], &c__1, &tauq1[i__]); + } else { + i__2 = *q - i__; + slarfgp_(&i__2, &x11[i__ + 1 + i__ * x11_dim1], &x11[i__ + + 2 + i__ * x11_dim1], &c__1, &tauq1[i__]); + } + x11[i__ + 1 + i__ * x11_dim1] = 1.f; + } + if (*m - *q > i__) { + i__2 = *m - *q - i__ + 1; + slarfgp_(&i__2, &x12[i__ + i__ * x12_dim1], &x12[i__ + 1 + + i__ * x12_dim1], &c__1, &tauq2[i__]); + } else { + i__2 = *m - *q - i__ + 1; + slarfgp_(&i__2, &x12[i__ + i__ * x12_dim1], &x12[i__ + i__ * + x12_dim1], &c__1, &tauq2[i__]); + } + x12[i__ + i__ * x12_dim1] = 1.f; + + if (i__ < *q) { + i__2 = *q - i__; + i__3 = *p - i__; + slarf_("L", &i__2, &i__3, &x11[i__ + 1 + i__ * x11_dim1], & + c__1, &tauq1[i__], &x11[i__ + 1 + (i__ + 1) * + x11_dim1], ldx11, &work[1]); + i__2 = *q - i__; + i__3 = *m - *p - i__; + slarf_("L", &i__2, &i__3, &x11[i__ + 1 + i__ * x11_dim1], & + c__1, &tauq1[i__], &x21[i__ + 1 + (i__ + 1) * + x21_dim1], ldx21, &work[1]); + } + i__2 = *m - *q - i__ + 1; + i__3 = *p - i__; + slarf_("L", &i__2, &i__3, &x12[i__ + i__ * x12_dim1], &c__1, & + tauq2[i__], &x12[i__ + (i__ + 1) * x12_dim1], ldx12, & + work[1]); + if (*m - *p - i__ > 0) { + i__2 = *m - *q - i__ + 1; + i__3 = *m - *p - i__; + slarf_("L", &i__2, &i__3, &x12[i__ + i__ * x12_dim1], &c__1, & + tauq2[i__], &x22[i__ + (i__ + 1) * x22_dim1], ldx22, & + work[1]); + } + + } + +/* Reduce columns Q + 1, ..., P of X12, X22 */ + + i__1 = *p; + for (i__ = *q + 1; i__ <= i__1; ++i__) { + + i__2 = *m - *q - i__ + 1; + r__1 = -z1 * z4; + sscal_(&i__2, &r__1, &x12[i__ + i__ * x12_dim1], &c__1); + i__2 = *m - *q - i__ + 1; + slarfgp_(&i__2, &x12[i__ + i__ * x12_dim1], &x12[i__ + 1 + i__ * + x12_dim1], &c__1, &tauq2[i__]); + x12[i__ + i__ * x12_dim1] = 1.f; + + if (*p > i__) { + i__2 = *m - *q - i__ + 1; + i__3 = *p - i__; + slarf_("L", &i__2, &i__3, &x12[i__ + i__ * x12_dim1], &c__1, & + tauq2[i__], &x12[i__ + (i__ + 1) * x12_dim1], ldx12, & + work[1]); + } + if (*m - *p - *q >= 1) { + i__2 = *m - *q - i__ + 1; + i__3 = *m - *p - *q; + slarf_("L", &i__2, &i__3, &x12[i__ + i__ * x12_dim1], &c__1, & + tauq2[i__], &x22[i__ + (*q + 1) * x22_dim1], ldx22, & + work[1]); + } + + } + +/* Reduce columns P + 1, ..., M - Q of X12, X22 */ + + i__1 = *m - *p - *q; + for (i__ = 1; i__ <= i__1; ++i__) { + + i__2 = *m - *p - *q - i__ + 1; + r__1 = z2 * z4; + sscal_(&i__2, &r__1, &x22[*p + i__ + (*q + i__) * x22_dim1], & + c__1); + if (*m - *p - *q == i__) { + i__2 = *m - *p - *q - i__ + 1; + slarfgp_(&i__2, &x22[*p + i__ + (*q + i__) * x22_dim1], &x22[* + p + i__ + (*q + i__) * x22_dim1], &c__1, &tauq2[*p + + i__]); + x22[*p + i__ + (*q + i__) * x22_dim1] = 1.f; + } else { + i__2 = *m - *p - *q - i__ + 1; + slarfgp_(&i__2, &x22[*p + i__ + (*q + i__) * x22_dim1], &x22[* + p + i__ + 1 + (*q + i__) * x22_dim1], &c__1, &tauq2[* + p + i__]); + x22[*p + i__ + (*q + i__) * x22_dim1] = 1.f; + i__2 = *m - *p - *q - i__ + 1; + i__3 = *m - *p - *q - i__; + slarf_("L", &i__2, &i__3, &x22[*p + i__ + (*q + i__) * + x22_dim1], &c__1, &tauq2[*p + i__], &x22[*p + i__ + (* + q + i__ + 1) * x22_dim1], ldx22, &work[1]); + } + + + } + + } + + return 0; + +/* End of SORBDB */ + +} /* sorbdb_ */ +