diff --git a/lapack-netlib/SRC/dsytrf.c b/lapack-netlib/SRC/dsytrf.c new file mode 100644 index 000000000..eb834a8ce --- /dev/null +++ b/lapack-netlib/SRC/dsytrf.c @@ -0,0 +1,780 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYTRF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTRF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LWORK, N */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYTRF computes the factorization of a real symmetric matrix A using */ +/* > the Bunch-Kaufman diagonal pivoting method. The form of the */ +/* > factorization is */ +/* > */ +/* > A = U**T*D*U or A = L*D*L**T */ +/* > */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and D is symmetric and block diagonal with */ +/* > 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > This is the blocked version of the algorithm, calling Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, the block diagonal matrix D and the multipliers used */ +/* > to obtain the factor U or L (see below for further details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D. */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* > interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */ +/* > columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ +/* > is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */ +/* > IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */ +/* > interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of WORK. LWORK >=1. For best performance */ +/* > LWORK >= N*NB, where NB is the block size returned by ILAENV. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) is exactly zero. The factorization */ +/* > has been completed, but the block diagonal matrix D is */ +/* > exactly singular, and division by zero will occur if it */ +/* > is used to solve a system of equations. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleSYcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > If UPLO = 'U', then A = U**T*D*U, where */ +/* > U = P(n)*U(n)* ... *P(k)U(k)* ..., */ +/* > i.e., U is a product of terms P(k)*U(k), where k decreases from n to */ +/* > 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* > and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* > defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */ +/* > that if the diagonal block D(k) is of order s (s = 1 or 2), then */ +/* > */ +/* > ( I v 0 ) k-s */ +/* > U(k) = ( 0 I 0 ) s */ +/* > ( 0 0 I ) n-k */ +/* > k-s s n-k */ +/* > */ +/* > If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */ +/* > If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */ +/* > and A(k,k), and v overwrites A(1:k-2,k-1:k). */ +/* > */ +/* > If UPLO = 'L', then A = L*D*L**T, where */ +/* > L = P(1)*L(1)* ... *P(k)*L(k)* ..., */ +/* > i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */ +/* > n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* > and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* > defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */ +/* > that if the diagonal block D(k) is of order s (s = 1 or 2), then */ +/* > */ +/* > ( I 0 0 ) k-1 */ +/* > L(k) = ( 0 I 0 ) s */ +/* > ( 0 v I ) n-k-s+1 */ +/* > k-1 s n-k-s+1 */ +/* > */ +/* > If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */ +/* > If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */ +/* > and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dsytrf_(char *uplo, integer *n, doublereal *a, integer * + lda, integer *ipiv, doublereal *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer j, k; + extern logical lsame_(char *, char *); + integer nbmin, iinfo; + logical upper; + extern /* Subroutine */ int dsytf2_(char *, integer *, doublereal *, + integer *, integer *, integer *); + integer kb, nb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dlasyf_(char *, integer *, integer *, integer + *, doublereal *, integer *, integer *, doublereal *, integer *, + integer *); + integer ldwork, lwkopt; + logical lquery; + integer iws; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + lquery = *lwork == -1; + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*lwork < 1 && ! lquery) { + *info = -7; + } + + if (*info == 0) { + +/* Determine the block size */ + + nb = ilaenv_(&c__1, "DSYTRF", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); + lwkopt = *n * nb; + work[1] = (doublereal) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRF", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + + nbmin = 2; + ldwork = *n; + if (nb > 1 && nb < *n) { + iws = ldwork * nb; + if (*lwork < iws) { +/* Computing MAX */ + i__1 = *lwork / ldwork; + nb = f2cmax(i__1,1); +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "DSYTRF", uplo, n, &c_n1, &c_n1, & + c_n1, (ftnlen)6, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + } + } else { + iws = 1; + } + if (nb < nbmin) { + nb = *n; + } + + if (upper) { + +/* Factorize A as U**T*D*U using the upper triangle of A */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* KB, where KB is the number of columns factorized by DLASYF; */ +/* KB is either NB or NB-1, or K for the last block */ + + k = *n; +L10: + +/* If K < 1, exit from loop */ + + if (k < 1) { + goto L40; + } + + if (k > nb) { + +/* Factorize columns k-kb+1:k of A and use blocked code to */ +/* update columns 1:k-kb */ + + dlasyf_(uplo, &k, &nb, &kb, &a[a_offset], lda, &ipiv[1], &work[1], + &ldwork, &iinfo); + } else { + +/* Use unblocked code to factorize columns 1:k of A */ + + dsytf2_(uplo, &k, &a[a_offset], lda, &ipiv[1], &iinfo); + kb = k; + } + +/* Set INFO on the first occurrence of a zero pivot */ + + if (*info == 0 && iinfo > 0) { + *info = iinfo; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kb; + goto L10; + + } else { + +/* Factorize A as L*D*L**T using the lower triangle of A */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* KB, where KB is the number of columns factorized by DLASYF; */ +/* KB is either NB or NB-1, or N-K+1 for the last block */ + + k = 1; +L20: + +/* If K > N, exit from loop */ + + if (k > *n) { + goto L40; + } + + if (k <= *n - nb) { + +/* Factorize columns k:k+kb-1 of A and use blocked code to */ +/* update columns k+kb:n */ + + i__1 = *n - k + 1; + dlasyf_(uplo, &i__1, &nb, &kb, &a[k + k * a_dim1], lda, &ipiv[k], + &work[1], &ldwork, &iinfo); + } else { + +/* Use unblocked code to factorize columns k:n of A */ + + i__1 = *n - k + 1; + dsytf2_(uplo, &i__1, &a[k + k * a_dim1], lda, &ipiv[k], &iinfo); + kb = *n - k + 1; + } + +/* Set INFO on the first occurrence of a zero pivot */ + + if (*info == 0 && iinfo > 0) { + *info = iinfo + k - 1; + } + +/* Adjust IPIV */ + + i__1 = k + kb - 1; + for (j = k; j <= i__1; ++j) { + if (ipiv[j] > 0) { + ipiv[j] = ipiv[j] + k - 1; + } else { + ipiv[j] = ipiv[j] - k + 1; + } +/* L30: */ + } + +/* Increase K and return to the start of the main loop */ + + k += kb; + goto L20; + + } + +L40: + work[1] = (doublereal) lwkopt; + return 0; + +/* End of DSYTRF */ + +} /* dsytrf_ */ + diff --git a/lapack-netlib/SRC/dsytrf_aa.c b/lapack-netlib/SRC/dsytrf_aa.c new file mode 100644 index 000000000..a5c8d7fd4 --- /dev/null +++ b/lapack-netlib/SRC/dsytrf_aa.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 DSYTRF_AA */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTRF_AA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER N, LDA, LWORK, INFO */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), WORK( * ) */ + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYTRF_AA computes the factorization of a real symmetric matrix A */ +/* > using the Aasen's algorithm. The form of the factorization is */ +/* > */ +/* > A = U**T*T*U or A = L*T*L**T */ +/* > */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and T is a symmetric tridiagonal matrix. */ +/* > */ +/* > This is the blocked version of the algorithm, calling Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, the tridiagonal matrix is stored in the diagonals */ +/* > and the subdiagonals of A just below (or above) the diagonals, */ +/* > and L is stored below (or above) the subdiaonals, when UPLO */ +/* > is 'L' (or 'U'). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > On exit, it contains the details of the interchanges, i.e., */ +/* > the row and column k of A were interchanged with the */ +/* > row and column IPIV(k). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of WORK. LWORK >= MAX(1,2*N). For optimum performance */ +/* > LWORK >= N*(1+NB), where NB is the optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup doubleSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dsytrf_aa_(char *uplo, integer *n, doublereal *a, + integer *lda, integer *ipiv, doublereal *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer j; + doublereal alpha; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dgemm_(char *, char *, integer *, integer *, integer * + , doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dlasyf_aa_(char *, integer *, integer *, + integer *, doublereal *, integer *, integer *, doublereal *, + integer *, doublereal *), dgemv_(char *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *), dcopy_( + integer *, doublereal *, integer *, doublereal *, integer *), + dswap_(integer *, doublereal *, integer *, doublereal *, integer * + ); + logical upper; + integer k1, k2, j1, j2, j3, jb, nb, mj, nj; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer lwkopt; + logical lquery; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + + +/* ===================================================================== */ + + +/* Determine the block size */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + --work; + + /* Function Body */ + nb = ilaenv_(&c__1, "DSYTRF_AA", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)9, + (ftnlen)1); + +/* Test the input parameters. */ + + *info = 0; + upper = lsame_(uplo, "U"); + lquery = *lwork == -1; + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *n << 1; + if (*lwork < f2cmax(i__1,i__2) && ! lquery) { + *info = -7; + } + } + + if (*info == 0) { + lwkopt = (nb + 1) * *n; + work[1] = (doublereal) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRF_AA", &i__1, (ftnlen)9); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return */ + + if (*n == 0) { + return 0; + } + ipiv[1] = 1; + if (*n == 1) { + return 0; + } + +/* Adjust block size based on the workspace size */ + + if (*lwork < (nb + 1) * *n) { + nb = (*lwork - *n) / *n; + } + + if (upper) { + +/* ..................................................... */ +/* Factorize A as U**T*D*U using the upper triangle of A */ +/* ..................................................... */ + +/* Copy first row A(1, 1:N) into H(1:n) (stored in WORK(1:N)) */ + + dcopy_(n, &a[a_dim1 + 1], lda, &work[1], &c__1); + +/* J is the main loop index, increasing from 1 to N in steps of */ +/* JB, where JB is the number of columns factorized by DLASYF; */ +/* JB is either NB, or N-J+1 for the last block */ + + j = 0; +L10: + if (j >= *n) { + goto L20; + } + +/* each step of the main loop */ +/* J is the last column of the previous panel */ +/* J1 is the first column of the current panel */ +/* K1 identifies if the previous column of the panel has been */ +/* explicitly stored, e.g., K1=1 for the first panel, and */ +/* K1=0 for the rest */ + + j1 = j + 1; +/* Computing MIN */ + i__1 = *n - j1 + 1; + jb = f2cmin(i__1,nb); + k1 = f2cmax(1,j) - j; + +/* Panel factorization */ + + i__1 = 2 - k1; + i__2 = *n - j; + dlasyf_aa_(uplo, &i__1, &i__2, &jb, &a[f2cmax(1,j) + (j + 1) * a_dim1], + lda, &ipiv[j + 1], &work[1], n, &work[*n * nb + 1]) + ; + +/* Adjust IPIV and apply it back (J-th step picks (J+1)-th pivot) */ + +/* Computing MIN */ + i__2 = *n, i__3 = j + jb + 1; + i__1 = f2cmin(i__2,i__3); + for (j2 = j + 2; j2 <= i__1; ++j2) { + ipiv[j2] += j; + if (j2 != ipiv[j2] && j1 - k1 > 2) { + i__2 = j1 - k1 - 2; + dswap_(&i__2, &a[j2 * a_dim1 + 1], &c__1, &a[ipiv[j2] * + a_dim1 + 1], &c__1); + } + } + j += jb; + +/* Trailing submatrix update, where */ +/* the row A(J1-1, J2-1:N) stores U(J1, J2+1:N) and */ +/* WORK stores the current block of the auxiriarly matrix H */ + + if (j < *n) { + +/* If first panel and JB=1 (NB=1), then nothing to do */ + + if (j1 > 1 || jb > 1) { + +/* Merge rank-1 update with BLAS-3 update */ + + alpha = a[j + (j + 1) * a_dim1]; + a[j + (j + 1) * a_dim1] = 1.; + i__1 = *n - j; + dcopy_(&i__1, &a[j - 1 + (j + 1) * a_dim1], lda, &work[j + 1 + - j1 + 1 + jb * *n], &c__1); + i__1 = *n - j; + dscal_(&i__1, &alpha, &work[j + 1 - j1 + 1 + jb * *n], &c__1); + +/* K1 identifies if the previous column of the panel has been */ +/* explicitly stored, e.g., K1=1 and K2= 0 for the first panel, */ +/* while K1=0 and K2=1 for the rest */ + + if (j1 > 1) { + +/* Not first panel */ + + k2 = 1; + } else { + +/* First panel */ + + k2 = 0; + +/* First update skips the first column */ + + --jb; + } + + i__1 = *n; + i__2 = nb; + for (j2 = j + 1; i__2 < 0 ? j2 >= i__1 : j2 <= i__1; j2 += + i__2) { +/* Computing MIN */ + i__3 = nb, i__4 = *n - j2 + 1; + nj = f2cmin(i__3,i__4); + +/* Update (J2, J2) diagonal block with DGEMV */ + + j3 = j2; + for (mj = nj - 1; mj >= 1; --mj) { + i__3 = jb + 1; + dgemv_("No transpose", &mj, &i__3, &c_b18, &work[j3 - + j1 + 1 + k1 * *n], n, &a[j1 - k2 + j3 * + a_dim1], &c__1, &c_b20, &a[j3 + j3 * a_dim1], + lda); + ++j3; + } + +/* Update off-diagonal block of J2-th block row with DGEMM */ + + i__3 = *n - j3 + 1; + i__4 = jb + 1; + dgemm_("Transpose", "Transpose", &nj, &i__3, &i__4, & + c_b18, &a[j1 - k2 + j2 * a_dim1], lda, &work[j3 - + j1 + 1 + k1 * *n], n, &c_b20, &a[j2 + j3 * a_dim1] + , lda); + } + +/* Recover T( J, J+1 ) */ + + a[j + (j + 1) * a_dim1] = alpha; + } + +/* WORK(J+1, 1) stores H(J+1, 1) */ + + i__2 = *n - j; + dcopy_(&i__2, &a[j + 1 + (j + 1) * a_dim1], lda, &work[1], &c__1); + } + goto L10; + } else { + +/* ..................................................... */ +/* Factorize A as L*D*L**T using the lower triangle of A */ +/* ..................................................... */ + +/* copy first column A(1:N, 1) into H(1:N, 1) */ +/* (stored in WORK(1:N)) */ + + dcopy_(n, &a[a_dim1 + 1], &c__1, &work[1], &c__1); + +/* J is the main loop index, increasing from 1 to N in steps of */ +/* JB, where JB is the number of columns factorized by DLASYF; */ +/* JB is either NB, or N-J+1 for the last block */ + + j = 0; +L11: + if (j >= *n) { + goto L20; + } + +/* each step of the main loop */ +/* J is the last column of the previous panel */ +/* J1 is the first column of the current panel */ +/* K1 identifies if the previous column of the panel has been */ +/* explicitly stored, e.g., K1=1 for the first panel, and */ +/* K1=0 for the rest */ + + j1 = j + 1; +/* Computing MIN */ + i__2 = *n - j1 + 1; + jb = f2cmin(i__2,nb); + k1 = f2cmax(1,j) - j; + +/* Panel factorization */ + + i__2 = 2 - k1; + i__1 = *n - j; + dlasyf_aa_(uplo, &i__2, &i__1, &jb, &a[j + 1 + f2cmax(1,j) * a_dim1], + lda, &ipiv[j + 1], &work[1], n, &work[*n * nb + 1]) + ; + +/* Adjust IPIV and apply it back (J-th step picks (J+1)-th pivot) */ + +/* Computing MIN */ + i__1 = *n, i__3 = j + jb + 1; + i__2 = f2cmin(i__1,i__3); + for (j2 = j + 2; j2 <= i__2; ++j2) { + ipiv[j2] += j; + if (j2 != ipiv[j2] && j1 - k1 > 2) { + i__1 = j1 - k1 - 2; + dswap_(&i__1, &a[j2 + a_dim1], lda, &a[ipiv[j2] + a_dim1], + lda); + } + } + j += jb; + +/* Trailing submatrix update, where */ +/* A(J2+1, J1-1) stores L(J2+1, J1) and */ +/* WORK(J2+1, 1) stores H(J2+1, 1) */ + + if (j < *n) { + +/* if first panel and JB=1 (NB=1), then nothing to do */ + + if (j1 > 1 || jb > 1) { + +/* Merge rank-1 update with BLAS-3 update */ + + alpha = a[j + 1 + j * a_dim1]; + a[j + 1 + j * a_dim1] = 1.; + i__2 = *n - j; + dcopy_(&i__2, &a[j + 1 + (j - 1) * a_dim1], &c__1, &work[j + + 1 - j1 + 1 + jb * *n], &c__1); + i__2 = *n - j; + dscal_(&i__2, &alpha, &work[j + 1 - j1 + 1 + jb * *n], &c__1); + +/* K1 identifies if the previous column of the panel has been */ +/* explicitly stored, e.g., K1=1 and K2= 0 for the first panel, */ +/* while K1=0 and K2=1 for the rest */ + + if (j1 > 1) { + +/* Not first panel */ + + k2 = 1; + } else { + +/* First panel */ + + k2 = 0; + +/* First update skips the first column */ + + --jb; + } + + i__2 = *n; + i__1 = nb; + for (j2 = j + 1; i__1 < 0 ? j2 >= i__2 : j2 <= i__2; j2 += + i__1) { +/* Computing MIN */ + i__3 = nb, i__4 = *n - j2 + 1; + nj = f2cmin(i__3,i__4); + +/* Update (J2, J2) diagonal block with DGEMV */ + + j3 = j2; + for (mj = nj - 1; mj >= 1; --mj) { + i__3 = jb + 1; + dgemv_("No transpose", &mj, &i__3, &c_b18, &work[j3 - + j1 + 1 + k1 * *n], n, &a[j3 + (j1 - k2) * + a_dim1], lda, &c_b20, &a[j3 + j3 * a_dim1], & + c__1); + ++j3; + } + +/* Update off-diagonal block in J2-th block column with DGEMM */ + + i__3 = *n - j3 + 1; + i__4 = jb + 1; + dgemm_("No transpose", "Transpose", &i__3, &nj, &i__4, & + c_b18, &work[j3 - j1 + 1 + k1 * *n], n, &a[j2 + ( + j1 - k2) * a_dim1], lda, &c_b20, &a[j3 + j2 * + a_dim1], lda); + } + +/* Recover T( J+1, J ) */ + + a[j + 1 + j * a_dim1] = alpha; + } + +/* WORK(J+1, 1) stores H(J+1, 1) */ + + i__1 = *n - j; + dcopy_(&i__1, &a[j + 1 + (j + 1) * a_dim1], &c__1, &work[1], & + c__1); + } + goto L11; + } + +L20: + return 0; + +/* End of DSYTRF_AA */ + +} /* dsytrf_aa__ */ + diff --git a/lapack-netlib/SRC/dsytrf_rk.c b/lapack-netlib/SRC/dsytrf_rk.c new file mode 100644 index 000000000..79e48149a --- /dev/null +++ b/lapack-netlib/SRC/dsytrf_rk.c @@ -0,0 +1,920 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYTRF_RK computes the factorization of a real symmetric indefinite matrix using the bounded Bu +nch-Kaufman (rook) diagonal pivoting method (BLAS3 blocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTRF_RK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, */ +/* INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LWORK, N */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), E ( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > DSYTRF_RK computes the factorization of a real symmetric matrix A */ +/* > using the bounded Bunch-Kaufman (rook) diagonal pivoting method: */ +/* > */ +/* > A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), */ +/* > */ +/* > where U (or L) is unit upper (or lower) triangular matrix, */ +/* > U**T (or L**T) is the transpose of U (or L), P is a permutation */ +/* > matrix, P**T is the transpose of P, and D is symmetric and block */ +/* > diagonal with 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > This is the blocked version of the algorithm, calling Level 3 BLAS. */ +/* > For more information see Further Details section. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the upper or lower triangular part of the */ +/* > symmetric matrix A is stored: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION 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 DOUBLE PRECISION array, dimension (N) */ +/* > On exit, contains the superdiagonal (or subdiagonal) */ +/* > elements of the symmetric block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; */ +/* > If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. */ +/* > */ +/* > NOTE: For 1-by-1 diagonal block D(k), where */ +/* > 1 <= k <= N, the element E(k) is set to 0 in both */ +/* > UPLO = 'U' or UPLO = 'L' cases. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > IPIV describes the permutation matrix P in the factorization */ +/* > of matrix A as follows. The absolute value of IPIV(k) */ +/* > represents the index of row and column that were */ +/* > interchanged with the k-th row and column. The value of UPLO */ +/* > describes the order in which the interchanges were applied. */ +/* > Also, the sign of IPIV represents the block structure of */ +/* > the symmetric block diagonal matrix D with 1-by-1 or 2-by-2 */ +/* > diagonal blocks which correspond to 1 or 2 interchanges */ +/* > at each factorization step. For more info see Further */ +/* > Details section. */ +/* > */ +/* > If UPLO = 'U', */ +/* > ( in factorization order, k decreases from N to 1 ): */ +/* > a) A single positive entry IPIV(k) > 0 means: */ +/* > D(k,k) is a 1-by-1 diagonal block. */ +/* > If IPIV(k) != k, rows and columns k and IPIV(k) were */ +/* > interchanged in the matrix A(1:N,1:N); */ +/* > If IPIV(k) = k, no interchange occurred. */ +/* > */ +/* > b) A pair of consecutive negative entries */ +/* > IPIV(k) < 0 and IPIV(k-1) < 0 means: */ +/* > D(k-1:k,k-1:k) is a 2-by-2 diagonal block. */ +/* > (NOTE: negative entries in IPIV appear ONLY in pairs). */ +/* > 1) If -IPIV(k) != k, rows and columns */ +/* > k and -IPIV(k) were interchanged */ +/* > in the matrix A(1:N,1:N). */ +/* > If -IPIV(k) = k, no interchange occurred. */ +/* > 2) If -IPIV(k-1) != k-1, rows and columns */ +/* > k-1 and -IPIV(k-1) were interchanged */ +/* > in the matrix A(1:N,1:N). */ +/* > If -IPIV(k-1) = k-1, no interchange occurred. */ +/* > */ +/* > c) In both cases a) and b), always ABS( IPIV(k) ) <= k. */ +/* > */ +/* > d) NOTE: Any entry IPIV(k) is always NONZERO on output. */ +/* > */ +/* > If UPLO = 'L', */ +/* > ( in factorization order, k increases from 1 to N ): */ +/* > a) A single positive entry IPIV(k) > 0 means: */ +/* > D(k,k) is a 1-by-1 diagonal block. */ +/* > If IPIV(k) != k, rows and columns k and IPIV(k) were */ +/* > interchanged in the matrix A(1:N,1:N). */ +/* > If IPIV(k) = k, no interchange occurred. */ +/* > */ +/* > b) A pair of consecutive negative entries */ +/* > IPIV(k) < 0 and IPIV(k+1) < 0 means: */ +/* > D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ +/* > (NOTE: negative entries in IPIV appear ONLY in pairs). */ +/* > 1) If -IPIV(k) != k, rows and columns */ +/* > k and -IPIV(k) were interchanged */ +/* > in the matrix A(1:N,1:N). */ +/* > If -IPIV(k) = k, no interchange occurred. */ +/* > 2) If -IPIV(k+1) != k+1, rows and columns */ +/* > k-1 and -IPIV(k-1) were interchanged */ +/* > in the matrix A(1:N,1:N). */ +/* > If -IPIV(k+1) = k+1, no interchange occurred. */ +/* > */ +/* > c) In both cases a) and b), always ABS( IPIV(k) ) >= k. */ +/* > */ +/* > d) NOTE: Any entry IPIV(k) is always NONZERO on output. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension ( MAX(1,LWORK) ). */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of WORK. LWORK >=1. For best performance */ +/* > LWORK >= N*NB, where NB is the block size returned */ +/* > by ILAENV. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; */ +/* > the routine only calculates the optimal size of the WORK */ +/* > array, returns this value as the first entry of the WORK */ +/* > array, and no error message related to LWORK is issued */ +/* > by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > */ +/* > < 0: If INFO = -k, the k-th argument had an illegal value */ +/* > */ +/* > > 0: If INFO = k, the matrix A is singular, because: */ +/* > If UPLO = 'U': column k in the upper */ +/* > triangular part of A contains all zeros. */ +/* > If UPLO = 'L': column k in the lower */ +/* > triangular part of A contains all zeros. */ +/* > */ +/* > Therefore D(k,k) is exactly zero, and superdiagonal */ +/* > elements of column k of U (or subdiagonal elements of */ +/* > column k of L ) are all zeros. The factorization has */ +/* > been completed, but the block diagonal matrix D is */ +/* > exactly singular, and division by zero will occur if */ +/* > it is used to solve a system of equations. */ +/* > */ +/* > NOTE: INFO only stores the first occurrence of */ +/* > a singularity, any subsequent occurrence of singularity */ +/* > is not stored in INFO even though the factorization */ +/* > always completes. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleSYcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > TODO: put correct description */ +/* > \endverbatim */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > December 2016, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dsytrf_rk_(char *uplo, integer *n, doublereal *a, + integer *lda, doublereal *e, integer *ipiv, doublereal *work, integer + *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, k; + extern /* Subroutine */ int dsytf2_rk_(char *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *); + extern logical lsame_(char *, char *); + integer nbmin, iinfo; + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *); + logical upper; + extern /* Subroutine */ int dlasyf_rk_(char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, integer *); + integer kb, nb, ip; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer ldwork, lwkopt; + logical lquery; + integer iws; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --e; + --ipiv; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + lquery = *lwork == -1; + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*lwork < 1 && ! lquery) { + *info = -8; + } + + if (*info == 0) { + +/* Determine the block size */ + + nb = ilaenv_(&c__1, "DSYTRF_RK", uplo, n, &c_n1, &c_n1, &c_n1, ( + ftnlen)9, (ftnlen)1); + lwkopt = *n * nb; + work[1] = (doublereal) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRF_RK", &i__1, (ftnlen)9); + return 0; + } else if (lquery) { + return 0; + } + + nbmin = 2; + ldwork = *n; + if (nb > 1 && nb < *n) { + iws = ldwork * nb; + if (*lwork < iws) { +/* Computing MAX */ + i__1 = *lwork / ldwork; + nb = f2cmax(i__1,1); +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "DSYTRF_RK", uplo, n, &c_n1, & + c_n1, &c_n1, (ftnlen)9, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + } + } else { + iws = 1; + } + if (nb < nbmin) { + nb = *n; + } + + if (upper) { + +/* Factorize A as U*D*U**T using the upper triangle of A */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* KB, where KB is the number of columns factorized by DLASYF_RK; */ +/* KB is either NB or NB-1, or K for the last block */ + + k = *n; +L10: + +/* If K < 1, exit from loop */ + + if (k < 1) { + goto L15; + } + + if (k > nb) { + +/* Factorize columns k-kb+1:k of A and use blocked code to */ +/* update columns 1:k-kb */ + + dlasyf_rk_(uplo, &k, &nb, &kb, &a[a_offset], lda, &e[1], &ipiv[1] + , &work[1], &ldwork, &iinfo); + } else { + +/* Use unblocked code to factorize columns 1:k of A */ + + dsytf2_rk_(uplo, &k, &a[a_offset], lda, &e[1], &ipiv[1], &iinfo); + kb = k; + } + +/* Set INFO on the first occurrence of a zero pivot */ + + if (*info == 0 && iinfo > 0) { + *info = iinfo; + } + +/* No need to adjust IPIV */ + + +/* Apply permutations to the leading panel 1:k-1 */ + +/* Read IPIV from the last block factored, i.e. */ +/* indices k-kb+1:k and apply row permutations to the */ +/* last k+1 colunms k+1:N after that block */ +/* (We can do the simple loop over IPIV with decrement -1, */ +/* since the ABS value of IPIV( I ) represents the row index */ +/* of the interchange with row i in both 1x1 and 2x2 pivot cases) */ + + if (k < *n) { + i__1 = k - kb + 1; + for (i__ = k; i__ >= i__1; --i__) { + ip = (i__2 = ipiv[i__], abs(i__2)); + if (ip != i__) { + i__2 = *n - k; + dswap_(&i__2, &a[i__ + (k + 1) * a_dim1], lda, &a[ip + (k + + 1) * a_dim1], lda); + } + } + } + +/* Decrease K and return to the start of the main loop */ + + k -= kb; + goto L10; + +/* This label is the exit from main loop over K decreasing */ +/* from N to 1 in steps of KB */ + +L15: + + ; + } else { + +/* Factorize A as L*D*L**T using the lower triangle of A */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* KB, where KB is the number of columns factorized by DLASYF_RK; */ +/* KB is either NB or NB-1, or N-K+1 for the last block */ + + k = 1; +L20: + +/* If K > N, exit from loop */ + + if (k > *n) { + goto L35; + } + + if (k <= *n - nb) { + +/* Factorize columns k:k+kb-1 of A and use blocked code to */ +/* update columns k+kb:n */ + + i__1 = *n - k + 1; + dlasyf_rk_(uplo, &i__1, &nb, &kb, &a[k + k * a_dim1], lda, &e[k], + &ipiv[k], &work[1], &ldwork, &iinfo); + } else { + +/* Use unblocked code to factorize columns k:n of A */ + + i__1 = *n - k + 1; + dsytf2_rk_(uplo, &i__1, &a[k + k * a_dim1], lda, &e[k], &ipiv[k], + &iinfo); + kb = *n - k + 1; + + } + +/* Set INFO on the first occurrence of a zero pivot */ + + if (*info == 0 && iinfo > 0) { + *info = iinfo + k - 1; + } + +/* Adjust IPIV */ + + i__1 = k + kb - 1; + for (i__ = k; i__ <= i__1; ++i__) { + if (ipiv[i__] > 0) { + ipiv[i__] = ipiv[i__] + k - 1; + } else { + ipiv[i__] = ipiv[i__] - k + 1; + } + } + +/* Apply permutations to the leading panel 1:k-1 */ + +/* Read IPIV from the last block factored, i.e. */ +/* indices k:k+kb-1 and apply row permutations to the */ +/* first k-1 colunms 1:k-1 before that block */ +/* (We can do the simple loop over IPIV with increment 1, */ +/* since the ABS value of IPIV( I ) represents the row index */ +/* of the interchange with row i in both 1x1 and 2x2 pivot cases) */ + + if (k > 1) { + i__1 = k + kb - 1; + for (i__ = k; i__ <= i__1; ++i__) { + ip = (i__2 = ipiv[i__], abs(i__2)); + if (ip != i__) { + i__2 = k - 1; + dswap_(&i__2, &a[i__ + a_dim1], lda, &a[ip + a_dim1], lda) + ; + } + } + } + +/* Increase K and return to the start of the main loop */ + + k += kb; + goto L20; + +/* This label is the exit from main loop over K increasing */ +/* from 1 to N in steps of KB */ + +L35: + +/* End Lower */ + + ; + } + + work[1] = (doublereal) lwkopt; + return 0; + +/* End of DSYTRF_RK */ + +} /* dsytrf_rk__ */ + diff --git a/lapack-netlib/SRC/dsytrf_rook.c b/lapack-netlib/SRC/dsytrf_rook.c new file mode 100644 index 000000000..179cfefc2 --- /dev/null +++ b/lapack-netlib/SRC/dsytrf_rook.c @@ -0,0 +1,811 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYTRF_ROOK */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTRF_ROOK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LWORK, N */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYTRF_ROOK computes the factorization of a real symmetric matrix A */ +/* > using the bounded Bunch-Kaufman ("rook") diagonal pivoting method. */ +/* > The form of the factorization is */ +/* > */ +/* > A = U*D*U**T or A = L*D*L**T */ +/* > */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and D is symmetric and block diagonal with */ +/* > 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > This is the blocked version of the algorithm, calling Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the symmetric matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, the block diagonal matrix D and the multipliers used */ +/* > to obtain the factor U or L (see below for further details). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D. */ +/* > */ +/* > If UPLO = 'U': */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) */ +/* > were interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and */ +/* > columns k and -IPIV(k) were interchanged and rows and */ +/* > columns k-1 and -IPIV(k-1) were inerchaged, */ +/* > D(k-1:k,k-1:k) is a 2-by-2 diagonal block. */ +/* > */ +/* > If UPLO = 'L': */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) */ +/* > were interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and */ +/* > columns k and -IPIV(k) were interchanged and rows and */ +/* > columns k+1 and -IPIV(k+1) were inerchaged, */ +/* > D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)). */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of WORK. LWORK >=1. For best performance */ +/* > LWORK >= N*NB, where NB is the block size returned by ILAENV. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) is exactly zero. The factorization */ +/* > has been completed, but the block diagonal matrix D is */ +/* > exactly singular, and division by zero will occur if it */ +/* > is used to solve a system of equations. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup doubleSYcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > If UPLO = 'U', then A = U*D*U**T, where */ +/* > U = P(n)*U(n)* ... *P(k)U(k)* ..., */ +/* > i.e., U is a product of terms P(k)*U(k), where k decreases from n to */ +/* > 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* > and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* > defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */ +/* > that if the diagonal block D(k) is of order s (s = 1 or 2), then */ +/* > */ +/* > ( I v 0 ) k-s */ +/* > U(k) = ( 0 I 0 ) s */ +/* > ( 0 0 I ) n-k */ +/* > k-s s n-k */ +/* > */ +/* > If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */ +/* > If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */ +/* > and A(k,k), and v overwrites A(1:k-2,k-1:k). */ +/* > */ +/* > If UPLO = 'L', then A = L*D*L**T, where */ +/* > L = P(1)*L(1)* ... *P(k)*L(k)* ..., */ +/* > i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */ +/* > n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* > and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* > defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */ +/* > that if the diagonal block D(k) is of order s (s = 1 or 2), then */ +/* > */ +/* > ( I 0 0 ) k-1 */ +/* > L(k) = ( 0 I 0 ) s */ +/* > ( 0 v I ) n-k-s+1 */ +/* > k-1 s n-k-s+1 */ +/* > */ +/* > If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */ +/* > If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */ +/* > and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */ +/* > \endverbatim */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > April 2012, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dsytrf_rook_(char *uplo, integer *n, doublereal *a, + integer *lda, integer *ipiv, doublereal *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer j, k; + extern logical lsame_(char *, char *); + integer nbmin, iinfo; + logical upper; + integer kb, nb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer ldwork, lwkopt; + logical lquery; + integer iws; + extern /* Subroutine */ int dsytf2_rook_(char *, integer *, doublereal *, + integer *, integer *, integer *), dlasyf_rook_(char *, + integer *, integer *, integer *, doublereal *, integer *, integer + *, doublereal *, integer *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + lquery = *lwork == -1; + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*lwork < 1 && ! lquery) { + *info = -7; + } + + if (*info == 0) { + +/* Determine the block size */ + + nb = ilaenv_(&c__1, "DSYTRF_ROOK", uplo, n, &c_n1, &c_n1, &c_n1, ( + ftnlen)11, (ftnlen)1); +/* Computing MAX */ + i__1 = 1, i__2 = *n * nb; + lwkopt = f2cmax(i__1,i__2); + work[1] = (doublereal) lwkopt; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRF_ROOK", &i__1, (ftnlen)11); + return 0; + } else if (lquery) { + return 0; + } + + nbmin = 2; + ldwork = *n; + if (nb > 1 && nb < *n) { + iws = ldwork * nb; + if (*lwork < iws) { +/* Computing MAX */ + i__1 = *lwork / ldwork; + nb = f2cmax(i__1,1); +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "DSYTRF_ROOK", uplo, n, &c_n1, & + c_n1, &c_n1, (ftnlen)11, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + } + } else { + iws = 1; + } + if (nb < nbmin) { + nb = *n; + } + + if (upper) { + +/* Factorize A as U*D*U**T using the upper triangle of A */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* KB, where KB is the number of columns factorized by DLASYF_ROOK; */ +/* KB is either NB or NB-1, or K for the last block */ + + k = *n; +L10: + +/* If K < 1, exit from loop */ + + if (k < 1) { + goto L40; + } + + if (k > nb) { + +/* Factorize columns k-kb+1:k of A and use blocked code to */ +/* update columns 1:k-kb */ + + dlasyf_rook_(uplo, &k, &nb, &kb, &a[a_offset], lda, &ipiv[1], & + work[1], &ldwork, &iinfo); + } else { + +/* Use unblocked code to factorize columns 1:k of A */ + + dsytf2_rook_(uplo, &k, &a[a_offset], lda, &ipiv[1], &iinfo); + kb = k; + } + +/* Set INFO on the first occurrence of a zero pivot */ + + if (*info == 0 && iinfo > 0) { + *info = iinfo; + } + +/* No need to adjust IPIV */ + +/* Decrease K and return to the start of the main loop */ + + k -= kb; + goto L10; + + } else { + +/* Factorize A as L*D*L**T using the lower triangle of A */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* KB, where KB is the number of columns factorized by DLASYF_ROOK; */ +/* KB is either NB or NB-1, or N-K+1 for the last block */ + + k = 1; +L20: + +/* If K > N, exit from loop */ + + if (k > *n) { + goto L40; + } + + if (k <= *n - nb) { + +/* Factorize columns k:k+kb-1 of A and use blocked code to */ +/* update columns k+kb:n */ + + i__1 = *n - k + 1; + dlasyf_rook_(uplo, &i__1, &nb, &kb, &a[k + k * a_dim1], lda, & + ipiv[k], &work[1], &ldwork, &iinfo); + } else { + +/* Use unblocked code to factorize columns k:n of A */ + + i__1 = *n - k + 1; + dsytf2_rook_(uplo, &i__1, &a[k + k * a_dim1], lda, &ipiv[k], & + iinfo); + kb = *n - k + 1; + } + +/* Set INFO on the first occurrence of a zero pivot */ + + if (*info == 0 && iinfo > 0) { + *info = iinfo + k - 1; + } + +/* Adjust IPIV */ + + i__1 = k + kb - 1; + for (j = k; j <= i__1; ++j) { + if (ipiv[j] > 0) { + ipiv[j] = ipiv[j] + k - 1; + } else { + ipiv[j] = ipiv[j] - k + 1; + } +/* L30: */ + } + +/* Increase K and return to the start of the main loop */ + + k += kb; + goto L20; + + } + +L40: + work[1] = (doublereal) lwkopt; + return 0; + +/* End of DSYTRF_ROOK */ + +} /* dsytrf_rook__ */ + diff --git a/lapack-netlib/SRC/dsytri.c b/lapack-netlib/SRC/dsytri.c new file mode 100644 index 000000000..4bb234e80 --- /dev/null +++ b/lapack-netlib/SRC/dsytri.c @@ -0,0 +1,825 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYTRI */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTRI + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYTRI computes the inverse of a real symmetric indefinite matrix */ +/* > A using the factorization A = U*D*U**T or A = L*D*L**T computed by */ +/* > DSYTRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U*D*U**T; */ +/* > = 'L': Lower triangular, form is A = L*D*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the block diagonal matrix D and the multipliers */ +/* > used to obtain the factor U or L as computed by DSYTRF. */ +/* > */ +/* > On exit, if INFO = 0, the (symmetric) inverse of the original */ +/* > matrix. If UPLO = 'U', the upper triangular part of the */ +/* > inverse is formed and the part of A below the diagonal is not */ +/* > referenced; if UPLO = 'L' the lower triangular part of the */ +/* > inverse is formed and the part of A above the diagonal is */ +/* > not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */ +/* > inverse could not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dsytri_(char *uplo, integer *n, doublereal *a, integer * + lda, integer *ipiv, doublereal *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + doublereal d__1; + + /* Local variables */ + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + doublereal temp, akkp1, d__; + integer k; + doublereal t; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), dswap_(integer *, doublereal *, integer + *, doublereal *, integer *); + integer kstep; + logical upper; + extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *); + doublereal ak; + integer kp; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal akp1; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRI", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check that the diagonal matrix D is nonsingular. */ + + if (upper) { + +/* Upper triangular storage: examine D from bottom to top */ + + for (*info = *n; *info >= 1; --(*info)) { + if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.) { + return 0; + } +/* L10: */ + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.) { + return 0; + } +/* L20: */ + } + } + *info = 0; + + if (upper) { + +/* Compute inv(A) from the factorization A = U*D*U**T. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = 1; +L30: + +/* If K > N, exit from loop. */ + + if (k > *n) { + goto L40; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Invert the diagonal block. */ + + a[k + k * a_dim1] = 1. / a[k + k * a_dim1]; + +/* Compute column K of the inverse. */ + + if (k > 1) { + i__1 = k - 1; + dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1); + i__1 = k - 1; + dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], & + c__1, &c_b13, &a[k * a_dim1 + 1], &c__1); + i__1 = k - 1; + a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k * + a_dim1 + 1], &c__1); + } + kstep = 1; + } else { + +/* 2 x 2 diagonal block */ + +/* Invert the diagonal block. */ + + t = (d__1 = a[k + (k + 1) * a_dim1], abs(d__1)); + ak = a[k + k * a_dim1] / t; + akp1 = a[k + 1 + (k + 1) * a_dim1] / t; + akkp1 = a[k + (k + 1) * a_dim1] / t; + d__ = t * (ak * akp1 - 1.); + a[k + k * a_dim1] = akp1 / d__; + a[k + 1 + (k + 1) * a_dim1] = ak / d__; + a[k + (k + 1) * a_dim1] = -akkp1 / d__; + +/* Compute columns K and K+1 of the inverse. */ + + if (k > 1) { + i__1 = k - 1; + dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1); + i__1 = k - 1; + dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], & + c__1, &c_b13, &a[k * a_dim1 + 1], &c__1); + i__1 = k - 1; + a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k * + a_dim1 + 1], &c__1); + i__1 = k - 1; + a[k + (k + 1) * a_dim1] -= ddot_(&i__1, &a[k * a_dim1 + 1], & + c__1, &a[(k + 1) * a_dim1 + 1], &c__1); + i__1 = k - 1; + dcopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], & + c__1); + i__1 = k - 1; + dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], & + c__1, &c_b13, &a[(k + 1) * a_dim1 + 1], &c__1); + i__1 = k - 1; + a[k + 1 + (k + 1) * a_dim1] -= ddot_(&i__1, &work[1], &c__1, & + a[(k + 1) * a_dim1 + 1], &c__1); + } + kstep = 2; + } + + kp = (i__1 = ipiv[k], abs(i__1)); + if (kp != k) { + +/* Interchange rows and columns K and KP in the leading */ +/* submatrix A(1:k+1,1:k+1) */ + + i__1 = kp - 1; + dswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], & + c__1); + i__1 = k - kp - 1; + dswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1) * + a_dim1], lda); + temp = a[k + k * a_dim1]; + a[k + k * a_dim1] = a[kp + kp * a_dim1]; + a[kp + kp * a_dim1] = temp; + if (kstep == 2) { + temp = a[k + (k + 1) * a_dim1]; + a[k + (k + 1) * a_dim1] = a[kp + (k + 1) * a_dim1]; + a[kp + (k + 1) * a_dim1] = temp; + } + } + + k += kstep; + goto L30; +L40: + + ; + } else { + +/* Compute inv(A) from the factorization A = L*D*L**T. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = *n; +L50: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L60; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Invert the diagonal block. */ + + a[k + k * a_dim1] = 1. / a[k + k * a_dim1]; + +/* Compute column K of the inverse. */ + + if (k < *n) { + i__1 = *n - k; + dcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1); + i__1 = *n - k; + dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda, + &work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], & + c__1); + i__1 = *n - k; + a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k + 1 + + k * a_dim1], &c__1); + } + kstep = 1; + } else { + +/* 2 x 2 diagonal block */ + +/* Invert the diagonal block. */ + + t = (d__1 = a[k + (k - 1) * a_dim1], abs(d__1)); + ak = a[k - 1 + (k - 1) * a_dim1] / t; + akp1 = a[k + k * a_dim1] / t; + akkp1 = a[k + (k - 1) * a_dim1] / t; + d__ = t * (ak * akp1 - 1.); + a[k - 1 + (k - 1) * a_dim1] = akp1 / d__; + a[k + k * a_dim1] = ak / d__; + a[k + (k - 1) * a_dim1] = -akkp1 / d__; + +/* Compute columns K-1 and K of the inverse. */ + + if (k < *n) { + i__1 = *n - k; + dcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1); + i__1 = *n - k; + dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda, + &work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], & + c__1); + i__1 = *n - k; + a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k + 1 + + k * a_dim1], &c__1); + i__1 = *n - k; + a[k + (k - 1) * a_dim1] -= ddot_(&i__1, &a[k + 1 + k * a_dim1] + , &c__1, &a[k + 1 + (k - 1) * a_dim1], &c__1); + i__1 = *n - k; + dcopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], & + c__1); + i__1 = *n - k; + dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda, + &work[1], &c__1, &c_b13, &a[k + 1 + (k - 1) * a_dim1] + , &c__1); + i__1 = *n - k; + a[k - 1 + (k - 1) * a_dim1] -= ddot_(&i__1, &work[1], &c__1, & + a[k + 1 + (k - 1) * a_dim1], &c__1); + } + kstep = 2; + } + + kp = (i__1 = ipiv[k], abs(i__1)); + if (kp != k) { + +/* Interchange rows and columns K and KP in the trailing */ +/* submatrix A(k-1:n,k-1:n) */ + + if (kp < *n) { + i__1 = *n - kp; + dswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + kp * + a_dim1], &c__1); + } + i__1 = kp - k - 1; + dswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) * + a_dim1], lda); + temp = a[k + k * a_dim1]; + a[k + k * a_dim1] = a[kp + kp * a_dim1]; + a[kp + kp * a_dim1] = temp; + if (kstep == 2) { + temp = a[k + (k - 1) * a_dim1]; + a[k + (k - 1) * a_dim1] = a[kp + (k - 1) * a_dim1]; + a[kp + (k - 1) * a_dim1] = temp; + } + } + + k -= kstep; + goto L50; +L60: + ; + } + + return 0; + +/* End of DSYTRI */ + +} /* dsytri_ */ + diff --git a/lapack-netlib/SRC/dsytri2.c b/lapack-netlib/SRC/dsytri2.c new file mode 100644 index 000000000..8bfca8d3e --- /dev/null +++ b/lapack-netlib/SRC/dsytri2.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 DSYTRI2 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTRI2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LWORK, N */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYTRI2 computes the inverse of a DOUBLE PRECISION symmetric indefinite matrix */ +/* > A using the factorization A = U*D*U**T or A = L*D*L**T computed by */ +/* > DSYTRF. DSYTRI2 sets the LEADING DIMENSION of the workspace */ +/* > before calling DSYTRI2X that actually computes the inverse. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U*D*U**T; */ +/* > = 'L': Lower triangular, form is A = L*D*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the block diagonal matrix D and the multipliers */ +/* > used to obtain the factor U or L as computed by DSYTRF. */ +/* > */ +/* > On exit, if INFO = 0, the (symmetric) inverse of the original */ +/* > matrix. If UPLO = 'U', the upper triangular part of the */ +/* > inverse is formed and the part of A below the diagonal is not */ +/* > referenced; if UPLO = 'L' the lower triangular part of the */ +/* > inverse is formed and the part of A above the diagonal is */ +/* > not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (N+NB+1)*(NB+3) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > WORK is size >= (N+NB+1)*(NB+3) */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > calculates: */ +/* > - the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, */ +/* > - and no error message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */ +/* > inverse could not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup doubleSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dsytri2_(char *uplo, integer *n, doublereal *a, integer * + lda, integer *ipiv, doublereal *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + + /* Local variables */ + extern /* Subroutine */ int dsytri2x_(char *, integer *, doublereal *, + integer *, integer *, doublereal *, integer *, integer *); + extern logical lsame_(char *, char *); + integer nbmax; + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dsytri_(char *, integer *, doublereal *, + integer *, integer *, doublereal *, integer *); + logical lquery; + integer minsize; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + lquery = *lwork == -1; +/* Get blocksize */ + nbmax = ilaenv_(&c__1, "DSYTRI2", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)7, + (ftnlen)1); + if (nbmax >= *n) { + minsize = *n; + } else { + minsize = (*n + nbmax + 1) * (nbmax + 3); + } + + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*lwork < minsize && ! lquery) { + *info = -7; + } + +/* Quick return if possible */ + + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRI2", &i__1, (ftnlen)7); + return 0; + } else if (lquery) { + work[1] = (doublereal) minsize; + return 0; + } + if (*n == 0) { + return 0; + } + if (nbmax >= *n) { + dsytri_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], info); + } else { + dsytri2x_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], &nbmax, + info); + } + return 0; + +/* End of DSYTRI2 */ + +} /* dsytri2_ */ + diff --git a/lapack-netlib/SRC/dsytri2x.c b/lapack-netlib/SRC/dsytri2x.c new file mode 100644 index 000000000..e66b60cdd --- /dev/null +++ b/lapack-netlib/SRC/dsytri2x.c @@ -0,0 +1,1094 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYTRI2X */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTRI2X + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N, NB */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), WORK( N+NB+1,* ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYTRI2X computes the inverse of a real symmetric indefinite matrix */ +/* > A using the factorization A = U*D*U**T or A = L*D*L**T computed by */ +/* > DSYTRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U*D*U**T; */ +/* > = 'L': Lower triangular, form is A = L*D*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the NNB diagonal matrix D and the multipliers */ +/* > used to obtain the factor U or L as computed by DSYTRF. */ +/* > */ +/* > On exit, if INFO = 0, the (symmetric) inverse of the original */ +/* > matrix. If UPLO = 'U', the upper triangular part of the */ +/* > inverse is formed and the part of A below the diagonal is not */ +/* > referenced; if UPLO = 'L' the lower triangular part of the */ +/* > inverse is formed and the part of A above the diagonal is */ +/* > not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the NNB structure of D */ +/* > as determined by DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (N+NB+1,NB+3) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > Block size */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */ +/* > inverse could not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup doubleSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dsytri2x_(char *uplo, integer *n, doublereal *a, integer + *lda, integer *ipiv, doublereal *work, integer *nb, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, work_dim1, work_offset, i__1, i__2, i__3; + + /* Local variables */ + integer invd; + doublereal akkp1; + extern /* Subroutine */ int dsyswapr_(char *, integer *, doublereal *, + integer *, integer *, integer *); + doublereal d__; + integer i__, j, k; + doublereal t; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + extern logical lsame_(char *, char *); + integer iinfo; + extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + integer count; + logical upper; + doublereal ak, u01_i_j__; + integer u11; + doublereal u11_i_j__; + integer ip; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dtrtri_( + char *, char *, integer *, doublereal *, integer *, integer *); + integer nnb, cut; + doublereal akp1; + extern /* Subroutine */ int dsyconv_(char *, char *, integer *, + doublereal *, integer *, integer *, doublereal *, integer *); + doublereal u01_ip1_j__, u11_ip1_j__; + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + work_dim1 = *n + *nb + 1; + work_offset = 1 + work_dim1 * 1; + work -= work_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; + } + +/* Quick return if possible */ + + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRI2X", &i__1, (ftnlen)8); + return 0; + } + if (*n == 0) { + return 0; + } + +/* Convert A */ +/* Workspace got Non-diag elements of D */ + + dsyconv_(uplo, "C", n, &a[a_offset], lda, &ipiv[1], &work[work_offset], & + iinfo); + +/* Check that the diagonal matrix D is nonsingular. */ + + if (upper) { + +/* Upper triangular storage: examine D from bottom to top */ + + for (*info = *n; *info >= 1; --(*info)) { + if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.) { + return 0; + } + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.) { + return 0; + } + } + } + *info = 0; + +/* Splitting Workspace */ +/* U01 is a block (N,NB+1) */ +/* The first element of U01 is in WORK(1,1) */ +/* U11 is a block (NB+1,NB+1) */ +/* The first element of U11 is in WORK(N+1,1) */ + u11 = *n; +/* INVD is a block (N,2) */ +/* The first element of INVD is in WORK(1,INVD) */ + invd = *nb + 2; + if (upper) { + +/* invA = P * inv(U**T)*inv(D)*inv(U)*P**T. */ + + dtrtri_(uplo, "U", n, &a[a_offset], lda, info); + +/* inv(D) and inv(D)*inv(U) */ + + k = 1; + while(k <= *n) { + if (ipiv[k] > 0) { +/* 1 x 1 diagonal NNB */ + work[k + invd * work_dim1] = 1. / a[k + k * a_dim1]; + work[k + (invd + 1) * work_dim1] = 0.; + ++k; + } else { +/* 2 x 2 diagonal NNB */ + t = work[k + 1 + work_dim1]; + ak = a[k + k * a_dim1] / t; + akp1 = a[k + 1 + (k + 1) * a_dim1] / t; + akkp1 = work[k + 1 + work_dim1] / t; + d__ = t * (ak * akp1 - 1.); + work[k + invd * work_dim1] = akp1 / d__; + work[k + 1 + (invd + 1) * work_dim1] = ak / d__; + work[k + (invd + 1) * work_dim1] = -akkp1 / d__; + work[k + 1 + invd * work_dim1] = -akkp1 / d__; + k += 2; + } + } + +/* inv(U**T) = (inv(U))**T */ + +/* inv(U**T)*inv(D)*inv(U) */ + + cut = *n; + while(cut > 0) { + nnb = *nb; + if (cut <= nnb) { + nnb = cut; + } else { + count = 0; +/* count negative elements, */ + i__1 = cut; + for (i__ = cut + 1 - nnb; i__ <= i__1; ++i__) { + if (ipiv[i__] < 0) { + ++count; + } + } +/* need a even number for a clear cut */ + if (count % 2 == 1) { + ++nnb; + } + } + cut -= nnb; + +/* U01 Block */ + + i__1 = cut; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = 1; j <= i__2; ++j) { + work[i__ + j * work_dim1] = a[i__ + (cut + j) * a_dim1]; + } + } + +/* U11 Block */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + work[u11 + i__ + i__ * work_dim1] = 1.; + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + work[u11 + i__ + j * work_dim1] = 0.; + } + i__2 = nnb; + for (j = i__ + 1; j <= i__2; ++j) { + work[u11 + i__ + j * work_dim1] = a[cut + i__ + (cut + j) + * a_dim1]; + } + } + +/* invD*U01 */ + + i__ = 1; + while(i__ <= cut) { + if (ipiv[i__] > 0) { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + work[i__ + j * work_dim1] = work[i__ + invd * + work_dim1] * work[i__ + j * work_dim1]; + } + ++i__; + } else { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + u01_i_j__ = work[i__ + j * work_dim1]; + u01_ip1_j__ = work[i__ + 1 + j * work_dim1]; + work[i__ + j * work_dim1] = work[i__ + invd * + work_dim1] * u01_i_j__ + work[i__ + (invd + 1) + * work_dim1] * u01_ip1_j__; + work[i__ + 1 + j * work_dim1] = work[i__ + 1 + invd * + work_dim1] * u01_i_j__ + work[i__ + 1 + (invd + + 1) * work_dim1] * u01_ip1_j__; + } + i__ += 2; + } + } + +/* invD1*U11 */ + + i__ = 1; + while(i__ <= nnb) { + if (ipiv[cut + i__] > 0) { + i__1 = nnb; + for (j = i__; j <= i__1; ++j) { + work[u11 + i__ + j * work_dim1] = work[cut + i__ + + invd * work_dim1] * work[u11 + i__ + j * + work_dim1]; + } + ++i__; + } else { + i__1 = nnb; + for (j = i__; j <= i__1; ++j) { + u11_i_j__ = work[u11 + i__ + j * work_dim1]; + u11_ip1_j__ = work[u11 + i__ + 1 + j * work_dim1]; + work[u11 + i__ + j * work_dim1] = work[cut + i__ + + invd * work_dim1] * work[u11 + i__ + j * + work_dim1] + work[cut + i__ + (invd + 1) * + work_dim1] * work[u11 + i__ + 1 + j * + work_dim1]; + work[u11 + i__ + 1 + j * work_dim1] = work[cut + i__ + + 1 + invd * work_dim1] * u11_i_j__ + work[ + cut + i__ + 1 + (invd + 1) * work_dim1] * + u11_ip1_j__; + } + i__ += 2; + } + } + +/* U11**T*invD1*U11->U11 */ + + i__1 = *n + *nb + 1; + dtrmm_("L", "U", "T", "U", &nnb, &nnb, &c_b11, &a[cut + 1 + (cut + + 1) * a_dim1], lda, &work[u11 + 1 + work_dim1], &i__1); + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = i__; j <= i__2; ++j) { + a[cut + i__ + (cut + j) * a_dim1] = work[u11 + i__ + j * + work_dim1]; + } + } + +/* U01**T*invD*U01->A(CUT+I,CUT+J) */ + + i__1 = *n + *nb + 1; + i__2 = *n + *nb + 1; + dgemm_("T", "N", &nnb, &nnb, &cut, &c_b11, &a[(cut + 1) * a_dim1 + + 1], lda, &work[work_offset], &i__1, &c_b15, &work[u11 + + 1 + work_dim1], &i__2); + +/* U11 = U11**T*invD1*U11 + U01**T*invD*U01 */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = i__; j <= i__2; ++j) { + a[cut + i__ + (cut + j) * a_dim1] += work[u11 + i__ + j * + work_dim1]; + } + } + +/* U01 = U00**T*invD0*U01 */ + + i__1 = *n + *nb + 1; + dtrmm_("L", uplo, "T", "U", &cut, &nnb, &c_b11, &a[a_offset], lda, + &work[work_offset], &i__1); + +/* Update U01 */ + + i__1 = cut; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = 1; j <= i__2; ++j) { + a[i__ + (cut + j) * a_dim1] = work[i__ + j * work_dim1]; + } + } + +/* Next Block */ + + } + +/* Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T */ + + i__ = 1; + while(i__ <= *n) { + if (ipiv[i__] > 0) { + ip = ipiv[i__]; + if (i__ < ip) { + dsyswapr_(uplo, n, &a[a_offset], lda, &i__, &ip); + } + if (i__ > ip) { + dsyswapr_(uplo, n, &a[a_offset], lda, &ip, &i__); + } + } else { + ip = -ipiv[i__]; + ++i__; + if (i__ - 1 < ip) { + i__1 = i__ - 1; + dsyswapr_(uplo, n, &a[a_offset], lda, &i__1, &ip); + } + if (i__ - 1 > ip) { + i__1 = i__ - 1; + dsyswapr_(uplo, n, &a[a_offset], lda, &ip, &i__1); + } + } + ++i__; + } + } else { + +/* LOWER... */ + +/* invA = P * inv(U**T)*inv(D)*inv(U)*P**T. */ + + dtrtri_(uplo, "U", n, &a[a_offset], lda, info); + +/* inv(D) and inv(D)*inv(U) */ + + k = *n; + while(k >= 1) { + if (ipiv[k] > 0) { +/* 1 x 1 diagonal NNB */ + work[k + invd * work_dim1] = 1. / a[k + k * a_dim1]; + work[k + (invd + 1) * work_dim1] = 0.; + --k; + } else { +/* 2 x 2 diagonal NNB */ + t = work[k - 1 + work_dim1]; + ak = a[k - 1 + (k - 1) * a_dim1] / t; + akp1 = a[k + k * a_dim1] / t; + akkp1 = work[k - 1 + work_dim1] / t; + d__ = t * (ak * akp1 - 1.); + work[k - 1 + invd * work_dim1] = akp1 / d__; + work[k + invd * work_dim1] = ak / d__; + work[k + (invd + 1) * work_dim1] = -akkp1 / d__; + work[k - 1 + (invd + 1) * work_dim1] = -akkp1 / d__; + k += -2; + } + } + +/* inv(U**T) = (inv(U))**T */ + +/* inv(U**T)*inv(D)*inv(U) */ + + cut = 0; + while(cut < *n) { + nnb = *nb; + if (cut + nnb > *n) { + nnb = *n - cut; + } else { + count = 0; +/* count negative elements, */ + i__1 = cut + nnb; + for (i__ = cut + 1; i__ <= i__1; ++i__) { + if (ipiv[i__] < 0) { + ++count; + } + } +/* need a even number for a clear cut */ + if (count % 2 == 1) { + ++nnb; + } + } +/* L21 Block */ + i__1 = *n - cut - nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = 1; j <= i__2; ++j) { + work[i__ + j * work_dim1] = a[cut + nnb + i__ + (cut + j) + * a_dim1]; + } + } +/* L11 Block */ + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + work[u11 + i__ + i__ * work_dim1] = 1.; + i__2 = nnb; + for (j = i__ + 1; j <= i__2; ++j) { + work[u11 + i__ + j * work_dim1] = 0.; + } + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + work[u11 + i__ + j * work_dim1] = a[cut + i__ + (cut + j) + * a_dim1]; + } + } + +/* invD*L21 */ + + i__ = *n - cut - nnb; + while(i__ >= 1) { + if (ipiv[cut + nnb + i__] > 0) { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + work[i__ + j * work_dim1] = work[cut + nnb + i__ + + invd * work_dim1] * work[i__ + j * work_dim1]; + } + --i__; + } else { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + u01_i_j__ = work[i__ + j * work_dim1]; + u01_ip1_j__ = work[i__ - 1 + j * work_dim1]; + work[i__ + j * work_dim1] = work[cut + nnb + i__ + + invd * work_dim1] * u01_i_j__ + work[cut + + nnb + i__ + (invd + 1) * work_dim1] * + u01_ip1_j__; + work[i__ - 1 + j * work_dim1] = work[cut + nnb + i__ + - 1 + (invd + 1) * work_dim1] * u01_i_j__ + + work[cut + nnb + i__ - 1 + invd * work_dim1] * + u01_ip1_j__; + } + i__ += -2; + } + } + +/* invD1*L11 */ + + i__ = nnb; + while(i__ >= 1) { + if (ipiv[cut + i__] > 0) { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + work[u11 + i__ + j * work_dim1] = work[cut + i__ + + invd * work_dim1] * work[u11 + i__ + j * + work_dim1]; + } + --i__; + } else { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + u11_i_j__ = work[u11 + i__ + j * work_dim1]; + u11_ip1_j__ = work[u11 + i__ - 1 + j * work_dim1]; + work[u11 + i__ + j * work_dim1] = work[cut + i__ + + invd * work_dim1] * work[u11 + i__ + j * + work_dim1] + work[cut + i__ + (invd + 1) * + work_dim1] * u11_ip1_j__; + work[u11 + i__ - 1 + j * work_dim1] = work[cut + i__ + - 1 + (invd + 1) * work_dim1] * u11_i_j__ + + work[cut + i__ - 1 + invd * work_dim1] * + u11_ip1_j__; + } + i__ += -2; + } + } + +/* L11**T*invD1*L11->L11 */ + + i__1 = *n + *nb + 1; + dtrmm_("L", uplo, "T", "U", &nnb, &nnb, &c_b11, &a[cut + 1 + (cut + + 1) * a_dim1], lda, &work[u11 + 1 + work_dim1], &i__1); + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + a[cut + i__ + (cut + j) * a_dim1] = work[u11 + i__ + j * + work_dim1]; + } + } + + if (cut + nnb < *n) { + +/* L21**T*invD2*L21->A(CUT+I,CUT+J) */ + + i__1 = *n - nnb - cut; + i__2 = *n + *nb + 1; + i__3 = *n + *nb + 1; + dgemm_("T", "N", &nnb, &nnb, &i__1, &c_b11, &a[cut + nnb + 1 + + (cut + 1) * a_dim1], lda, &work[work_offset], &i__2, + &c_b15, &work[u11 + 1 + work_dim1], &i__3); + +/* L11 = L11**T*invD1*L11 + U01**T*invD*U01 */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + a[cut + i__ + (cut + j) * a_dim1] += work[u11 + i__ + + j * work_dim1]; + } + } + +/* L01 = L22**T*invD2*L21 */ + + i__1 = *n - nnb - cut; + i__2 = *n + *nb + 1; + dtrmm_("L", uplo, "T", "U", &i__1, &nnb, &c_b11, &a[cut + nnb + + 1 + (cut + nnb + 1) * a_dim1], lda, &work[ + work_offset], &i__2); + +/* Update L21 */ + + i__1 = *n - cut - nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = 1; j <= i__2; ++j) { + a[cut + nnb + i__ + (cut + j) * a_dim1] = work[i__ + + j * work_dim1]; + } + } + } else { + +/* L11 = L11**T*invD1*L11 */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + a[cut + i__ + (cut + j) * a_dim1] = work[u11 + i__ + + j * work_dim1]; + } + } + } + +/* Next Block */ + + cut += nnb; + } + +/* Apply PERMUTATIONS P and P**T: P * inv(U**T)*inv(D)*inv(U) *P**T */ + + i__ = *n; + while(i__ >= 1) { + if (ipiv[i__] > 0) { + ip = ipiv[i__]; + if (i__ < ip) { + dsyswapr_(uplo, n, &a[a_offset], lda, &i__, &ip); + } + if (i__ > ip) { + dsyswapr_(uplo, n, &a[a_offset], lda, &ip, &i__); + } + } else { + ip = -ipiv[i__]; + if (i__ < ip) { + dsyswapr_(uplo, n, &a[a_offset], lda, &i__, &ip); + } + if (i__ > ip) { + dsyswapr_(uplo, n, &a[a_offset], lda, &ip, &i__); + } + --i__; + } + --i__; + } + } + + return 0; + +/* End of DSYTRI2X */ + +} /* dsytri2x_ */ + diff --git a/lapack-netlib/SRC/dsytri_3.c b/lapack-netlib/SRC/dsytri_3.c new file mode 100644 index 000000000..b0af9ff74 --- /dev/null +++ b/lapack-netlib/SRC/dsytri_3.c @@ -0,0 +1,650 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYTRI_3 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTRI_3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, */ +/* INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LWORK, N */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), E( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > DSYTRI_3 computes the inverse of a real symmetric indefinite */ +/* > matrix A using the factorization computed by DSYTRF_RK or DSYTRF_BK: */ +/* > */ +/* > A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), */ +/* > */ +/* > where U (or L) is unit upper (or lower) triangular matrix, */ +/* > U**T (or L**T) is the transpose of U (or L), P is a permutation */ +/* > matrix, P**T is the transpose of P, and D is symmetric and block */ +/* > diagonal with 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > DSYTRI_3 sets the leading dimension of the workspace before calling */ +/* > DSYTRI_3X that actually computes the inverse. This is the blocked */ +/* > version of the algorithm, calling Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are */ +/* > stored as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, diagonal of the block diagonal matrix D and */ +/* > factors U or L as computed by DSYTRF_RK and DSYTRF_BK: */ +/* > a) ONLY diagonal elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > should be provided on entry in array E), and */ +/* > b) If UPLO = 'U': factor U in the superdiagonal part of A. */ +/* > If UPLO = 'L': factor L in the subdiagonal part of A. */ +/* > */ +/* > On exit, if INFO = 0, the symmetric inverse of the original */ +/* > matrix. */ +/* > If UPLO = 'U': the upper triangular part of the inverse */ +/* > is formed and the part of A below the diagonal is not */ +/* > referenced; */ +/* > If UPLO = 'L': the lower triangular part of the inverse */ +/* > is formed and the part of A above the diagonal is not */ +/* > referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, contains the superdiagonal (or subdiagonal) */ +/* > elements of the symmetric block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; */ +/* > If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. */ +/* > */ +/* > NOTE: For 1-by-1 diagonal block D(k), where */ +/* > 1 <= k <= N, the element E(k) is not referenced in both */ +/* > UPLO = 'U' or UPLO = 'L' cases. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by DSYTRF_RK or DSYTRF_BK. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (N+NB+1)*(NB+3). */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of WORK. LWORK >= (N+NB+1)*(NB+3). */ +/* > */ +/* > If LDWORK = -1, then a workspace query is assumed; */ +/* > the routine only calculates the optimal size of the optimal */ +/* > size of the WORK array, returns this value as the first */ +/* > entry of the WORK array, and no error message related to */ +/* > LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */ +/* > inverse could not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup doubleSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > \verbatim */ +/* > */ +/* > November 2017, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dsytri_3_(char *uplo, integer *n, doublereal *a, + integer *lda, doublereal *e, integer *ipiv, doublereal *work, integer + *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dsytri_3x_(char *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + integer *); + logical upper; + integer nb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer lwkopt; + logical lquery; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --e; + --ipiv; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + lquery = *lwork == -1; + +/* Determine the block size */ + +/* Computing MAX */ + i__1 = 1, i__2 = ilaenv_(&c__1, "DSYTRI_3", uplo, n, &c_n1, &c_n1, &c_n1, + (ftnlen)8, (ftnlen)1); + nb = f2cmax(i__1,i__2); + lwkopt = (*n + nb + 1) * (nb + 3); + + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*lwork < lwkopt && ! lquery) { + *info = -8; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRI_3", &i__1, (ftnlen)8); + return 0; + } else if (lquery) { + work[1] = (doublereal) lwkopt; + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + dsytri_3x_(uplo, n, &a[a_offset], lda, &e[1], &ipiv[1], &work[1], &nb, + info); + + work[1] = (doublereal) lwkopt; + + return 0; + +/* End of DSYTRI_3 */ + +} /* dsytri_3__ */ + diff --git a/lapack-netlib/SRC/dsytri_3x.c b/lapack-netlib/SRC/dsytri_3x.c new file mode 100644 index 000000000..1bca4e5e7 --- /dev/null +++ b/lapack-netlib/SRC/dsytri_3x.c @@ -0,0 +1,1143 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYTRI_3X */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTRI_3X + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N, NB */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), E( * ), WORK( N+NB+1, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > DSYTRI_3X computes the inverse of a real symmetric indefinite */ +/* > matrix A using the factorization computed by DSYTRF_RK or DSYTRF_BK: */ +/* > */ +/* > A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), */ +/* > */ +/* > where U (or L) is unit upper (or lower) triangular matrix, */ +/* > U**T (or L**T) is the transpose of U (or L), P is a permutation */ +/* > matrix, P**T is the transpose of P, and D is symmetric and block */ +/* > diagonal with 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > This is the blocked version of the algorithm, calling Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are */ +/* > stored as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, diagonal of the block diagonal matrix D and */ +/* > factors U or L as computed by DSYTRF_RK and DSYTRF_BK: */ +/* > a) ONLY diagonal elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > should be provided on entry in array E), and */ +/* > b) If UPLO = 'U': factor U in the superdiagonal part of A. */ +/* > If UPLO = 'L': factor L in the subdiagonal part of A. */ +/* > */ +/* > On exit, if INFO = 0, the symmetric inverse of the original */ +/* > matrix. */ +/* > If UPLO = 'U': the upper triangular part of the inverse */ +/* > is formed and the part of A below the diagonal is not */ +/* > referenced; */ +/* > If UPLO = 'L': the lower triangular part of the inverse */ +/* > is formed and the part of A above the diagonal is not */ +/* > referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, contains the superdiagonal (or subdiagonal) */ +/* > elements of the symmetric block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) not referenced; */ +/* > If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) not referenced. */ +/* > */ +/* > NOTE: For 1-by-1 diagonal block D(k), where */ +/* > 1 <= k <= N, the element E(k) is not referenced in both */ +/* > UPLO = 'U' or UPLO = 'L' cases. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by DSYTRF_RK or DSYTRF_BK. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (N+NB+1,NB+3). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > Block size. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */ +/* > inverse could not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup doubleSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > \verbatim */ +/* > */ +/* > June 2017, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dsytri_3x_(char *uplo, integer *n, doublereal *a, + integer *lda, doublereal *e, integer *ipiv, doublereal *work, integer + *nb, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, work_dim1, work_offset, i__1, i__2, i__3; + + /* Local variables */ + integer invd; + doublereal akkp1; + extern /* Subroutine */ int dsyswapr_(char *, integer *, doublereal *, + integer *, integer *, integer *); + doublereal d__; + integer i__, j, k; + doublereal t; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + logical upper; + doublereal ak, u01_i_j__; + integer u11; + doublereal u11_i_j__; + integer ip; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + integer icount; + extern /* Subroutine */ int dtrtri_(char *, char *, integer *, doublereal + *, integer *, integer *); + integer nnb, cut; + doublereal akp1, u01_ip1_j__, u11_ip1_j__; + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --e; + --ipiv; + work_dim1 = *n + *nb + 1; + work_offset = 1 + work_dim1 * 1; + work -= work_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; + } + +/* Quick return if possible */ + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRI_3X", &i__1, (ftnlen)9); + return 0; + } + if (*n == 0) { + return 0; + } + +/* Workspace got Non-diag elements of D */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + work[k + work_dim1] = e[k]; + } + +/* Check that the diagonal matrix D is nonsingular. */ + + if (upper) { + +/* Upper triangular storage: examine D from bottom to top */ + + for (*info = *n; *info >= 1; --(*info)) { + if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.) { + return 0; + } + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.) { + return 0; + } + } + } + + *info = 0; + +/* Splitting Workspace */ +/* U01 is a block ( N, NB+1 ) */ +/* The first element of U01 is in WORK( 1, 1 ) */ +/* U11 is a block ( NB+1, NB+1 ) */ +/* The first element of U11 is in WORK( N+1, 1 ) */ + + u11 = *n; + +/* INVD is a block ( N, 2 ) */ +/* The first element of INVD is in WORK( 1, INVD ) */ + + invd = *nb + 2; + if (upper) { + +/* Begin Upper */ + +/* invA = P * inv(U**T) * inv(D) * inv(U) * P**T. */ + + dtrtri_(uplo, "U", n, &a[a_offset], lda, info); + +/* inv(D) and inv(D) * inv(U) */ + + k = 1; + while(k <= *n) { + if (ipiv[k] > 0) { +/* 1 x 1 diagonal NNB */ + work[k + invd * work_dim1] = 1. / a[k + k * a_dim1]; + work[k + (invd + 1) * work_dim1] = 0.; + } else { +/* 2 x 2 diagonal NNB */ + t = work[k + 1 + work_dim1]; + ak = a[k + k * a_dim1] / t; + akp1 = a[k + 1 + (k + 1) * a_dim1] / t; + akkp1 = work[k + 1 + work_dim1] / t; + d__ = t * (ak * akp1 - 1.); + work[k + invd * work_dim1] = akp1 / d__; + work[k + 1 + (invd + 1) * work_dim1] = ak / d__; + work[k + (invd + 1) * work_dim1] = -akkp1 / d__; + work[k + 1 + invd * work_dim1] = work[k + (invd + 1) * + work_dim1]; + ++k; + } + ++k; + } + +/* inv(U**T) = (inv(U))**T */ + +/* inv(U**T) * inv(D) * inv(U) */ + + cut = *n; + while(cut > 0) { + nnb = *nb; + if (cut <= nnb) { + nnb = cut; + } else { + icount = 0; +/* count negative elements, */ + i__1 = cut; + for (i__ = cut + 1 - nnb; i__ <= i__1; ++i__) { + if (ipiv[i__] < 0) { + ++icount; + } + } +/* need a even number for a clear cut */ + if (icount % 2 == 1) { + ++nnb; + } + } + cut -= nnb; + +/* U01 Block */ + + i__1 = cut; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = 1; j <= i__2; ++j) { + work[i__ + j * work_dim1] = a[i__ + (cut + j) * a_dim1]; + } + } + +/* U11 Block */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + work[u11 + i__ + i__ * work_dim1] = 1.; + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + work[u11 + i__ + j * work_dim1] = 0.; + } + i__2 = nnb; + for (j = i__ + 1; j <= i__2; ++j) { + work[u11 + i__ + j * work_dim1] = a[cut + i__ + (cut + j) + * a_dim1]; + } + } + +/* invD * U01 */ + + i__ = 1; + while(i__ <= cut) { + if (ipiv[i__] > 0) { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + work[i__ + j * work_dim1] = work[i__ + invd * + work_dim1] * work[i__ + j * work_dim1]; + } + } else { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + u01_i_j__ = work[i__ + j * work_dim1]; + u01_ip1_j__ = work[i__ + 1 + j * work_dim1]; + work[i__ + j * work_dim1] = work[i__ + invd * + work_dim1] * u01_i_j__ + work[i__ + (invd + 1) + * work_dim1] * u01_ip1_j__; + work[i__ + 1 + j * work_dim1] = work[i__ + 1 + invd * + work_dim1] * u01_i_j__ + work[i__ + 1 + (invd + + 1) * work_dim1] * u01_ip1_j__; + } + ++i__; + } + ++i__; + } + +/* invD1 * U11 */ + + i__ = 1; + while(i__ <= nnb) { + if (ipiv[cut + i__] > 0) { + i__1 = nnb; + for (j = i__; j <= i__1; ++j) { + work[u11 + i__ + j * work_dim1] = work[cut + i__ + + invd * work_dim1] * work[u11 + i__ + j * + work_dim1]; + } + } else { + i__1 = nnb; + for (j = i__; j <= i__1; ++j) { + u11_i_j__ = work[u11 + i__ + j * work_dim1]; + u11_ip1_j__ = work[u11 + i__ + 1 + j * work_dim1]; + work[u11 + i__ + j * work_dim1] = work[cut + i__ + + invd * work_dim1] * work[u11 + i__ + j * + work_dim1] + work[cut + i__ + (invd + 1) * + work_dim1] * work[u11 + i__ + 1 + j * + work_dim1]; + work[u11 + i__ + 1 + j * work_dim1] = work[cut + i__ + + 1 + invd * work_dim1] * u11_i_j__ + work[ + cut + i__ + 1 + (invd + 1) * work_dim1] * + u11_ip1_j__; + } + ++i__; + } + ++i__; + } + +/* U11**T * invD1 * U11 -> U11 */ + + i__1 = *n + *nb + 1; + dtrmm_("L", "U", "T", "U", &nnb, &nnb, &c_b10, &a[cut + 1 + (cut + + 1) * a_dim1], lda, &work[u11 + 1 + work_dim1], &i__1); + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = i__; j <= i__2; ++j) { + a[cut + i__ + (cut + j) * a_dim1] = work[u11 + i__ + j * + work_dim1]; + } + } + +/* U01**T * invD * U01 -> A( CUT+I, CUT+J ) */ + + i__1 = *n + *nb + 1; + i__2 = *n + *nb + 1; + dgemm_("T", "N", &nnb, &nnb, &cut, &c_b10, &a[(cut + 1) * a_dim1 + + 1], lda, &work[work_offset], &i__1, &c_b14, &work[u11 + + 1 + work_dim1], &i__2); + +/* U11 = U11**T * invD1 * U11 + U01**T * invD * U01 */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = i__; j <= i__2; ++j) { + a[cut + i__ + (cut + j) * a_dim1] += work[u11 + i__ + j * + work_dim1]; + } + } + +/* U01 = U00**T * invD0 * U01 */ + + i__1 = *n + *nb + 1; + dtrmm_("L", uplo, "T", "U", &cut, &nnb, &c_b10, &a[a_offset], lda, + &work[work_offset], &i__1); + +/* Update U01 */ + + i__1 = cut; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = 1; j <= i__2; ++j) { + a[i__ + (cut + j) * a_dim1] = work[i__ + j * work_dim1]; + } + } + +/* Next Block */ + + } + +/* Apply PERMUTATIONS P and P**T: */ +/* P * inv(U**T) * inv(D) * inv(U) * P**T. */ +/* Interchange rows and columns I and IPIV(I) in reverse order */ +/* from the formation order of IPIV vector for Upper case. */ + +/* ( We can use a loop over IPIV with increment 1, */ +/* since the ABS value of IPIV(I) represents the row (column) */ +/* index of the interchange with row (column) i in both 1x1 */ +/* and 2x2 pivot cases, i.e. we don't need separate code branches */ +/* for 1x1 and 2x2 pivot cases ) */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ip = (i__2 = ipiv[i__], abs(i__2)); + if (ip != i__) { + if (i__ < ip) { + dsyswapr_(uplo, n, &a[a_offset], lda, &i__, &ip); + } + if (i__ > ip) { + dsyswapr_(uplo, n, &a[a_offset], lda, &ip, &i__); + } + } + } + + } else { + +/* Begin Lower */ + +/* inv A = P * inv(L**T) * inv(D) * inv(L) * P**T. */ + + dtrtri_(uplo, "U", n, &a[a_offset], lda, info); + +/* inv(D) and inv(D) * inv(L) */ + + k = *n; + while(k >= 1) { + if (ipiv[k] > 0) { +/* 1 x 1 diagonal NNB */ + work[k + invd * work_dim1] = 1. / a[k + k * a_dim1]; + work[k + (invd + 1) * work_dim1] = 0.; + } else { +/* 2 x 2 diagonal NNB */ + t = work[k - 1 + work_dim1]; + ak = a[k - 1 + (k - 1) * a_dim1] / t; + akp1 = a[k + k * a_dim1] / t; + akkp1 = work[k - 1 + work_dim1] / t; + d__ = t * (ak * akp1 - 1.); + work[k - 1 + invd * work_dim1] = akp1 / d__; + work[k + invd * work_dim1] = ak / d__; + work[k + (invd + 1) * work_dim1] = -akkp1 / d__; + work[k - 1 + (invd + 1) * work_dim1] = work[k + (invd + 1) * + work_dim1]; + --k; + } + --k; + } + +/* inv(L**T) = (inv(L))**T */ + +/* inv(L**T) * inv(D) * inv(L) */ + + cut = 0; + while(cut < *n) { + nnb = *nb; + if (cut + nnb > *n) { + nnb = *n - cut; + } else { + icount = 0; +/* count negative elements, */ + i__1 = cut + nnb; + for (i__ = cut + 1; i__ <= i__1; ++i__) { + if (ipiv[i__] < 0) { + ++icount; + } + } +/* need a even number for a clear cut */ + if (icount % 2 == 1) { + ++nnb; + } + } + +/* L21 Block */ + + i__1 = *n - cut - nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = 1; j <= i__2; ++j) { + work[i__ + j * work_dim1] = a[cut + nnb + i__ + (cut + j) + * a_dim1]; + } + } + +/* L11 Block */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + work[u11 + i__ + i__ * work_dim1] = 1.; + i__2 = nnb; + for (j = i__ + 1; j <= i__2; ++j) { + work[u11 + i__ + j * work_dim1] = 0.; + } + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + work[u11 + i__ + j * work_dim1] = a[cut + i__ + (cut + j) + * a_dim1]; + } + } + +/* invD*L21 */ + + i__ = *n - cut - nnb; + while(i__ >= 1) { + if (ipiv[cut + nnb + i__] > 0) { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + work[i__ + j * work_dim1] = work[cut + nnb + i__ + + invd * work_dim1] * work[i__ + j * work_dim1]; + } + } else { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + u01_i_j__ = work[i__ + j * work_dim1]; + u01_ip1_j__ = work[i__ - 1 + j * work_dim1]; + work[i__ + j * work_dim1] = work[cut + nnb + i__ + + invd * work_dim1] * u01_i_j__ + work[cut + + nnb + i__ + (invd + 1) * work_dim1] * + u01_ip1_j__; + work[i__ - 1 + j * work_dim1] = work[cut + nnb + i__ + - 1 + (invd + 1) * work_dim1] * u01_i_j__ + + work[cut + nnb + i__ - 1 + invd * work_dim1] * + u01_ip1_j__; + } + --i__; + } + --i__; + } + +/* invD1*L11 */ + + i__ = nnb; + while(i__ >= 1) { + if (ipiv[cut + i__] > 0) { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + work[u11 + i__ + j * work_dim1] = work[cut + i__ + + invd * work_dim1] * work[u11 + i__ + j * + work_dim1]; + } + } else { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + u11_i_j__ = work[u11 + i__ + j * work_dim1]; + u11_ip1_j__ = work[u11 + i__ - 1 + j * work_dim1]; + work[u11 + i__ + j * work_dim1] = work[cut + i__ + + invd * work_dim1] * work[u11 + i__ + j * + work_dim1] + work[cut + i__ + (invd + 1) * + work_dim1] * u11_ip1_j__; + work[u11 + i__ - 1 + j * work_dim1] = work[cut + i__ + - 1 + (invd + 1) * work_dim1] * u11_i_j__ + + work[cut + i__ - 1 + invd * work_dim1] * + u11_ip1_j__; + } + --i__; + } + --i__; + } + +/* L11**T * invD1 * L11 -> L11 */ + + i__1 = *n + *nb + 1; + dtrmm_("L", uplo, "T", "U", &nnb, &nnb, &c_b10, &a[cut + 1 + (cut + + 1) * a_dim1], lda, &work[u11 + 1 + work_dim1], &i__1); + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + a[cut + i__ + (cut + j) * a_dim1] = work[u11 + i__ + j * + work_dim1]; + } + } + + if (cut + nnb < *n) { + +/* L21**T * invD2*L21 -> A( CUT+I, CUT+J ) */ + + i__1 = *n - nnb - cut; + i__2 = *n + *nb + 1; + i__3 = *n + *nb + 1; + dgemm_("T", "N", &nnb, &nnb, &i__1, &c_b10, &a[cut + nnb + 1 + + (cut + 1) * a_dim1], lda, &work[work_offset], &i__2, + &c_b14, &work[u11 + 1 + work_dim1], &i__3); + +/* L11 = L11**T * invD1 * L11 + U01**T * invD * U01 */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + a[cut + i__ + (cut + j) * a_dim1] += work[u11 + i__ + + j * work_dim1]; + } + } + +/* L01 = L22**T * invD2 * L21 */ + + i__1 = *n - nnb - cut; + i__2 = *n + *nb + 1; + dtrmm_("L", uplo, "T", "U", &i__1, &nnb, &c_b10, &a[cut + nnb + + 1 + (cut + nnb + 1) * a_dim1], lda, &work[ + work_offset], &i__2); + +/* Update L21 */ + + i__1 = *n - cut - nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = 1; j <= i__2; ++j) { + a[cut + nnb + i__ + (cut + j) * a_dim1] = work[i__ + + j * work_dim1]; + } + } + + } else { + +/* L11 = L11**T * invD1 * L11 */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + a[cut + i__ + (cut + j) * a_dim1] = work[u11 + i__ + + j * work_dim1]; + } + } + } + +/* Next Block */ + + cut += nnb; + + } + +/* Apply PERMUTATIONS P and P**T: */ +/* P * inv(L**T) * inv(D) * inv(L) * P**T. */ +/* Interchange rows and columns I and IPIV(I) in reverse order */ +/* from the formation order of IPIV vector for Lower case. */ + +/* ( We can use a loop over IPIV with increment -1, */ +/* since the ABS value of IPIV(I) represents the row (column) */ +/* index of the interchange with row (column) i in both 1x1 */ +/* and 2x2 pivot cases, i.e. we don't need separate code branches */ +/* for 1x1 and 2x2 pivot cases ) */ + + for (i__ = *n; i__ >= 1; --i__) { + ip = (i__1 = ipiv[i__], abs(i__1)); + if (ip != i__) { + if (i__ < ip) { + dsyswapr_(uplo, n, &a[a_offset], lda, &i__, &ip); + } + if (i__ > ip) { + dsyswapr_(uplo, n, &a[a_offset], lda, &ip, &i__); + } + } + } + + } + + return 0; + +/* End of DSYTRI_3X */ + +} /* dsytri_3x__ */ + diff --git a/lapack-netlib/SRC/dsytri_rook.c b/lapack-netlib/SRC/dsytri_rook.c new file mode 100644 index 000000000..726b45a43 --- /dev/null +++ b/lapack-netlib/SRC/dsytri_rook.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 DSYTRI_ROOK */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTRI_ROOK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYTRI_ROOK computes the inverse of a real symmetric */ +/* > matrix A using the factorization A = U*D*U**T or A = L*D*L**T */ +/* > computed by DSYTRF_ROOK. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U*D*U**T; */ +/* > = 'L': Lower triangular, form is A = L*D*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the block diagonal matrix D and the multipliers */ +/* > used to obtain the factor U or L as computed by DSYTRF_ROOK. */ +/* > */ +/* > On exit, if INFO = 0, the (symmetric) inverse of the original */ +/* > matrix. If UPLO = 'U', the upper triangular part of the */ +/* > inverse is formed and the part of A below the diagonal is not */ +/* > referenced; if UPLO = 'L' the lower triangular part of the */ +/* > inverse is formed and the part of A above the diagonal is */ +/* > not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by DSYTRF_ROOK. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its */ +/* > inverse could not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup doubleSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > April 2012, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dsytri_rook_(char *uplo, integer *n, doublereal *a, + integer *lda, integer *ipiv, doublereal *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + doublereal d__1; + + /* Local variables */ + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + doublereal temp, akkp1, d__; + integer k; + doublereal t; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), dswap_(integer *, doublereal *, integer + *, doublereal *, integer *); + integer kstep; + logical upper; + extern /* Subroutine */ int dsymv_(char *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *); + doublereal ak; + integer kp; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal akp1; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRI_ROOK", &i__1, (ftnlen)11); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check that the diagonal matrix D is nonsingular. */ + + if (upper) { + +/* Upper triangular storage: examine D from bottom to top */ + + for (*info = *n; *info >= 1; --(*info)) { + if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.) { + return 0; + } +/* L10: */ + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (ipiv[*info] > 0 && a[*info + *info * a_dim1] == 0.) { + return 0; + } +/* L20: */ + } + } + *info = 0; + + if (upper) { + +/* Compute inv(A) from the factorization A = U*D*U**T. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = 1; +L30: + +/* If K > N, exit from loop. */ + + if (k > *n) { + goto L40; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Invert the diagonal block. */ + + a[k + k * a_dim1] = 1. / a[k + k * a_dim1]; + +/* Compute column K of the inverse. */ + + if (k > 1) { + i__1 = k - 1; + dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1); + i__1 = k - 1; + dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], & + c__1, &c_b13, &a[k * a_dim1 + 1], &c__1); + i__1 = k - 1; + a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k * + a_dim1 + 1], &c__1); + } + kstep = 1; + } else { + +/* 2 x 2 diagonal block */ + +/* Invert the diagonal block. */ + + t = (d__1 = a[k + (k + 1) * a_dim1], abs(d__1)); + ak = a[k + k * a_dim1] / t; + akp1 = a[k + 1 + (k + 1) * a_dim1] / t; + akkp1 = a[k + (k + 1) * a_dim1] / t; + d__ = t * (ak * akp1 - 1.); + a[k + k * a_dim1] = akp1 / d__; + a[k + 1 + (k + 1) * a_dim1] = ak / d__; + a[k + (k + 1) * a_dim1] = -akkp1 / d__; + +/* Compute columns K and K+1 of the inverse. */ + + if (k > 1) { + i__1 = k - 1; + dcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1); + i__1 = k - 1; + dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], & + c__1, &c_b13, &a[k * a_dim1 + 1], &c__1); + i__1 = k - 1; + a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k * + a_dim1 + 1], &c__1); + i__1 = k - 1; + a[k + (k + 1) * a_dim1] -= ddot_(&i__1, &a[k * a_dim1 + 1], & + c__1, &a[(k + 1) * a_dim1 + 1], &c__1); + i__1 = k - 1; + dcopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], & + c__1); + i__1 = k - 1; + dsymv_(uplo, &i__1, &c_b11, &a[a_offset], lda, &work[1], & + c__1, &c_b13, &a[(k + 1) * a_dim1 + 1], &c__1); + i__1 = k - 1; + a[k + 1 + (k + 1) * a_dim1] -= ddot_(&i__1, &work[1], &c__1, & + a[(k + 1) * a_dim1 + 1], &c__1); + } + kstep = 2; + } + + if (kstep == 1) { + +/* Interchange rows and columns K and IPIV(K) in the leading */ +/* submatrix A(1:k+1,1:k+1) */ + + kp = ipiv[k]; + if (kp != k) { + if (kp > 1) { + i__1 = kp - 1; + dswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + i__1 = k - kp - 1; + dswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1) + * a_dim1], lda); + temp = a[k + k * a_dim1]; + a[k + k * a_dim1] = a[kp + kp * a_dim1]; + a[kp + kp * a_dim1] = temp; + } + } else { + +/* Interchange rows and columns K and K+1 with -IPIV(K) and */ +/* -IPIV(K+1)in the leading submatrix A(1:k+1,1:k+1) */ + + kp = -ipiv[k]; + if (kp != k) { + if (kp > 1) { + i__1 = kp - 1; + dswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + i__1 = k - kp - 1; + dswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1) + * a_dim1], lda); + + temp = a[k + k * a_dim1]; + a[k + k * a_dim1] = a[kp + kp * a_dim1]; + a[kp + kp * a_dim1] = temp; + temp = a[k + (k + 1) * a_dim1]; + a[k + (k + 1) * a_dim1] = a[kp + (k + 1) * a_dim1]; + a[kp + (k + 1) * a_dim1] = temp; + } + + ++k; + kp = -ipiv[k]; + if (kp != k) { + if (kp > 1) { + i__1 = kp - 1; + dswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + i__1 = k - kp - 1; + dswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + (kp + 1) + * a_dim1], lda); + temp = a[k + k * a_dim1]; + a[k + k * a_dim1] = a[kp + kp * a_dim1]; + a[kp + kp * a_dim1] = temp; + } + } + + ++k; + goto L30; +L40: + + ; + } else { + +/* Compute inv(A) from the factorization A = L*D*L**T. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = *n; +L50: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L60; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Invert the diagonal block. */ + + a[k + k * a_dim1] = 1. / a[k + k * a_dim1]; + +/* Compute column K of the inverse. */ + + if (k < *n) { + i__1 = *n - k; + dcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1); + i__1 = *n - k; + dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda, + &work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], & + c__1); + i__1 = *n - k; + a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k + 1 + + k * a_dim1], &c__1); + } + kstep = 1; + } else { + +/* 2 x 2 diagonal block */ + +/* Invert the diagonal block. */ + + t = (d__1 = a[k + (k - 1) * a_dim1], abs(d__1)); + ak = a[k - 1 + (k - 1) * a_dim1] / t; + akp1 = a[k + k * a_dim1] / t; + akkp1 = a[k + (k - 1) * a_dim1] / t; + d__ = t * (ak * akp1 - 1.); + a[k - 1 + (k - 1) * a_dim1] = akp1 / d__; + a[k + k * a_dim1] = ak / d__; + a[k + (k - 1) * a_dim1] = -akkp1 / d__; + +/* Compute columns K-1 and K of the inverse. */ + + if (k < *n) { + i__1 = *n - k; + dcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1); + i__1 = *n - k; + dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda, + &work[1], &c__1, &c_b13, &a[k + 1 + k * a_dim1], & + c__1); + i__1 = *n - k; + a[k + k * a_dim1] -= ddot_(&i__1, &work[1], &c__1, &a[k + 1 + + k * a_dim1], &c__1); + i__1 = *n - k; + a[k + (k - 1) * a_dim1] -= ddot_(&i__1, &a[k + 1 + k * a_dim1] + , &c__1, &a[k + 1 + (k - 1) * a_dim1], &c__1); + i__1 = *n - k; + dcopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], & + c__1); + i__1 = *n - k; + dsymv_(uplo, &i__1, &c_b11, &a[k + 1 + (k + 1) * a_dim1], lda, + &work[1], &c__1, &c_b13, &a[k + 1 + (k - 1) * a_dim1] + , &c__1); + i__1 = *n - k; + a[k - 1 + (k - 1) * a_dim1] -= ddot_(&i__1, &work[1], &c__1, & + a[k + 1 + (k - 1) * a_dim1], &c__1); + } + kstep = 2; + } + + if (kstep == 1) { + +/* Interchange rows and columns K and IPIV(K) in the trailing */ +/* submatrix A(k-1:n,k-1:n) */ + + kp = ipiv[k]; + if (kp != k) { + if (kp < *n) { + i__1 = *n - kp; + dswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + i__1 = kp - k - 1; + dswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) * + a_dim1], lda); + temp = a[k + k * a_dim1]; + a[k + k * a_dim1] = a[kp + kp * a_dim1]; + a[kp + kp * a_dim1] = temp; + } + } else { + +/* Interchange rows and columns K and K-1 with -IPIV(K) and */ +/* -IPIV(K-1) in the trailing submatrix A(k-1:n,k-1:n) */ + + kp = -ipiv[k]; + if (kp != k) { + if (kp < *n) { + i__1 = *n - kp; + dswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + i__1 = kp - k - 1; + dswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) * + a_dim1], lda); + + temp = a[k + k * a_dim1]; + a[k + k * a_dim1] = a[kp + kp * a_dim1]; + a[kp + kp * a_dim1] = temp; + temp = a[k + (k - 1) * a_dim1]; + a[k + (k - 1) * a_dim1] = a[kp + (k - 1) * a_dim1]; + a[kp + (k - 1) * a_dim1] = temp; + } + + --k; + kp = -ipiv[k]; + if (kp != k) { + if (kp < *n) { + i__1 = *n - kp; + dswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + i__1 = kp - k - 1; + dswap_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &a[kp + (k + 1) * + a_dim1], lda); + temp = a[k + k * a_dim1]; + a[k + k * a_dim1] = a[kp + kp * a_dim1]; + a[kp + kp * a_dim1] = temp; + } + } + + --k; + goto L50; +L60: + ; + } + + return 0; + +/* End of DSYTRI_ROOK */ + +} /* dsytri_rook__ */ + diff --git a/lapack-netlib/SRC/dsytrs.c b/lapack-netlib/SRC/dsytrs.c new file mode 100644 index 000000000..1cb17e39a --- /dev/null +++ b/lapack-netlib/SRC/dsytrs.c @@ -0,0 +1,887 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYTRS solves a system of linear equations A*X = B with a real */ +/* > symmetric matrix A using the factorization A = U*D*U**T or */ +/* > A = L*D*L**T computed by DSYTRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U*D*U**T; */ +/* > = 'L': Lower triangular, form is A = L*D*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dsytrs_(char *uplo, integer *n, integer *nrhs, + doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer * + ldb, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + doublereal d__1; + + /* Local variables */ + extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *); + doublereal akm1k; + integer j, k; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + doublereal denom; + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *), dswap_(integer *, + doublereal *, integer *, doublereal *, integer *); + logical upper; + doublereal ak, bk; + integer kp; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal akm1, bkm1; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + + if (upper) { + +/* Solve A*X = B, where A = U*D*U**T. */ + +/* First solve U*D*X = B, overwriting B with X. */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = *n; +L10: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L30; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(U(K)), where U(K) is the transformation */ +/* stored in column K of A. */ + + i__1 = k - 1; + dger_(&i__1, nrhs, &c_b7, &a[k * a_dim1 + 1], &c__1, &b[k + + b_dim1], ldb, &b[b_dim1 + 1], ldb); + +/* Multiply by the inverse of the diagonal block. */ + + d__1 = 1. / a[k + k * a_dim1]; + dscal_(nrhs, &d__1, &b[k + b_dim1], ldb); + --k; + } else { + +/* 2 x 2 diagonal block */ + +/* Interchange rows K-1 and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k - 1) { + dswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(U(K)), where U(K) is the transformation */ +/* stored in columns K-1 and K of A. */ + + i__1 = k - 2; + dger_(&i__1, nrhs, &c_b7, &a[k * a_dim1 + 1], &c__1, &b[k + + b_dim1], ldb, &b[b_dim1 + 1], ldb); + i__1 = k - 2; + dger_(&i__1, nrhs, &c_b7, &a[(k - 1) * a_dim1 + 1], &c__1, &b[k - + 1 + b_dim1], ldb, &b[b_dim1 + 1], ldb); + +/* Multiply by the inverse of the diagonal block. */ + + akm1k = a[k - 1 + k * a_dim1]; + akm1 = a[k - 1 + (k - 1) * a_dim1] / akm1k; + ak = a[k + k * a_dim1] / akm1k; + denom = akm1 * ak - 1.; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + bkm1 = b[k - 1 + j * b_dim1] / akm1k; + bk = b[k + j * b_dim1] / akm1k; + b[k - 1 + j * b_dim1] = (ak * bkm1 - bk) / denom; + b[k + j * b_dim1] = (akm1 * bk - bkm1) / denom; +/* L20: */ + } + k += -2; + } + + goto L10; +L30: + +/* Next solve U**T *X = B, overwriting B with X. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = 1; +L40: + +/* If K > N, exit from loop. */ + + if (k > *n) { + goto L50; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Multiply by inv(U**T(K)), where U(K) is the transformation */ +/* stored in column K of A. */ + + i__1 = k - 1; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[k * + a_dim1 + 1], &c__1, &c_b19, &b[k + b_dim1], ldb); + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + ++k; + } else { + +/* 2 x 2 diagonal block */ + +/* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation */ +/* stored in columns K and K+1 of A. */ + + i__1 = k - 1; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[k * + a_dim1 + 1], &c__1, &c_b19, &b[k + b_dim1], ldb); + i__1 = k - 1; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[(k + + 1) * a_dim1 + 1], &c__1, &c_b19, &b[k + 1 + b_dim1], + ldb); + +/* Interchange rows K and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + k += 2; + } + + goto L40; +L50: + + ; + } else { + +/* Solve A*X = B, where A = L*D*L**T. */ + +/* First solve L*D*X = B, overwriting B with X. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = 1; +L60: + +/* If K > N, exit from loop. */ + + if (k > *n) { + goto L80; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(L(K)), where L(K) is the transformation */ +/* stored in column K of A. */ + + if (k < *n) { + i__1 = *n - k; + dger_(&i__1, nrhs, &c_b7, &a[k + 1 + k * a_dim1], &c__1, &b[k + + b_dim1], ldb, &b[k + 1 + b_dim1], ldb); + } + +/* Multiply by the inverse of the diagonal block. */ + + d__1 = 1. / a[k + k * a_dim1]; + dscal_(nrhs, &d__1, &b[k + b_dim1], ldb); + ++k; + } else { + +/* 2 x 2 diagonal block */ + +/* Interchange rows K+1 and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k + 1) { + dswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(L(K)), where L(K) is the transformation */ +/* stored in columns K and K+1 of A. */ + + if (k < *n - 1) { + i__1 = *n - k - 1; + dger_(&i__1, nrhs, &c_b7, &a[k + 2 + k * a_dim1], &c__1, &b[k + + b_dim1], ldb, &b[k + 2 + b_dim1], ldb); + i__1 = *n - k - 1; + dger_(&i__1, nrhs, &c_b7, &a[k + 2 + (k + 1) * a_dim1], &c__1, + &b[k + 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb); + } + +/* Multiply by the inverse of the diagonal block. */ + + akm1k = a[k + 1 + k * a_dim1]; + akm1 = a[k + k * a_dim1] / akm1k; + ak = a[k + 1 + (k + 1) * a_dim1] / akm1k; + denom = akm1 * ak - 1.; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + bkm1 = b[k + j * b_dim1] / akm1k; + bk = b[k + 1 + j * b_dim1] / akm1k; + b[k + j * b_dim1] = (ak * bkm1 - bk) / denom; + b[k + 1 + j * b_dim1] = (akm1 * bk - bkm1) / denom; +/* L70: */ + } + k += 2; + } + + goto L60; +L80: + +/* Next solve L**T *X = B, overwriting B with X. */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = *n; +L90: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L100; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Multiply by inv(L**T(K)), where L(K) is the transformation */ +/* stored in column K of A. */ + + if (k < *n) { + i__1 = *n - k; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], + ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b19, &b[k + + b_dim1], ldb); + } + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + --k; + } else { + +/* 2 x 2 diagonal block */ + +/* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation */ +/* stored in columns K-1 and K of A. */ + + if (k < *n) { + i__1 = *n - k; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], + ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b19, &b[k + + b_dim1], ldb); + i__1 = *n - k; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], + ldb, &a[k + 1 + (k - 1) * a_dim1], &c__1, &c_b19, &b[ + k - 1 + b_dim1], ldb); + } + +/* Interchange rows K and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + k += -2; + } + + goto L90; +L100: + ; + } + + return 0; + +/* End of DSYTRS */ + +} /* dsytrs_ */ + diff --git a/lapack-netlib/SRC/dsytrs2.c b/lapack-netlib/SRC/dsytrs2.c new file mode 100644 index 000000000..c4d4b8d32 --- /dev/null +++ b/lapack-netlib/SRC/dsytrs2.c @@ -0,0 +1,784 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYTRS2 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTRS2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, */ +/* WORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYTRS2 solves a system of linear equations A*X = B with a real */ +/* > symmetric matrix A using the factorization A = U*D*U**T or */ +/* > A = L*D*L**T computed by DSYTRF and converted by DSYCONV. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U*D*U**T; */ +/* > = 'L': Lower triangular, form is A = L*D*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by DSYTRF. */ +/* > Note that A is input / output. This might be counter-intuitive, */ +/* > and one may think that A is input only. A is input / output. This */ +/* > is because, at the start of the subroutine, we permute A in a */ +/* > "better" form and then we permute A back to its original form at */ +/* > the end. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by DSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup doubleSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dsytrs2_(char *uplo, integer *n, integer *nrhs, + doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer * + ldb, doublereal *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + doublereal d__1; + + /* Local variables */ + doublereal akm1k; + integer i__, j, k; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + doublereal denom; + integer iinfo; + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *), dtrsm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + logical upper; + doublereal ak, bk; + integer kp; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal akm1, bkm1; + extern /* Subroutine */ int dsyconv_(char *, char *, integer *, + doublereal *, integer *, integer *, doublereal *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRS2", &i__1, (ftnlen)7); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + +/* Convert A */ + + dsyconv_(uplo, "C", n, &a[a_offset], lda, &ipiv[1], &work[1], &iinfo); + + if (upper) { + +/* Solve A*X = B, where A = U*D*U**T. */ + +/* P**T * B */ + k = *n; + while(k >= 1) { + if (ipiv[k] > 0) { +/* 1 x 1 diagonal block */ +/* Interchange rows K and IPIV(K). */ + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + --k; + } else { +/* 2 x 2 diagonal block */ +/* Interchange rows K-1 and -IPIV(K). */ + kp = -ipiv[k]; + if (kp == -ipiv[k - 1]) { + dswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], + ldb); + } + k += -2; + } + } + +/* Compute (U \P**T * B) -> B [ (U \P**T * B) ] */ + + dtrsm_("L", "U", "N", "U", n, nrhs, &c_b10, &a[a_offset], lda, &b[ + b_offset], ldb); + +/* Compute D \ B -> B [ D \ (U \P**T * B) ] */ + + i__ = *n; + while(i__ >= 1) { + if (ipiv[i__] > 0) { + d__1 = 1. / a[i__ + i__ * a_dim1]; + dscal_(nrhs, &d__1, &b[i__ + b_dim1], ldb); + } else if (i__ > 1) { + if (ipiv[i__ - 1] == ipiv[i__]) { + akm1k = work[i__]; + akm1 = a[i__ - 1 + (i__ - 1) * a_dim1] / akm1k; + ak = a[i__ + i__ * a_dim1] / akm1k; + denom = akm1 * ak - 1.; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + bkm1 = b[i__ - 1 + j * b_dim1] / akm1k; + bk = b[i__ + j * b_dim1] / akm1k; + b[i__ - 1 + j * b_dim1] = (ak * bkm1 - bk) / denom; + b[i__ + j * b_dim1] = (akm1 * bk - bkm1) / denom; +/* L15: */ + } + --i__; + } + } + --i__; + } + +/* Compute (U**T \ B) -> B [ U**T \ (D \ (U \P**T * B) ) ] */ + + dtrsm_("L", "U", "T", "U", n, nrhs, &c_b10, &a[a_offset], lda, &b[ + b_offset], ldb); + +/* P * B [ P * (U**T \ (D \ (U \P**T * B) )) ] */ + + k = 1; + while(k <= *n) { + if (ipiv[k] > 0) { +/* 1 x 1 diagonal block */ +/* Interchange rows K and IPIV(K). */ + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + ++k; + } else { +/* 2 x 2 diagonal block */ +/* Interchange rows K-1 and -IPIV(K). */ + kp = -ipiv[k]; + if (k < *n && kp == -ipiv[k + 1]) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + k += 2; + } + } + + } else { + +/* Solve A*X = B, where A = L*D*L**T. */ + +/* P**T * B */ + k = 1; + while(k <= *n) { + if (ipiv[k] > 0) { +/* 1 x 1 diagonal block */ +/* Interchange rows K and IPIV(K). */ + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + ++k; + } else { +/* 2 x 2 diagonal block */ +/* Interchange rows K and -IPIV(K+1). */ + kp = -ipiv[k + 1]; + if (kp == -ipiv[k]) { + dswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], + ldb); + } + k += 2; + } + } + +/* Compute (L \P**T * B) -> B [ (L \P**T * B) ] */ + + dtrsm_("L", "L", "N", "U", n, nrhs, &c_b10, &a[a_offset], lda, &b[ + b_offset], ldb); + +/* Compute D \ B -> B [ D \ (L \P**T * B) ] */ + + i__ = 1; + while(i__ <= *n) { + if (ipiv[i__] > 0) { + d__1 = 1. / a[i__ + i__ * a_dim1]; + dscal_(nrhs, &d__1, &b[i__ + b_dim1], ldb); + } else { + akm1k = work[i__]; + akm1 = a[i__ + i__ * a_dim1] / akm1k; + ak = a[i__ + 1 + (i__ + 1) * a_dim1] / akm1k; + denom = akm1 * ak - 1.; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + bkm1 = b[i__ + j * b_dim1] / akm1k; + bk = b[i__ + 1 + j * b_dim1] / akm1k; + b[i__ + j * b_dim1] = (ak * bkm1 - bk) / denom; + b[i__ + 1 + j * b_dim1] = (akm1 * bk - bkm1) / denom; +/* L25: */ + } + ++i__; + } + ++i__; + } + +/* Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ] */ + + dtrsm_("L", "L", "T", "U", n, nrhs, &c_b10, &a[a_offset], lda, &b[ + b_offset], ldb); + +/* P * B [ P * (L**T \ (D \ (L \P**T * B) )) ] */ + + k = *n; + while(k >= 1) { + if (ipiv[k] > 0) { +/* 1 x 1 diagonal block */ +/* Interchange rows K and IPIV(K). */ + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + --k; + } else { +/* 2 x 2 diagonal block */ +/* Interchange rows K-1 and -IPIV(K). */ + kp = -ipiv[k]; + if (k > 1 && kp == -ipiv[k - 1]) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + k += -2; + } + } + + } + +/* Revert A */ + + dsyconv_(uplo, "R", n, &a[a_offset], lda, &ipiv[1], &work[1], &iinfo); + + return 0; + +/* End of DSYTRS2 */ + +} /* dsytrs2_ */ + diff --git a/lapack-netlib/SRC/dsytrs_3.c b/lapack-netlib/SRC/dsytrs_3.c new file mode 100644 index 000000000..139917377 --- /dev/null +++ b/lapack-netlib/SRC/dsytrs_3.c @@ -0,0 +1,781 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYTRS_3 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTRS_3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, */ +/* INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > DSYTRS_3 solves a system of linear equations A * X = B with a real */ +/* > symmetric matrix A using the factorization computed */ +/* > by DSYTRF_RK or DSYTRF_BK: */ +/* > */ +/* > A = P*U*D*(U**T)*(P**T) or A = P*L*D*(L**T)*(P**T), */ +/* > */ +/* > where U (or L) is unit upper (or lower) triangular matrix, */ +/* > U**T (or L**T) is the transpose of U (or L), P is a permutation */ +/* > matrix, P**T is the transpose of P, and D is symmetric and block */ +/* > diagonal with 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > This algorithm is using Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are */ +/* > stored as an upper or lower triangular matrix: */ +/* > = 'U': Upper triangular, form is A = P*U*D*(U**T)*(P**T); */ +/* > = 'L': Lower triangular, form is A = P*L*D*(L**T)*(P**T). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > Diagonal of the block diagonal matrix D and factors U or L */ +/* > as computed by DSYTRF_RK and DSYTRF_BK: */ +/* > a) ONLY diagonal elements of the symmetric block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > should be provided on entry in array E), and */ +/* > b) If UPLO = 'U': factor U in the superdiagonal part of A. */ +/* > If UPLO = 'L': factor L in the subdiagonal part of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, contains the superdiagonal (or subdiagonal) */ +/* > elements of the symmetric block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) not referenced; */ +/* > If UPLO = 'L': E(i) = D(i+1,i),i=1:N-1, E(N) not referenced. */ +/* > */ +/* > NOTE: For 1-by-1 diagonal block D(k), where */ +/* > 1 <= k <= N, the element E(k) is not referenced in both */ +/* > UPLO = 'U' or UPLO = 'L' cases. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by DSYTRF_RK or DSYTRF_BK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup doubleSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > June 2017, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dsytrs_3_(char *uplo, integer *n, integer *nrhs, + doublereal *a, integer *lda, doublereal *e, integer *ipiv, doublereal + *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + doublereal akm1k; + integer i__, j, k; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + doublereal denom; + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *), dtrsm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + logical upper; + doublereal ak, bk; + integer kp; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal akm1, bkm1; + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --e; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRS_3", &i__1, (ftnlen)8); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + + if (upper) { + +/* Begin Upper */ + +/* Solve A*X = B, where A = U*D*U**T. */ + +/* P**T * B */ + +/* Interchange rows K and IPIV(K) of matrix B in the same order */ +/* that the formation order of IPIV(I) vector for Upper case. */ + +/* (We can do the simple loop over IPIV with decrement -1, */ +/* since the ABS value of IPIV( I ) represents the row index */ +/* of the interchange with row i in both 1x1 and 2x2 pivot cases) */ + + for (k = *n; k >= 1; --k) { + kp = (i__1 = ipiv[k], abs(i__1)); + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + +/* Compute (U \P**T * B) -> B [ (U \P**T * B) ] */ + + dtrsm_("L", "U", "N", "U", n, nrhs, &c_b9, &a[a_offset], lda, &b[ + b_offset], ldb); + +/* Compute D \ B -> B [ D \ (U \P**T * B) ] */ + + i__ = *n; + while(i__ >= 1) { + if (ipiv[i__] > 0) { + d__1 = 1. / a[i__ + i__ * a_dim1]; + dscal_(nrhs, &d__1, &b[i__ + b_dim1], ldb); + } else if (i__ > 1) { + akm1k = e[i__]; + akm1 = a[i__ - 1 + (i__ - 1) * a_dim1] / akm1k; + ak = a[i__ + i__ * a_dim1] / akm1k; + denom = akm1 * ak - 1.; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + bkm1 = b[i__ - 1 + j * b_dim1] / akm1k; + bk = b[i__ + j * b_dim1] / akm1k; + b[i__ - 1 + j * b_dim1] = (ak * bkm1 - bk) / denom; + b[i__ + j * b_dim1] = (akm1 * bk - bkm1) / denom; + } + --i__; + } + --i__; + } + +/* Compute (U**T \ B) -> B [ U**T \ (D \ (U \P**T * B) ) ] */ + + dtrsm_("L", "U", "T", "U", n, nrhs, &c_b9, &a[a_offset], lda, &b[ + b_offset], ldb); + +/* P * B [ P * (U**T \ (D \ (U \P**T * B) )) ] */ + +/* Interchange rows K and IPIV(K) of matrix B in reverse order */ +/* from the formation order of IPIV(I) vector for Upper case. */ + +/* (We can do the simple loop over IPIV with increment 1, */ +/* since the ABS value of IPIV(I) represents the row index */ +/* of the interchange with row i in both 1x1 and 2x2 pivot cases) */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + kp = (i__2 = ipiv[k], abs(i__2)); + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + + } else { + +/* Begin Lower */ + +/* Solve A*X = B, where A = L*D*L**T. */ + +/* P**T * B */ +/* Interchange rows K and IPIV(K) of matrix B in the same order */ +/* that the formation order of IPIV(I) vector for Lower case. */ + +/* (We can do the simple loop over IPIV with increment 1, */ +/* since the ABS value of IPIV(I) represents the row index */ +/* of the interchange with row i in both 1x1 and 2x2 pivot cases) */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + kp = (i__2 = ipiv[k], abs(i__2)); + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + +/* Compute (L \P**T * B) -> B [ (L \P**T * B) ] */ + + dtrsm_("L", "L", "N", "U", n, nrhs, &c_b9, &a[a_offset], lda, &b[ + b_offset], ldb); + +/* Compute D \ B -> B [ D \ (L \P**T * B) ] */ + + i__ = 1; + while(i__ <= *n) { + if (ipiv[i__] > 0) { + d__1 = 1. / a[i__ + i__ * a_dim1]; + dscal_(nrhs, &d__1, &b[i__ + b_dim1], ldb); + } else if (i__ < *n) { + akm1k = e[i__]; + akm1 = a[i__ + i__ * a_dim1] / akm1k; + ak = a[i__ + 1 + (i__ + 1) * a_dim1] / akm1k; + denom = akm1 * ak - 1.; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + bkm1 = b[i__ + j * b_dim1] / akm1k; + bk = b[i__ + 1 + j * b_dim1] / akm1k; + b[i__ + j * b_dim1] = (ak * bkm1 - bk) / denom; + b[i__ + 1 + j * b_dim1] = (akm1 * bk - bkm1) / denom; + } + ++i__; + } + ++i__; + } + +/* Compute (L**T \ B) -> B [ L**T \ (D \ (L \P**T * B) ) ] */ + + dtrsm_("L", "L", "T", "U", n, nrhs, &c_b9, &a[a_offset], lda, &b[ + b_offset], ldb); + +/* P * B [ P * (L**T \ (D \ (L \P**T * B) )) ] */ + +/* Interchange rows K and IPIV(K) of matrix B in reverse order */ +/* from the formation order of IPIV(I) vector for Lower case. */ + +/* (We can do the simple loop over IPIV with decrement -1, */ +/* since the ABS value of IPIV(I) represents the row index */ +/* of the interchange with row i in both 1x1 and 2x2 pivot cases) */ + + for (k = *n; k >= 1; --k) { + kp = (i__1 = ipiv[k], abs(i__1)); + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + +/* END Lower */ + + } + + return 0; + +/* End of DSYTRS_3 */ + +} /* dsytrs_3__ */ + diff --git a/lapack-netlib/SRC/dsytrs_aa.c b/lapack-netlib/SRC/dsytrs_aa.c new file mode 100644 index 000000000..3d0a17bbd --- /dev/null +++ b/lapack-netlib/SRC/dsytrs_aa.c @@ -0,0 +1,738 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYTRS_AA */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTRS_AA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, */ +/* WORK, LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER N, NRHS, LDA, LDB, LWORK, INFO */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYTRS_AA solves a system of linear equations A*X = B with a real */ +/* > symmetric matrix A using the factorization A = U**T*T*U or */ +/* > A = L*T*L**T computed by DSYTRF_AA. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U**T*T*U; */ +/* > = 'L': Lower triangular, form is A = L*T*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > Details of factors computed by DSYTRF_AA. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges as computed by DSYTRF_AA. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,3*N-2). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup doubleSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dsytrs_aa_(char *uplo, integer *n, integer *nrhs, + doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer * + ldb, doublereal *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + + /* Local variables */ + integer k; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *, + doublereal *, integer *), dgtsv_(integer *, integer *, doublereal + *, doublereal *, doublereal *, doublereal *, integer *, integer *) + , dtrsm_(char *, char *, char *, char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *); + logical upper; + integer kp; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen); + integer lwkopt; + logical lquery; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + lquery = *lwork == -1; + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *n * 3 - 2; + if (*lwork < f2cmax(i__1,i__2) && ! lquery) { + *info = -10; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRS_AA", &i__1, (ftnlen)9); + return 0; + } else if (lquery) { + lwkopt = *n * 3 - 2; + work[1] = (doublereal) lwkopt; + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + + if (upper) { + +/* Solve A*X = B, where A = U**T*T*U. */ + +/* 1) Forward substitution with U**T */ + + if (*n > 1) { + +/* Pivot, P**T * B -> B */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + +/* Compute U**T \ B -> B [ (U**T \P**T * B) ] */ + + i__1 = *n - 1; + dtrsm_("L", "U", "T", "U", &i__1, nrhs, &c_b9, &a[(a_dim1 << 1) + + 1], lda, &b[b_dim1 + 2], ldb); + } + +/* 2) Solve with triangular matrix T */ + +/* Compute T \ B -> B [ T \ (U**T \P**T * B) ] */ + + i__1 = *lda + 1; + dlacpy_("F", &c__1, n, &a[a_dim1 + 1], &i__1, &work[*n], &c__1); + if (*n > 1) { + i__1 = *n - 1; + i__2 = *lda + 1; + dlacpy_("F", &c__1, &i__1, &a[(a_dim1 << 1) + 1], &i__2, &work[1], + &c__1); + i__1 = *n - 1; + i__2 = *lda + 1; + dlacpy_("F", &c__1, &i__1, &a[(a_dim1 << 1) + 1], &i__2, &work[*n + * 2], &c__1); + } + dgtsv_(n, nrhs, &work[1], &work[*n], &work[*n * 2], &b[b_offset], ldb, + info); + +/* 3) Backward substitution with U */ + + if (*n > 1) { + +/* Compute U \ B -> B [ U \ (T \ (U**T \P**T * B) ) ] */ + + i__1 = *n - 1; + dtrsm_("L", "U", "N", "U", &i__1, nrhs, &c_b9, &a[(a_dim1 << 1) + + 1], lda, &b[b_dim1 + 2], ldb); + +/* Pivot, P * B -> B [ P * (U \ (T \ (U**T \P**T * B) )) ] */ + + for (k = *n; k >= 1; --k) { + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + } + + } else { + +/* Solve A*X = B, where A = L*T*L**T. */ + +/* 1) Forward substitution with L */ + + if (*n > 1) { + +/* Pivot, P**T * B -> B */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + +/* Compute L \ B -> B [ (L \P**T * B) ] */ + + i__1 = *n - 1; + dtrsm_("L", "L", "N", "U", &i__1, nrhs, &c_b9, &a[a_dim1 + 2], + lda, &b[b_dim1 + 2], ldb); + } + +/* 2) Solve with triangular matrix T */ + +/* Compute T \ B -> B [ T \ (L \P**T * B) ] */ + + i__1 = *lda + 1; + dlacpy_("F", &c__1, n, &a[a_dim1 + 1], &i__1, &work[*n], &c__1); + if (*n > 1) { + i__1 = *n - 1; + i__2 = *lda + 1; + dlacpy_("F", &c__1, &i__1, &a[a_dim1 + 2], &i__2, &work[1], &c__1); + i__1 = *n - 1; + i__2 = *lda + 1; + dlacpy_("F", &c__1, &i__1, &a[a_dim1 + 2], &i__2, &work[*n * 2], & + c__1); + } + dgtsv_(n, nrhs, &work[1], &work[*n], &work[*n * 2], &b[b_offset], ldb, + info); + +/* 3) Backward substitution with L**T */ + + if (*n > 1) { + +/* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ] */ + + i__1 = *n - 1; + dtrsm_("L", "L", "T", "U", &i__1, nrhs, &c_b9, &a[a_dim1 + 2], + lda, &b[b_dim1 + 2], ldb); + +/* Pivot, P * B -> B [ P * (L**T \ (T \ (L \P**T * B) )) ] */ + + for (k = *n; k >= 1; --k) { + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + } + + } + + return 0; + +/* End of DSYTRS_AA */ + +} /* dsytrs_aa__ */ + diff --git a/lapack-netlib/SRC/dsytrs_aa_2stage.c b/lapack-netlib/SRC/dsytrs_aa_2stage.c new file mode 100644 index 000000000..d89147ae3 --- /dev/null +++ b/lapack-netlib/SRC/dsytrs_aa_2stage.c @@ -0,0 +1,690 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYTRS_AA_2STAGE */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTRS_AA_2STAGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTRS_AA_2STAGE( UPLO, N, NRHS, A, LDA, TB, LTB, IPIV, */ +/* IPIV2, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER N, NRHS, LDA, LTB, LDB, INFO */ +/* INTEGER IPIV( * ), IPIV2( * ) */ +/* DOUBLE PRECISION A( LDA, * ), TB( * ), B( LDB, * ) */ + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYTRS_AA_2STAGE solves a system of linear equations A*X = B with a real */ +/* > symmetric matrix A using the factorization A = U**T*T*U or */ +/* > A = L*T*L**T computed by DSYTRF_AA_2STAGE. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U**T*T*U; */ +/* > = 'L': Lower triangular, form is A = L*T*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > Details of factors computed by DSYTRF_AA_2STAGE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TB */ +/* > \verbatim */ +/* > TB is DOUBLE PRECISION array, dimension (LTB) */ +/* > Details of factors computed by DSYTRF_AA_2STAGE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LTB */ +/* > \verbatim */ +/* > LTB is INTEGER */ +/* > The size of the array TB. LTB >= 4*N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges as computed by */ +/* > DSYTRF_AA_2STAGE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV2 */ +/* > \verbatim */ +/* > IPIV2 is INTEGER array, dimension (N) */ +/* > Details of the interchanges as computed by */ +/* > DSYTRF_AA_2STAGE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup doubleSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dsytrs_aa_2stage_(char *uplo, integer *n, integer *nrhs, + doublereal *a, integer *lda, doublereal *tb, integer *ltb, integer * + ipiv, integer *ipiv2, doublereal *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + integer ldtb; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + logical upper; + integer nb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dgbtrs_( + char *, integer *, integer *, integer *, integer *, doublereal *, + integer *, integer *, doublereal *, integer *, integer *), + dlaswp_(integer *, doublereal *, integer *, integer *, integer *, + integer *, integer *); + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tb; + --ipiv; + --ipiv2; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ltb < *n << 2) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRS_AA_2STAGE", &i__1, (ftnlen)16); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + +/* Read NB and compute LDTB */ + + nb = (integer) tb[1]; + ldtb = *ltb / *n; + + if (upper) { + +/* Solve A*X = B, where A = U**T*T*U. */ + + if (*n > nb) { + +/* Pivot, P**T * B -> B */ + + i__1 = nb + 1; + dlaswp_(nrhs, &b[b_offset], ldb, &i__1, n, &ipiv[1], &c__1); + +/* Compute (U**T \ B) -> B [ (U**T \P**T * B) ] */ + + i__1 = *n - nb; + dtrsm_("L", "U", "T", "U", &i__1, nrhs, &c_b10, &a[(nb + 1) * + a_dim1 + 1], lda, &b[nb + 1 + b_dim1], ldb); + + } + +/* Compute T \ B -> B [ T \ (U**T \P**T * B) ] */ + + dgbtrs_("N", n, &nb, &nb, nrhs, &tb[1], &ldtb, &ipiv2[1], &b[b_offset] + , ldb, info); + if (*n > nb) { + +/* Compute (U \ B) -> B [ U \ (T \ (U**T \P**T * B) ) ] */ + + i__1 = *n - nb; + dtrsm_("L", "U", "N", "U", &i__1, nrhs, &c_b10, &a[(nb + 1) * + a_dim1 + 1], lda, &b[nb + 1 + b_dim1], ldb); + +/* Pivot, P * B -> B [ P * (U \ (T \ (U**T \P**T * B) )) ] */ + + i__1 = nb + 1; + dlaswp_(nrhs, &b[b_offset], ldb, &i__1, n, &ipiv[1], &c_n1); + + } + + } else { + +/* Solve A*X = B, where A = L*T*L**T. */ + + if (*n > nb) { + +/* Pivot, P**T * B -> B */ + + i__1 = nb + 1; + dlaswp_(nrhs, &b[b_offset], ldb, &i__1, n, &ipiv[1], &c__1); + +/* Compute (L \ B) -> B [ (L \P**T * B) ] */ + + i__1 = *n - nb; + dtrsm_("L", "L", "N", "U", &i__1, nrhs, &c_b10, &a[nb + 1 + + a_dim1], lda, &b[nb + 1 + b_dim1], ldb); + + } + +/* Compute T \ B -> B [ T \ (L \P**T * B) ] */ + + dgbtrs_("N", n, &nb, &nb, nrhs, &tb[1], &ldtb, &ipiv2[1], &b[b_offset] + , ldb, info); + if (*n > nb) { + +/* Compute (L**T \ B) -> B [ L**T \ (T \ (L \P**T * B) ) ] */ + + i__1 = *n - nb; + dtrsm_("L", "L", "T", "U", &i__1, nrhs, &c_b10, &a[nb + 1 + + a_dim1], lda, &b[nb + 1 + b_dim1], ldb); + +/* Pivot, P * B -> B [ P * (L**T \ (T \ (L \P**T * B) )) ] */ + + i__1 = nb + 1; + dlaswp_(nrhs, &b[b_offset], ldb, &i__1, n, &ipiv[1], &c_n1); + + } + } + + return 0; + +/* End of DSYTRS_AA_2STAGE */ + +} /* dsytrs_aa_2stage__ */ + diff --git a/lapack-netlib/SRC/dsytrs_rook.c b/lapack-netlib/SRC/dsytrs_rook.c new file mode 100644 index 000000000..0ef65182b --- /dev/null +++ b/lapack-netlib/SRC/dsytrs_rook.c @@ -0,0 +1,930 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DSYTRS_ROOK */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DSYTRS_ROOK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSYTRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSYTRS_ROOK solves a system of linear equations A*X = B with */ +/* > a real symmetric matrix A using the factorization A = U*D*U**T or */ +/* > A = L*D*L**T computed by DSYTRF_ROOK. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U*D*U**T; */ +/* > = 'L': Lower triangular, form is A = L*D*L**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by DSYTRF_ROOK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by DSYTRF_ROOK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup doubleSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > April 2012, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dsytrs_rook_(char *uplo, integer *n, integer *nrhs, + doublereal *a, integer *lda, integer *ipiv, doublereal *b, integer * + ldb, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + doublereal d__1; + + /* Local variables */ + extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *); + doublereal akm1k; + integer j, k; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + doublereal denom; + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *), dswap_(integer *, + doublereal *, integer *, doublereal *, integer *); + logical upper; + doublereal ak, bk; + integer kp; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal akm1, bkm1; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSYTRS_ROOK", &i__1, (ftnlen)11); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + + if (upper) { + +/* Solve A*X = B, where A = U*D*U**T. */ + +/* First solve U*D*X = B, overwriting B with X. */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = *n; +L10: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L30; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(U(K)), where U(K) is the transformation */ +/* stored in column K of A. */ + + i__1 = k - 1; + dger_(&i__1, nrhs, &c_b7, &a[k * a_dim1 + 1], &c__1, &b[k + + b_dim1], ldb, &b[b_dim1 + 1], ldb); + +/* Multiply by the inverse of the diagonal block. */ + + d__1 = 1. / a[k + k * a_dim1]; + dscal_(nrhs, &d__1, &b[k + b_dim1], ldb); + --k; + } else { + +/* 2 x 2 diagonal block */ + +/* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1) */ + + kp = -ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + + kp = -ipiv[k - 1]; + if (kp != k - 1) { + dswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(U(K)), where U(K) is the transformation */ +/* stored in columns K-1 and K of A. */ + + if (k > 2) { + i__1 = k - 2; + dger_(&i__1, nrhs, &c_b7, &a[k * a_dim1 + 1], &c__1, &b[k + + b_dim1], ldb, &b[b_dim1 + 1], ldb); + i__1 = k - 2; + dger_(&i__1, nrhs, &c_b7, &a[(k - 1) * a_dim1 + 1], &c__1, &b[ + k - 1 + b_dim1], ldb, &b[b_dim1 + 1], ldb); + } + +/* Multiply by the inverse of the diagonal block. */ + + akm1k = a[k - 1 + k * a_dim1]; + akm1 = a[k - 1 + (k - 1) * a_dim1] / akm1k; + ak = a[k + k * a_dim1] / akm1k; + denom = akm1 * ak - 1.; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + bkm1 = b[k - 1 + j * b_dim1] / akm1k; + bk = b[k + j * b_dim1] / akm1k; + b[k - 1 + j * b_dim1] = (ak * bkm1 - bk) / denom; + b[k + j * b_dim1] = (akm1 * bk - bkm1) / denom; +/* L20: */ + } + k += -2; + } + + goto L10; +L30: + +/* Next solve U**T *X = B, overwriting B with X. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = 1; +L40: + +/* If K > N, exit from loop. */ + + if (k > *n) { + goto L50; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Multiply by inv(U**T(K)), where U(K) is the transformation */ +/* stored in column K of A. */ + + if (k > 1) { + i__1 = k - 1; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[ + k * a_dim1 + 1], &c__1, &c_b19, &b[k + b_dim1], ldb); + } + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + ++k; + } else { + +/* 2 x 2 diagonal block */ + +/* Multiply by inv(U**T(K+1)), where U(K+1) is the transformation */ +/* stored in columns K and K+1 of A. */ + + if (k > 1) { + i__1 = k - 1; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[ + k * a_dim1 + 1], &c__1, &c_b19, &b[k + b_dim1], ldb); + i__1 = k - 1; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[b_offset], ldb, &a[ + (k + 1) * a_dim1 + 1], &c__1, &c_b19, &b[k + 1 + + b_dim1], ldb); + } + +/* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1). */ + + kp = -ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + + kp = -ipiv[k + 1]; + if (kp != k + 1) { + dswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + + k += 2; + } + + goto L40; +L50: + + ; + } else { + +/* Solve A*X = B, where A = L*D*L**T. */ + +/* First solve L*D*X = B, overwriting B with X. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = 1; +L60: + +/* If K > N, exit from loop. */ + + if (k > *n) { + goto L80; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(L(K)), where L(K) is the transformation */ +/* stored in column K of A. */ + + if (k < *n) { + i__1 = *n - k; + dger_(&i__1, nrhs, &c_b7, &a[k + 1 + k * a_dim1], &c__1, &b[k + + b_dim1], ldb, &b[k + 1 + b_dim1], ldb); + } + +/* Multiply by the inverse of the diagonal block. */ + + d__1 = 1. / a[k + k * a_dim1]; + dscal_(nrhs, &d__1, &b[k + b_dim1], ldb); + ++k; + } else { + +/* 2 x 2 diagonal block */ + +/* Interchange rows K and -IPIV(K) THEN K+1 and -IPIV(K+1) */ + + kp = -ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + + kp = -ipiv[k + 1]; + if (kp != k + 1) { + dswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + +/* Multiply by inv(L(K)), where L(K) is the transformation */ +/* stored in columns K and K+1 of A. */ + + if (k < *n - 1) { + i__1 = *n - k - 1; + dger_(&i__1, nrhs, &c_b7, &a[k + 2 + k * a_dim1], &c__1, &b[k + + b_dim1], ldb, &b[k + 2 + b_dim1], ldb); + i__1 = *n - k - 1; + dger_(&i__1, nrhs, &c_b7, &a[k + 2 + (k + 1) * a_dim1], &c__1, + &b[k + 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb); + } + +/* Multiply by the inverse of the diagonal block. */ + + akm1k = a[k + 1 + k * a_dim1]; + akm1 = a[k + k * a_dim1] / akm1k; + ak = a[k + 1 + (k + 1) * a_dim1] / akm1k; + denom = akm1 * ak - 1.; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + bkm1 = b[k + j * b_dim1] / akm1k; + bk = b[k + 1 + j * b_dim1] / akm1k; + b[k + j * b_dim1] = (ak * bkm1 - bk) / denom; + b[k + 1 + j * b_dim1] = (akm1 * bk - bkm1) / denom; +/* L70: */ + } + k += 2; + } + + goto L60; +L80: + +/* Next solve L**T *X = B, overwriting B with X. */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = *n; +L90: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L100; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Multiply by inv(L**T(K)), where L(K) is the transformation */ +/* stored in column K of A. */ + + if (k < *n) { + i__1 = *n - k; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], + ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b19, &b[k + + b_dim1], ldb); + } + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + --k; + } else { + +/* 2 x 2 diagonal block */ + +/* Multiply by inv(L**T(K-1)), where L(K-1) is the transformation */ +/* stored in columns K-1 and K of A. */ + + if (k < *n) { + i__1 = *n - k; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], + ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b19, &b[k + + b_dim1], ldb); + i__1 = *n - k; + dgemv_("Transpose", &i__1, nrhs, &c_b7, &b[k + 1 + b_dim1], + ldb, &a[k + 1 + (k - 1) * a_dim1], &c__1, &c_b19, &b[ + k - 1 + b_dim1], ldb); + } + +/* Interchange rows K and -IPIV(K) THEN K-1 and -IPIV(K-1) */ + + kp = -ipiv[k]; + if (kp != k) { + dswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + + kp = -ipiv[k - 1]; + if (kp != k - 1) { + dswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + + k += -2; + } + + goto L90; +L100: + ; + } + + return 0; + +/* End of DSYTRS_ROOK */ + +} /* dsytrs_rook__ */ + diff --git a/lapack-netlib/SRC/dtbcon.c b/lapack-netlib/SRC/dtbcon.c new file mode 100644 index 000000000..6b6e4b122 --- /dev/null +++ b/lapack-netlib/SRC/dtbcon.c @@ -0,0 +1,686 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTBCON */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTBCON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK, */ +/* IWORK, INFO ) */ + +/* CHARACTER DIAG, NORM, UPLO */ +/* INTEGER INFO, KD, LDAB, N */ +/* DOUBLE PRECISION RCOND */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION AB( LDAB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTBCON estimates the reciprocal of the condition number of a */ +/* > triangular band matrix A, in either the 1-norm or the infinity-norm. */ +/* > */ +/* > The norm of A is computed and an estimate is obtained for */ +/* > norm(inv(A)), then the reciprocal of the condition number is */ +/* > computed as */ +/* > RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies whether the 1-norm condition number or the */ +/* > infinity-norm condition number is required: */ +/* > = '1' or 'O': 1-norm; */ +/* > = 'I': Infinity-norm. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of superdiagonals or subdiagonals of the */ +/* > triangular band matrix A. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is DOUBLE PRECISION array, dimension (LDAB,N) */ +/* > The upper or lower triangular band matrix A, stored in the */ +/* > first kd+1 rows of the array. The j-th column of A is stored */ +/* > in the j-th column of the array AB as follows: */ +/* > if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > If DIAG = 'U', the diagonal elements of A are not referenced */ +/* > and are assumed to be 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > The reciprocal of the condition number of the matrix A, */ +/* > computed as RCOND = 1/(norm(A) * norm(inv(A))). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dtbcon_(char *norm, char *uplo, char *diag, integer *n, + integer *kd, doublereal *ab, integer *ldab, doublereal *rcond, + doublereal *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1; + doublereal d__1; + + /* Local variables */ + integer kase, kase1; + doublereal scale; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *, + integer *); + doublereal anorm; + logical upper; + doublereal xnorm; + extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + extern doublereal dlamch_(char *); + integer ix; + extern integer idamax_(integer *, doublereal *, integer *); + extern doublereal dlantb_(char *, char *, char *, integer *, integer *, + doublereal *, integer *, doublereal *); + extern /* Subroutine */ int dlatbs_(char *, char *, char *, char *, + integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, integer *), xerbla_(char *, integer *, ftnlen); + doublereal ainvnm; + logical onenrm; + char normin[1]; + doublereal smlnum; + logical nounit; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); + nounit = lsame_(diag, "N"); + + if (! onenrm && ! lsame_(norm, "I")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*kd < 0) { + *info = -5; + } else if (*ldab < *kd + 1) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTBCON", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *rcond = 1.; + return 0; + } + + *rcond = 0.; + smlnum = dlamch_("Safe minimum") * (doublereal) f2cmax(1,*n); + +/* Compute the norm of the triangular matrix A. */ + + anorm = dlantb_(norm, uplo, diag, n, kd, &ab[ab_offset], ldab, &work[1]); + +/* Continue only if ANORM > 0. */ + + if (anorm > 0.) { + +/* Estimate the norm of the inverse of A. */ + + ainvnm = 0.; + *(unsigned char *)normin = 'N'; + if (onenrm) { + kase1 = 1; + } else { + kase1 = 2; + } + kase = 0; +L10: + dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == kase1) { + +/* Multiply by inv(A). */ + + dlatbs_(uplo, "No transpose", diag, normin, n, kd, &ab[ + ab_offset], ldab, &work[1], &scale, &work[(*n << 1) + + 1], info) + ; + } else { + +/* Multiply by inv(A**T). */ + + dlatbs_(uplo, "Transpose", diag, normin, n, kd, &ab[ab_offset] + , ldab, &work[1], &scale, &work[(*n << 1) + 1], info); + } + *(unsigned char *)normin = 'Y'; + +/* Multiply by 1/SCALE if doing so will not cause overflow. */ + + if (scale != 1.) { + ix = idamax_(n, &work[1], &c__1); + xnorm = (d__1 = work[ix], abs(d__1)); + if (scale < xnorm * smlnum || scale == 0.) { + goto L20; + } + drscl_(n, &scale, &work[1], &c__1); + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + *rcond = 1. / anorm / ainvnm; + } + } + +L20: + return 0; + +/* End of DTBCON */ + +} /* dtbcon_ */ + diff --git a/lapack-netlib/SRC/dtbrfs.c b/lapack-netlib/SRC/dtbrfs.c new file mode 100644 index 000000000..ce363f6ac --- /dev/null +++ b/lapack-netlib/SRC/dtbrfs.c @@ -0,0 +1,975 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTBRFS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTBRFS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, */ +/* LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO ) */ + +/* CHARACTER DIAG, TRANS, UPLO */ +/* INTEGER INFO, KD, LDAB, LDB, LDX, N, NRHS */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ), BERR( * ), */ +/* $ FERR( * ), WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTBRFS provides error bounds and backward error estimates for the */ +/* > solution to a system of linear equations with a triangular band */ +/* > coefficient matrix. */ +/* > */ +/* > The solution matrix X must be computed by DTBTRS or some other */ +/* > means before entering this routine. DTBRFS does not do iterative */ +/* > refinement because doing so cannot improve the backward error. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of superdiagonals or subdiagonals of the */ +/* > triangular band matrix A. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is DOUBLE PRECISION array, dimension (LDAB,N) */ +/* > The upper or lower triangular band matrix A, stored in the */ +/* > first kd+1 rows of the array. The j-th column of A is stored */ +/* > in the j-th column of the array AB as follows: */ +/* > if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > If DIAG = 'U', the diagonal elements of A are not referenced */ +/* > and are assumed to be 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > The right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* > The solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dtbrfs_(char *uplo, char *trans, char *diag, integer *n, + integer *kd, integer *nrhs, doublereal *ab, integer *ldab, doublereal + *b, integer *ldb, doublereal *x, integer *ldx, doublereal *ferr, + doublereal *berr, doublereal *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, + i__2, i__3, i__4, i__5; + doublereal d__1, d__2, d__3; + + /* Local variables */ + integer kase; + doublereal safe1, safe2; + integer i__, j, k; + doublereal s; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int dtbmv_(char *, char *, char *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *), dcopy_(integer *, doublereal *, integer * + , doublereal *, integer *), dtbsv_(char *, char *, char *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *), daxpy_(integer *, doublereal * + , doublereal *, integer *, doublereal *, integer *); + logical upper; + extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + extern doublereal dlamch_(char *); + doublereal xk; + integer nz; + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical notran; + char transt[1]; + logical nounit; + doublereal lstres, eps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + notran = lsame_(trans, "N"); + nounit = lsame_(diag, "N"); + + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*kd < 0) { + *info = -5; + } else if (*nrhs < 0) { + *info = -6; + } else if (*ldab < *kd + 1) { + *info = -8; + } else if (*ldb < f2cmax(1,*n)) { + *info = -10; + } else if (*ldx < f2cmax(1,*n)) { + *info = -12; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTBRFS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.; + berr[j] = 0.; +/* L10: */ + } + return 0; + } + + if (notran) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = *kd + 2; + eps = dlamch_("Epsilon"); + safmin = dlamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Compute residual R = B - op(A) * X, */ +/* where op(A) = A or A**T, depending on TRANS. */ + + dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1); + dtbmv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[*n + 1], + &c__1); + daxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* f2cmax(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); +/* L20: */ + } + + if (notran) { + +/* Compute abs(A)*abs(X) + abs(B). */ + + if (upper) { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); +/* Computing MAX */ + i__3 = 1, i__4 = k - *kd; + i__5 = k; + for (i__ = f2cmax(i__3,i__4); i__ <= i__5; ++i__) { + work[i__] += (d__1 = ab[*kd + 1 + i__ - k + k * + ab_dim1], abs(d__1)) * xk; +/* L30: */ + } +/* L40: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); +/* Computing MAX */ + i__5 = 1, i__3 = k - *kd; + i__4 = k - 1; + for (i__ = f2cmax(i__5,i__3); i__ <= i__4; ++i__) { + work[i__] += (d__1 = ab[*kd + 1 + i__ - k + k * + ab_dim1], abs(d__1)) * xk; +/* L50: */ + } + work[k] += xk; +/* L60: */ + } + } + } else { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); +/* Computing MIN */ + i__5 = *n, i__3 = k + *kd; + i__4 = f2cmin(i__5,i__3); + for (i__ = k; i__ <= i__4; ++i__) { + work[i__] += (d__1 = ab[i__ + 1 - k + k * ab_dim1] + , abs(d__1)) * xk; +/* L70: */ + } +/* L80: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); +/* Computing MIN */ + i__5 = *n, i__3 = k + *kd; + i__4 = f2cmin(i__5,i__3); + for (i__ = k + 1; i__ <= i__4; ++i__) { + work[i__] += (d__1 = ab[i__ + 1 - k + k * ab_dim1] + , abs(d__1)) * xk; +/* L90: */ + } + work[k] += xk; +/* L100: */ + } + } + } + } else { + +/* Compute abs(A**T)*abs(X) + abs(B). */ + + if (upper) { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; +/* Computing MAX */ + i__4 = 1, i__5 = k - *kd; + i__3 = k; + for (i__ = f2cmax(i__4,i__5); i__ <= i__3; ++i__) { + s += (d__1 = ab[*kd + 1 + i__ - k + k * ab_dim1], + abs(d__1)) * (d__2 = x[i__ + j * x_dim1], + abs(d__2)); +/* L110: */ + } + work[k] += s; +/* L120: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = (d__1 = x[k + j * x_dim1], abs(d__1)); +/* Computing MAX */ + i__3 = 1, i__4 = k - *kd; + i__5 = k - 1; + for (i__ = f2cmax(i__3,i__4); i__ <= i__5; ++i__) { + s += (d__1 = ab[*kd + 1 + i__ - k + k * ab_dim1], + abs(d__1)) * (d__2 = x[i__ + j * x_dim1], + abs(d__2)); +/* L130: */ + } + work[k] += s; +/* L140: */ + } + } + } else { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; +/* Computing MIN */ + i__3 = *n, i__4 = k + *kd; + i__5 = f2cmin(i__3,i__4); + for (i__ = k; i__ <= i__5; ++i__) { + s += (d__1 = ab[i__ + 1 - k + k * ab_dim1], abs( + d__1)) * (d__2 = x[i__ + j * x_dim1], abs( + d__2)); +/* L150: */ + } + work[k] += s; +/* L160: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = (d__1 = x[k + j * x_dim1], abs(d__1)); +/* Computing MIN */ + i__3 = *n, i__4 = k + *kd; + i__5 = f2cmin(i__3,i__4); + for (i__ = k + 1; i__ <= i__5; ++i__) { + s += (d__1 = ab[i__ + 1 - k + k * ab_dim1], abs( + d__1)) * (d__2 = x[i__ + j * x_dim1], abs( + d__2)); +/* L170: */ + } + work[k] += s; +/* L180: */ + } + } + } + } + s = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ + i__]; + s = f2cmax(d__2,d__3); + } else { +/* Computing MAX */ + d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) + / (work[i__] + safe1); + s = f2cmax(d__2,d__3); + } +/* L190: */ + } + berr[j] = s; + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(op(A)))* */ +/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(op(A)) is the inverse of op(A) */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ + +/* Use DLACN2 to estimate the infinity-norm of the matrix */ +/* inv(op(A)) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__] + safe1; + } +/* L200: */ + } + + kase = 0; +L210: + dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & + kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(op(A)**T). */ + + dtbsv_(uplo, transt, diag, n, kd, &ab[ab_offset], ldab, &work[ + *n + 1], &c__1); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L220: */ + } + } else { + +/* Multiply by inv(op(A))*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L230: */ + } + dtbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &work[* + n + 1], &c__1); + } + goto L210; + } + +/* Normalize error. */ + + lstres = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); + lstres = f2cmax(d__2,d__3); +/* L240: */ + } + if (lstres != 0.) { + ferr[j] /= lstres; + } + +/* L250: */ + } + + return 0; + +/* End of DTBRFS */ + +} /* dtbrfs_ */ + diff --git a/lapack-netlib/SRC/dtbtrs.c b/lapack-netlib/SRC/dtbtrs.c new file mode 100644 index 000000000..570f6388e --- /dev/null +++ b/lapack-netlib/SRC/dtbtrs.c @@ -0,0 +1,644 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTBTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTBTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B, */ +/* LDB, INFO ) */ + +/* CHARACTER DIAG, TRANS, UPLO */ +/* INTEGER INFO, KD, LDAB, LDB, N, NRHS */ +/* DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTBTRS solves a triangular system of the form */ +/* > */ +/* > A * X = B or A**T * X = B, */ +/* > */ +/* > where A is a triangular band matrix of order N, and B is an */ +/* > N-by NRHS matrix. A check is made to verify that A is nonsingular. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KD */ +/* > \verbatim */ +/* > KD is INTEGER */ +/* > The number of superdiagonals or subdiagonals of the */ +/* > triangular band matrix A. KD >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is DOUBLE PRECISION array, dimension (LDAB,N) */ +/* > The upper or lower triangular band matrix A, stored in the */ +/* > first kd+1 rows of AB. The j-th column of A is stored */ +/* > in the j-th column of the array AB as follows: */ +/* > if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for f2cmax(1,j-kd)<=i<=j; */ +/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ +/* > If DIAG = 'U', the diagonal elements of A are not referenced */ +/* > and are assumed to be 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KD+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, if INFO = 0, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the i-th diagonal element of A is zero, */ +/* > indicating that the matrix is singular and the */ +/* > solutions X have not been computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dtbtrs_(char *uplo, char *trans, char *diag, integer *n, + integer *kd, integer *nrhs, doublereal *ab, integer *ldab, doublereal + *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + integer j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dtbsv_(char *, char *, char *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *); + logical upper; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical nounit; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + nounit = lsame_(diag, "N"); + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*kd < 0) { + *info = -5; + } else if (*nrhs < 0) { + *info = -6; + } else if (*ldab < *kd + 1) { + *info = -8; + } else if (*ldb < f2cmax(1,*n)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTBTRS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check for singularity. */ + + if (nounit) { + if (upper) { + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (ab[*kd + 1 + *info * ab_dim1] == 0.) { + return 0; + } +/* L10: */ + } + } else { + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (ab[*info * ab_dim1 + 1] == 0.) { + return 0; + } +/* L20: */ + } + } + } + *info = 0; + +/* Solve A * X = B or A**T * X = B. */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + dtbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &b[j * b_dim1 + + 1], &c__1); +/* L30: */ + } + + return 0; + +/* End of DTBTRS */ + +} /* dtbtrs_ */ + diff --git a/lapack-netlib/SRC/dtfsm.c b/lapack-netlib/SRC/dtfsm.c new file mode 100644 index 000000000..ccb36c8f5 --- /dev/null +++ b/lapack-netlib/SRC/dtfsm.c @@ -0,0 +1,1412 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTFSM solves a matrix equation (one operand is a triangular matrix in RFP format). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTFSM + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTFSM( TRANSR, SIDE, UPLO, TRANS, DIAG, M, N, ALPHA, A, */ +/* B, LDB ) */ + +/* CHARACTER TRANSR, DIAG, SIDE, TRANS, UPLO */ +/* INTEGER LDB, M, N */ +/* DOUBLE PRECISION ALPHA */ +/* DOUBLE PRECISION A( 0: * ), B( 0: LDB-1, 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Level 3 BLAS like routine for A in RFP Format. */ +/* > */ +/* > DTFSM solves the matrix equation */ +/* > */ +/* > op( A )*X = alpha*B or X*op( A ) = alpha*B */ +/* > */ +/* > where alpha is a scalar, X and B are m by n matrices, A is a unit, or */ +/* > non-unit, upper or lower triangular matrix and op( A ) is one of */ +/* > */ +/* > op( A ) = A or op( A ) = A**T. */ +/* > */ +/* > A is in Rectangular Full Packed (RFP) Format. */ +/* > */ +/* > The matrix X is overwritten on B. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER*1 */ +/* > = 'N': The Normal Form of RFP A is stored; */ +/* > = 'T': The Transpose Form of RFP A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > On entry, SIDE specifies whether op( A ) appears on the left */ +/* > or right of X as follows: */ +/* > */ +/* > SIDE = 'L' or 'l' op( A )*X = alpha*B. */ +/* > */ +/* > SIDE = 'R' or 'r' X*op( A ) = alpha*B. */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > On entry, UPLO specifies whether the RFP matrix A came from */ +/* > an upper or lower triangular matrix as follows: */ +/* > UPLO = 'U' or 'u' RFP A came from an upper triangular matrix */ +/* > UPLO = 'L' or 'l' RFP A came from a lower triangular matrix */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > On entry, TRANS specifies the form of op( A ) to be used */ +/* > in the matrix multiplication as follows: */ +/* > */ +/* > TRANS = 'N' or 'n' op( A ) = A. */ +/* > */ +/* > TRANS = 'T' or 't' op( A ) = A'. */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > On entry, DIAG specifies whether or not RFP A is unit */ +/* > triangular as follows: */ +/* > */ +/* > DIAG = 'U' or 'u' A is assumed to be unit triangular. */ +/* > */ +/* > DIAG = 'N' or 'n' A is not assumed to be unit */ +/* > triangular. */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > On entry, M specifies the number of rows of B. M must be at */ +/* > least zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > On entry, N specifies the number of columns of B. N must be */ +/* > at least zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is DOUBLE PRECISION */ +/* > On entry, ALPHA specifies the scalar alpha. When alpha is */ +/* > zero then A is not referenced and B need not be set before */ +/* > entry. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (NT) */ +/* > NT = N*(N+1)/2. On entry, the matrix A in RFP Format. */ +/* > RFP Format is described by TRANSR, UPLO and N as follows: */ +/* > If TRANSR='N' then RFP A is (0:N,0:K-1) when N is even; */ +/* > K=N/2. RFP A is (0:N-1,0:K) when N is odd; K=N/2. If */ +/* > TRANSR = 'T' then RFP is the transpose of RFP A as */ +/* > defined when TRANSR = 'N'. The contents of RFP A are defined */ +/* > by UPLO as follows: If UPLO = 'U' the RFP A contains the NT */ +/* > elements of upper packed A either in normal or */ +/* > transpose Format. If UPLO = 'L' the RFP A contains */ +/* > the NT elements of lower packed A either in normal or */ +/* > transpose Format. The LDA of RFP A is (N+1)/2 when */ +/* > TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is */ +/* > even and is N when is odd. */ +/* > See the Note below for more details. Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,N) */ +/* > Before entry, the leading m by n part of the array B must */ +/* > contain the right-hand side matrix B, and on exit is */ +/* > overwritten by the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > On entry, LDB specifies the first dimension of B as declared */ +/* > in the calling (sub) program. LDB must be at least */ +/* > f2cmax( 1, m ). */ +/* > Unchanged on exit. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > We first consider Rectangular Full Packed (RFP) Format when N is */ +/* > even. We give an example where N = 6. */ +/* > */ +/* > AP is Upper AP is Lower */ +/* > */ +/* > 00 01 02 03 04 05 00 */ +/* > 11 12 13 14 15 10 11 */ +/* > 22 23 24 25 20 21 22 */ +/* > 33 34 35 30 31 32 33 */ +/* > 44 45 40 41 42 43 44 */ +/* > 55 50 51 52 53 54 55 */ +/* > */ +/* > */ +/* > Let TRANSR = 'N'. RFP holds AP as follows: */ +/* > For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ +/* > three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ +/* > the transpose of the first three columns of AP upper. */ +/* > For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ +/* > three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ +/* > the transpose of the last three columns of AP lower. */ +/* > This covers the case N even and TRANSR = 'N'. */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 03 04 05 33 43 53 */ +/* > 13 14 15 00 44 54 */ +/* > 23 24 25 10 11 55 */ +/* > 33 34 35 20 21 22 */ +/* > 00 44 45 30 31 32 */ +/* > 01 11 55 40 41 42 */ +/* > 02 12 22 50 51 52 */ +/* > */ +/* > Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* > transpose of RFP A above. One therefore gets: */ +/* > */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ +/* > 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ +/* > 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ +/* > */ +/* > */ +/* > We then consider Rectangular Full Packed (RFP) Format when N is */ +/* > odd. We give an example where N = 5. */ +/* > */ +/* > AP is Upper AP is Lower */ +/* > */ +/* > 00 01 02 03 04 00 */ +/* > 11 12 13 14 10 11 */ +/* > 22 23 24 20 21 22 */ +/* > 33 34 30 31 32 33 */ +/* > 44 40 41 42 43 44 */ +/* > */ +/* > */ +/* > Let TRANSR = 'N'. RFP holds AP as follows: */ +/* > For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ +/* > three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ +/* > the transpose of the first two columns of AP upper. */ +/* > For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ +/* > three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ +/* > the transpose of the last two columns of AP lower. */ +/* > This covers the case N odd and TRANSR = 'N'. */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 02 03 04 00 33 43 */ +/* > 12 13 14 10 11 44 */ +/* > 22 23 24 20 21 22 */ +/* > 00 33 34 30 31 32 */ +/* > 01 11 44 40 41 42 */ +/* > */ +/* > Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* > transpose of RFP A above. One therefore gets: */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 02 12 22 00 01 00 10 20 30 40 50 */ +/* > 03 13 23 33 11 33 11 21 31 41 51 */ +/* > 04 14 24 34 44 43 44 22 32 42 52 */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dtfsm_(char *transr, char *side, char *uplo, char *trans, + char *diag, integer *m, integer *n, doublereal *alpha, doublereal *a, + doublereal *b, integer *ldb) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2; + + /* Local variables */ + integer info, i__, j, k; + logical normaltransr; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + logical lside; + extern logical lsame_(char *, char *); + logical lower; + extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + integer m1, m2, n1, n2; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical misodd, nisodd, notrans; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + b_dim1 = *ldb - 1 - 0 + 1; + b_offset = 0 + b_dim1 * 0; + b -= b_offset; + + /* Function Body */ + info = 0; + normaltransr = lsame_(transr, "N"); + lside = lsame_(side, "L"); + lower = lsame_(uplo, "L"); + notrans = lsame_(trans, "N"); + if (! normaltransr && ! lsame_(transr, "T")) { + info = -1; + } else if (! lside && ! lsame_(side, "R")) { + info = -2; + } else if (! lower && ! lsame_(uplo, "U")) { + info = -3; + } else if (! notrans && ! lsame_(trans, "T")) { + info = -4; + } else if (! lsame_(diag, "N") && ! lsame_(diag, + "U")) { + info = -5; + } else if (*m < 0) { + info = -6; + } else if (*n < 0) { + info = -7; + } else if (*ldb < f2cmax(1,*m)) { + info = -11; + } + if (info != 0) { + i__1 = -info; + xerbla_("DTFSM ", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return when ( (N.EQ.0).OR.(M.EQ.0) ) */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Quick return when ALPHA.EQ.(0D+0) */ + + if (*alpha == 0.) { + i__1 = *n - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = *m - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = 0.; +/* L10: */ + } +/* L20: */ + } + return 0; + } + + if (lside) { + +/* SIDE = 'L' */ + +/* A is M-by-M. */ +/* If M is odd, set NISODD = .TRUE., and M1 and M2. */ +/* If M is even, NISODD = .FALSE., and M. */ + + if (*m % 2 == 0) { + misodd = FALSE_; + k = *m / 2; + } else { + misodd = TRUE_; + if (lower) { + m2 = *m / 2; + m1 = *m - m2; + } else { + m1 = *m / 2; + m2 = *m - m1; + } + } + + + if (misodd) { + +/* SIDE = 'L' and N is odd */ + + if (normaltransr) { + +/* SIDE = 'L', N is odd, and TRANSR = 'N' */ + + if (lower) { + +/* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and */ +/* TRANS = 'N' */ + + if (*m == 1) { + dtrsm_("L", "L", "N", diag, &m1, n, alpha, a, m, & + b[b_offset], ldb); + } else { + dtrsm_("L", "L", "N", diag, &m1, n, alpha, a, m, & + b[b_offset], ldb); + dgemm_("N", "N", &m2, n, &m1, &c_b23, &a[m1], m, & + b[b_offset], ldb, alpha, &b[m1], ldb); + dtrsm_("L", "U", "T", diag, &m2, n, &c_b27, &a[*m] + , m, &b[m1], ldb); + } + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'L', and */ +/* TRANS = 'T' */ + + if (*m == 1) { + dtrsm_("L", "L", "T", diag, &m1, n, alpha, a, m, & + b[b_offset], ldb); + } else { + dtrsm_("L", "U", "N", diag, &m2, n, alpha, &a[*m], + m, &b[m1], ldb); + dgemm_("T", "N", &m1, n, &m2, &c_b23, &a[m1], m, & + b[m1], ldb, alpha, &b[b_offset], ldb); + dtrsm_("L", "L", "T", diag, &m1, n, &c_b27, a, m, + &b[b_offset], ldb); + } + + } + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'N', and UPLO = 'U' */ + + if (! notrans) { + +/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and */ +/* TRANS = 'N' */ + + dtrsm_("L", "L", "N", diag, &m1, n, alpha, &a[m2], m, + &b[b_offset], ldb); + dgemm_("T", "N", &m2, n, &m1, &c_b23, a, m, &b[ + b_offset], ldb, alpha, &b[m1], ldb); + dtrsm_("L", "U", "T", diag, &m2, n, &c_b27, &a[m1], m, + &b[m1], ldb); + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'N', UPLO = 'U', and */ +/* TRANS = 'T' */ + + dtrsm_("L", "U", "N", diag, &m2, n, alpha, &a[m1], m, + &b[m1], ldb); + dgemm_("N", "N", &m1, n, &m2, &c_b23, a, m, &b[m1], + ldb, alpha, &b[b_offset], ldb); + dtrsm_("L", "L", "T", diag, &m1, n, &c_b27, &a[m2], m, + &b[b_offset], ldb); + + } + + } + + } else { + +/* SIDE = 'L', N is odd, and TRANSR = 'T' */ + + if (lower) { + +/* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and */ +/* TRANS = 'N' */ + + if (*m == 1) { + dtrsm_("L", "U", "T", diag, &m1, n, alpha, a, &m1, + &b[b_offset], ldb); + } else { + dtrsm_("L", "U", "T", diag, &m1, n, alpha, a, &m1, + &b[b_offset], ldb); + dgemm_("T", "N", &m2, n, &m1, &c_b23, &a[m1 * m1], + &m1, &b[b_offset], ldb, alpha, &b[m1], + ldb); + dtrsm_("L", "L", "N", diag, &m2, n, &c_b27, &a[1], + &m1, &b[m1], ldb); + } + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'L', and */ +/* TRANS = 'T' */ + + if (*m == 1) { + dtrsm_("L", "U", "N", diag, &m1, n, alpha, a, &m1, + &b[b_offset], ldb); + } else { + dtrsm_("L", "L", "T", diag, &m2, n, alpha, &a[1], + &m1, &b[m1], ldb); + dgemm_("N", "N", &m1, n, &m2, &c_b23, &a[m1 * m1], + &m1, &b[m1], ldb, alpha, &b[b_offset], + ldb); + dtrsm_("L", "U", "N", diag, &m1, n, &c_b27, a, & + m1, &b[b_offset], ldb); + } + + } + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'T', and UPLO = 'U' */ + + if (! notrans) { + +/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and */ +/* TRANS = 'N' */ + + dtrsm_("L", "U", "T", diag, &m1, n, alpha, &a[m2 * m2] + , &m2, &b[b_offset], ldb); + dgemm_("N", "N", &m2, n, &m1, &c_b23, a, &m2, &b[ + b_offset], ldb, alpha, &b[m1], ldb); + dtrsm_("L", "L", "N", diag, &m2, n, &c_b27, &a[m1 * + m2], &m2, &b[m1], ldb); + + } else { + +/* SIDE ='L', N is odd, TRANSR = 'T', UPLO = 'U', and */ +/* TRANS = 'T' */ + + dtrsm_("L", "L", "T", diag, &m2, n, alpha, &a[m1 * m2] + , &m2, &b[m1], ldb); + dgemm_("T", "N", &m1, n, &m2, &c_b23, a, &m2, &b[m1], + ldb, alpha, &b[b_offset], ldb); + dtrsm_("L", "U", "N", diag, &m1, n, &c_b27, &a[m2 * + m2], &m2, &b[b_offset], ldb); + + } + + } + + } + + } else { + +/* SIDE = 'L' and N is even */ + + if (normaltransr) { + +/* SIDE = 'L', N is even, and TRANSR = 'N' */ + + if (lower) { + +/* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', */ +/* and TRANS = 'N' */ + + i__1 = *m + 1; + dtrsm_("L", "L", "N", diag, &k, n, alpha, &a[1], & + i__1, &b[b_offset], ldb); + i__1 = *m + 1; + dgemm_("N", "N", &k, n, &k, &c_b23, &a[k + 1], &i__1, + &b[b_offset], ldb, alpha, &b[k], ldb); + i__1 = *m + 1; + dtrsm_("L", "U", "T", diag, &k, n, &c_b27, a, &i__1, & + b[k], ldb); + + } else { + +/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'L', */ +/* and TRANS = 'T' */ + + i__1 = *m + 1; + dtrsm_("L", "U", "N", diag, &k, n, alpha, a, &i__1, & + b[k], ldb); + i__1 = *m + 1; + dgemm_("T", "N", &k, n, &k, &c_b23, &a[k + 1], &i__1, + &b[k], ldb, alpha, &b[b_offset], ldb); + i__1 = *m + 1; + dtrsm_("L", "L", "T", diag, &k, n, &c_b27, &a[1], & + i__1, &b[b_offset], ldb); + + } + + } else { + +/* SIDE ='L', N is even, TRANSR = 'N', and UPLO = 'U' */ + + if (! notrans) { + +/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', */ +/* and TRANS = 'N' */ + + i__1 = *m + 1; + dtrsm_("L", "L", "N", diag, &k, n, alpha, &a[k + 1], & + i__1, &b[b_offset], ldb); + i__1 = *m + 1; + dgemm_("T", "N", &k, n, &k, &c_b23, a, &i__1, &b[ + b_offset], ldb, alpha, &b[k], ldb); + i__1 = *m + 1; + dtrsm_("L", "U", "T", diag, &k, n, &c_b27, &a[k], & + i__1, &b[k], ldb); + + } else { + +/* SIDE ='L', N is even, TRANSR = 'N', UPLO = 'U', */ +/* and TRANS = 'T' */ + i__1 = *m + 1; + dtrsm_("L", "U", "N", diag, &k, n, alpha, &a[k], & + i__1, &b[k], ldb); + i__1 = *m + 1; + dgemm_("N", "N", &k, n, &k, &c_b23, a, &i__1, &b[k], + ldb, alpha, &b[b_offset], ldb); + i__1 = *m + 1; + dtrsm_("L", "L", "T", diag, &k, n, &c_b27, &a[k + 1], + &i__1, &b[b_offset], ldb); + + } + + } + + } else { + +/* SIDE = 'L', N is even, and TRANSR = 'T' */ + + if (lower) { + +/* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', */ +/* and TRANS = 'N' */ + + dtrsm_("L", "U", "T", diag, &k, n, alpha, &a[k], &k, & + b[b_offset], ldb); + dgemm_("T", "N", &k, n, &k, &c_b23, &a[k * (k + 1)], & + k, &b[b_offset], ldb, alpha, &b[k], ldb); + dtrsm_("L", "L", "N", diag, &k, n, &c_b27, a, &k, &b[ + k], ldb); + + } else { + +/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'L', */ +/* and TRANS = 'T' */ + + dtrsm_("L", "L", "T", diag, &k, n, alpha, a, &k, &b[k] + , ldb); + dgemm_("N", "N", &k, n, &k, &c_b23, &a[k * (k + 1)], & + k, &b[k], ldb, alpha, &b[b_offset], ldb); + dtrsm_("L", "U", "N", diag, &k, n, &c_b27, &a[k], &k, + &b[b_offset], ldb); + + } + + } else { + +/* SIDE ='L', N is even, TRANSR = 'T', and UPLO = 'U' */ + + if (! notrans) { + +/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', */ +/* and TRANS = 'N' */ + + dtrsm_("L", "U", "T", diag, &k, n, alpha, &a[k * (k + + 1)], &k, &b[b_offset], ldb); + dgemm_("N", "N", &k, n, &k, &c_b23, a, &k, &b[ + b_offset], ldb, alpha, &b[k], ldb); + dtrsm_("L", "L", "N", diag, &k, n, &c_b27, &a[k * k], + &k, &b[k], ldb); + + } else { + +/* SIDE ='L', N is even, TRANSR = 'T', UPLO = 'U', */ +/* and TRANS = 'T' */ + + dtrsm_("L", "L", "T", diag, &k, n, alpha, &a[k * k], & + k, &b[k], ldb); + dgemm_("T", "N", &k, n, &k, &c_b23, a, &k, &b[k], ldb, + alpha, &b[b_offset], ldb); + dtrsm_("L", "U", "N", diag, &k, n, &c_b27, &a[k * (k + + 1)], &k, &b[b_offset], ldb); + + } + + } + + } + + } + + } else { + +/* SIDE = 'R' */ + +/* A is N-by-N. */ +/* If N is odd, set NISODD = .TRUE., and N1 and N2. */ +/* If N is even, NISODD = .FALSE., and K. */ + + if (*n % 2 == 0) { + nisodd = FALSE_; + k = *n / 2; + } else { + nisodd = TRUE_; + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + } + + if (nisodd) { + +/* SIDE = 'R' and N is odd */ + + if (normaltransr) { + +/* SIDE = 'R', N is odd, and TRANSR = 'N' */ + + if (lower) { + +/* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and */ +/* TRANS = 'N' */ + + dtrsm_("R", "U", "T", diag, m, &n2, alpha, &a[*n], n, + &b[n1 * b_dim1], ldb); + dgemm_("N", "N", m, &n1, &n2, &c_b23, &b[n1 * b_dim1], + ldb, &a[n1], n, alpha, b, ldb); + dtrsm_("R", "L", "N", diag, m, &n1, &c_b27, a, n, b, + ldb); + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'L', and */ +/* TRANS = 'T' */ + + dtrsm_("R", "L", "T", diag, m, &n1, alpha, a, n, b, + ldb); + dgemm_("N", "T", m, &n2, &n1, &c_b23, b, ldb, &a[n1], + n, alpha, &b[n1 * b_dim1], ldb); + dtrsm_("R", "U", "N", diag, m, &n2, &c_b27, &a[*n], n, + &b[n1 * b_dim1], ldb); + + } + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'N', and UPLO = 'U' */ + + if (notrans) { + +/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and */ +/* TRANS = 'N' */ + + dtrsm_("R", "L", "T", diag, m, &n1, alpha, &a[n2], n, + b, ldb); + dgemm_("N", "N", m, &n2, &n1, &c_b23, b, ldb, a, n, + alpha, &b[n1 * b_dim1], ldb); + dtrsm_("R", "U", "N", diag, m, &n2, &c_b27, &a[n1], n, + &b[n1 * b_dim1], ldb); + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'N', UPLO = 'U', and */ +/* TRANS = 'T' */ + + dtrsm_("R", "U", "T", diag, m, &n2, alpha, &a[n1], n, + &b[n1 * b_dim1], ldb); + dgemm_("N", "T", m, &n1, &n2, &c_b23, &b[n1 * b_dim1], + ldb, a, n, alpha, b, ldb); + dtrsm_("R", "L", "N", diag, m, &n1, &c_b27, &a[n2], n, + b, ldb); + + } + + } + + } else { + +/* SIDE = 'R', N is odd, and TRANSR = 'T' */ + + if (lower) { + +/* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and */ +/* TRANS = 'N' */ + + dtrsm_("R", "L", "N", diag, m, &n2, alpha, &a[1], &n1, + &b[n1 * b_dim1], ldb); + dgemm_("N", "T", m, &n1, &n2, &c_b23, &b[n1 * b_dim1], + ldb, &a[n1 * n1], &n1, alpha, b, ldb); + dtrsm_("R", "U", "T", diag, m, &n1, &c_b27, a, &n1, b, + ldb); + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'L', and */ +/* TRANS = 'T' */ + + dtrsm_("R", "U", "N", diag, m, &n1, alpha, a, &n1, b, + ldb); + dgemm_("N", "N", m, &n2, &n1, &c_b23, b, ldb, &a[n1 * + n1], &n1, alpha, &b[n1 * b_dim1], ldb); + dtrsm_("R", "L", "T", diag, m, &n2, &c_b27, &a[1], & + n1, &b[n1 * b_dim1], ldb); + + } + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'T', and UPLO = 'U' */ + + if (notrans) { + +/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and */ +/* TRANS = 'N' */ + + dtrsm_("R", "U", "N", diag, m, &n1, alpha, &a[n2 * n2] + , &n2, b, ldb); + dgemm_("N", "T", m, &n2, &n1, &c_b23, b, ldb, a, &n2, + alpha, &b[n1 * b_dim1], ldb); + dtrsm_("R", "L", "T", diag, m, &n2, &c_b27, &a[n1 * + n2], &n2, &b[n1 * b_dim1], ldb); + + } else { + +/* SIDE ='R', N is odd, TRANSR = 'T', UPLO = 'U', and */ +/* TRANS = 'T' */ + + dtrsm_("R", "L", "N", diag, m, &n2, alpha, &a[n1 * n2] + , &n2, &b[n1 * b_dim1], ldb); + dgemm_("N", "N", m, &n1, &n2, &c_b23, &b[n1 * b_dim1], + ldb, a, &n2, alpha, b, ldb); + dtrsm_("R", "U", "T", diag, m, &n1, &c_b27, &a[n2 * + n2], &n2, b, ldb); + + } + + } + + } + + } else { + +/* SIDE = 'R' and N is even */ + + if (normaltransr) { + +/* SIDE = 'R', N is even, and TRANSR = 'N' */ + + if (lower) { + +/* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', */ +/* and TRANS = 'N' */ + + i__1 = *n + 1; + dtrsm_("R", "U", "T", diag, m, &k, alpha, a, &i__1, & + b[k * b_dim1], ldb); + i__1 = *n + 1; + dgemm_("N", "N", m, &k, &k, &c_b23, &b[k * b_dim1], + ldb, &a[k + 1], &i__1, alpha, b, ldb); + i__1 = *n + 1; + dtrsm_("R", "L", "N", diag, m, &k, &c_b27, &a[1], & + i__1, b, ldb); + + } else { + +/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'L', */ +/* and TRANS = 'T' */ + + i__1 = *n + 1; + dtrsm_("R", "L", "T", diag, m, &k, alpha, &a[1], & + i__1, b, ldb); + i__1 = *n + 1; + dgemm_("N", "T", m, &k, &k, &c_b23, b, ldb, &a[k + 1], + &i__1, alpha, &b[k * b_dim1], ldb); + i__1 = *n + 1; + dtrsm_("R", "U", "N", diag, m, &k, &c_b27, a, &i__1, & + b[k * b_dim1], ldb); + + } + + } else { + +/* SIDE ='R', N is even, TRANSR = 'N', and UPLO = 'U' */ + + if (notrans) { + +/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', */ +/* and TRANS = 'N' */ + + i__1 = *n + 1; + dtrsm_("R", "L", "T", diag, m, &k, alpha, &a[k + 1], & + i__1, b, ldb); + i__1 = *n + 1; + dgemm_("N", "N", m, &k, &k, &c_b23, b, ldb, a, &i__1, + alpha, &b[k * b_dim1], ldb); + i__1 = *n + 1; + dtrsm_("R", "U", "N", diag, m, &k, &c_b27, &a[k], & + i__1, &b[k * b_dim1], ldb); + + } else { + +/* SIDE ='R', N is even, TRANSR = 'N', UPLO = 'U', */ +/* and TRANS = 'T' */ + + i__1 = *n + 1; + dtrsm_("R", "U", "T", diag, m, &k, alpha, &a[k], & + i__1, &b[k * b_dim1], ldb); + i__1 = *n + 1; + dgemm_("N", "T", m, &k, &k, &c_b23, &b[k * b_dim1], + ldb, a, &i__1, alpha, b, ldb); + i__1 = *n + 1; + dtrsm_("R", "L", "N", diag, m, &k, &c_b27, &a[k + 1], + &i__1, b, ldb); + + } + + } + + } else { + +/* SIDE = 'R', N is even, and TRANSR = 'T' */ + + if (lower) { + +/* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'L' */ + + if (notrans) { + +/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', */ +/* and TRANS = 'N' */ + + dtrsm_("R", "L", "N", diag, m, &k, alpha, a, &k, &b[k + * b_dim1], ldb); + dgemm_("N", "T", m, &k, &k, &c_b23, &b[k * b_dim1], + ldb, &a[(k + 1) * k], &k, alpha, b, ldb); + dtrsm_("R", "U", "T", diag, m, &k, &c_b27, &a[k], &k, + b, ldb); + + } else { + +/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'L', */ +/* and TRANS = 'T' */ + + dtrsm_("R", "U", "N", diag, m, &k, alpha, &a[k], &k, + b, ldb); + dgemm_("N", "N", m, &k, &k, &c_b23, b, ldb, &a[(k + 1) + * k], &k, alpha, &b[k * b_dim1], ldb); + dtrsm_("R", "L", "T", diag, m, &k, &c_b27, a, &k, &b[ + k * b_dim1], ldb); + + } + + } else { + +/* SIDE ='R', N is even, TRANSR = 'T', and UPLO = 'U' */ + + if (notrans) { + +/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', */ +/* and TRANS = 'N' */ + + dtrsm_("R", "U", "N", diag, m, &k, alpha, &a[(k + 1) * + k], &k, b, ldb); + dgemm_("N", "T", m, &k, &k, &c_b23, b, ldb, a, &k, + alpha, &b[k * b_dim1], ldb); + dtrsm_("R", "L", "T", diag, m, &k, &c_b27, &a[k * k], + &k, &b[k * b_dim1], ldb); + + } else { + +/* SIDE ='R', N is even, TRANSR = 'T', UPLO = 'U', */ +/* and TRANS = 'T' */ + + dtrsm_("R", "L", "N", diag, m, &k, alpha, &a[k * k], & + k, &b[k * b_dim1], ldb); + dgemm_("N", "N", m, &k, &k, &c_b23, &b[k * b_dim1], + ldb, a, &k, alpha, b, ldb); + dtrsm_("R", "U", "T", diag, m, &k, &c_b27, &a[(k + 1) + * k], &k, b, ldb); + + } + + } + + } + + } + } + + return 0; + +/* End of DTFSM */ + +} /* dtfsm_ */ + diff --git a/lapack-netlib/SRC/dtftri.c b/lapack-netlib/SRC/dtftri.c new file mode 100644 index 000000000..48a28a029 --- /dev/null +++ b/lapack-netlib/SRC/dtftri.c @@ -0,0 +1,898 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTFTRI */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTFTRI + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTFTRI( TRANSR, UPLO, DIAG, N, A, INFO ) */ + +/* CHARACTER TRANSR, UPLO, DIAG */ +/* INTEGER INFO, N */ +/* DOUBLE PRECISION A( 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTFTRI computes the inverse of a triangular matrix A stored in RFP */ +/* > format. */ +/* > */ +/* > This is a Level 3 BLAS version of the algorithm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER*1 */ +/* > = 'N': The Normal TRANSR of RFP A is stored; */ +/* > = 'T': The Transpose TRANSR of RFP A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (0:nt-1); */ +/* > nt=N*(N+1)/2. On entry, the triangular factor of a Hermitian */ +/* > Positive Definite matrix A in RFP format. RFP format is */ +/* > described by TRANSR, UPLO, and N as follows: If TRANSR = 'N' */ +/* > then RFP A is (0:N,0:k-1) when N is even; k=N/2. RFP A is */ +/* > (0:N-1,0:k) when N is odd; k=N/2. IF TRANSR = 'T' then RFP is */ +/* > the transpose of RFP A as defined when */ +/* > TRANSR = 'N'. The contents of RFP A are defined by UPLO as */ +/* > follows: If UPLO = 'U' the RFP A contains the nt elements of */ +/* > upper packed A; If UPLO = 'L' the RFP A contains the nt */ +/* > elements of lower packed A. The LDA of RFP A is (N+1)/2 when */ +/* > TRANSR = 'T'. When TRANSR is 'N' the LDA is N+1 when N is */ +/* > even and N is odd. See the Note below for more details. */ +/* > */ +/* > On exit, the (triangular) inverse of the original matrix, in */ +/* > the same storage format. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, A(i,i) is exactly zero. The triangular */ +/* > matrix is singular and its inverse can not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > We first consider Rectangular Full Packed (RFP) Format when N is */ +/* > even. We give an example where N = 6. */ +/* > */ +/* > AP is Upper AP is Lower */ +/* > */ +/* > 00 01 02 03 04 05 00 */ +/* > 11 12 13 14 15 10 11 */ +/* > 22 23 24 25 20 21 22 */ +/* > 33 34 35 30 31 32 33 */ +/* > 44 45 40 41 42 43 44 */ +/* > 55 50 51 52 53 54 55 */ +/* > */ +/* > */ +/* > Let TRANSR = 'N'. RFP holds AP as follows: */ +/* > For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ +/* > three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ +/* > the transpose of the first three columns of AP upper. */ +/* > For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ +/* > three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ +/* > the transpose of the last three columns of AP lower. */ +/* > This covers the case N even and TRANSR = 'N'. */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 03 04 05 33 43 53 */ +/* > 13 14 15 00 44 54 */ +/* > 23 24 25 10 11 55 */ +/* > 33 34 35 20 21 22 */ +/* > 00 44 45 30 31 32 */ +/* > 01 11 55 40 41 42 */ +/* > 02 12 22 50 51 52 */ +/* > */ +/* > Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* > transpose of RFP A above. One therefore gets: */ +/* > */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ +/* > 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ +/* > 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ +/* > */ +/* > */ +/* > We then consider Rectangular Full Packed (RFP) Format when N is */ +/* > odd. We give an example where N = 5. */ +/* > */ +/* > AP is Upper AP is Lower */ +/* > */ +/* > 00 01 02 03 04 00 */ +/* > 11 12 13 14 10 11 */ +/* > 22 23 24 20 21 22 */ +/* > 33 34 30 31 32 33 */ +/* > 44 40 41 42 43 44 */ +/* > */ +/* > */ +/* > Let TRANSR = 'N'. RFP holds AP as follows: */ +/* > For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ +/* > three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ +/* > the transpose of the first two columns of AP upper. */ +/* > For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ +/* > three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ +/* > the transpose of the last two columns of AP lower. */ +/* > This covers the case N odd and TRANSR = 'N'. */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 02 03 04 00 33 43 */ +/* > 12 13 14 10 11 44 */ +/* > 22 23 24 20 21 22 */ +/* > 00 33 34 30 31 32 */ +/* > 01 11 44 40 41 42 */ +/* > */ +/* > Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* > transpose of RFP A above. One therefore gets: */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 02 12 22 00 01 00 10 20 30 40 50 */ +/* > 03 13 23 33 11 33 11 21 31 41 51 */ +/* > 04 14 24 34 44 43 44 22 32 42 52 */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtftri_(char *transr, char *uplo, char *diag, integer *n, + doublereal *a, integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer k; + logical normaltransr; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + logical lower; + integer n1, n2; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical nisodd; + extern /* Subroutine */ int dtrtri_(char *, char *, integer *, doublereal + *, integer *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + *info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + if (! normaltransr && ! lsame_(transr, "T")) { + *info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + *info = -2; + } else if (! lsame_(diag, "N") && ! lsame_(diag, + "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTFTRI", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* If N is odd, set NISODD = .TRUE. */ +/* If N is even, set K = N/2 and NISODD = .FALSE. */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = FALSE_; + } else { + nisodd = TRUE_; + } + +/* Set N1 and N2 depending on LOWER */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + + +/* start execution: there are eight cases */ + + if (nisodd) { + +/* N is odd */ + + if (normaltransr) { + +/* N is odd and TRANSR = 'N' */ + + if (lower) { + +/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */ +/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */ +/* T1 -> a(0), T2 -> a(n), S -> a(n1) */ + + dtrtri_("L", diag, &n1, a, n, info); + if (*info > 0) { + return 0; + } + dtrmm_("R", "L", "N", diag, &n2, &n1, &c_b13, a, n, &a[n1], n); + dtrtri_("U", diag, &n2, &a[*n], n, info) + ; + if (*info > 0) { + *info += n1; + } + if (*info > 0) { + return 0; + } + dtrmm_("L", "U", "T", diag, &n2, &n1, &c_b18, &a[*n], n, &a[ + n1], n); + + } else { + +/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */ +/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */ +/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */ + + dtrtri_("L", diag, &n1, &a[n2], n, info) + ; + if (*info > 0) { + return 0; + } + dtrmm_("L", "L", "T", diag, &n1, &n2, &c_b13, &a[n2], n, a, n); + dtrtri_("U", diag, &n2, &a[n1], n, info) + ; + if (*info > 0) { + *info += n1; + } + if (*info > 0) { + return 0; + } + dtrmm_("R", "U", "N", diag, &n1, &n2, &c_b18, &a[n1], n, a, n); + + } + + } else { + +/* N is odd and TRANSR = 'T' */ + + if (lower) { + +/* SRPA for LOWER, TRANSPOSE and N is odd */ +/* T1 -> a(0), T2 -> a(1), S -> a(0+n1*n1) */ + + dtrtri_("U", diag, &n1, a, &n1, info); + if (*info > 0) { + return 0; + } + dtrmm_("L", "U", "N", diag, &n1, &n2, &c_b13, a, &n1, &a[n1 * + n1], &n1); + dtrtri_("L", diag, &n2, &a[1], &n1, info); + if (*info > 0) { + *info += n1; + } + if (*info > 0) { + return 0; + } + dtrmm_("R", "L", "T", diag, &n1, &n2, &c_b18, &a[1], &n1, &a[ + n1 * n1], &n1); + + } else { + +/* SRPA for UPPER, TRANSPOSE and N is odd */ +/* T1 -> a(0+n2*n2), T2 -> a(0+n1*n2), S -> a(0) */ + + dtrtri_("U", diag, &n1, &a[n2 * n2], &n2, info); + if (*info > 0) { + return 0; + } + dtrmm_("R", "U", "T", diag, &n2, &n1, &c_b13, &a[n2 * n2], & + n2, a, &n2); + dtrtri_("L", diag, &n2, &a[n1 * n2], &n2, info); + if (*info > 0) { + *info += n1; + } + if (*info > 0) { + return 0; + } + dtrmm_("L", "L", "N", diag, &n2, &n1, &c_b18, &a[n1 * n2], & + n2, a, &n2); + } + + } + + } else { + +/* N is even */ + + if (normaltransr) { + +/* N is even and TRANSR = 'N' */ + + if (lower) { + +/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ +/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */ +/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */ + + i__1 = *n + 1; + dtrtri_("L", diag, &k, &a[1], &i__1, info); + if (*info > 0) { + return 0; + } + i__1 = *n + 1; + i__2 = *n + 1; + dtrmm_("R", "L", "N", diag, &k, &k, &c_b13, &a[1], &i__1, &a[ + k + 1], &i__2); + i__1 = *n + 1; + dtrtri_("U", diag, &k, a, &i__1, info); + if (*info > 0) { + *info += k; + } + if (*info > 0) { + return 0; + } + i__1 = *n + 1; + i__2 = *n + 1; + dtrmm_("L", "U", "T", diag, &k, &k, &c_b18, a, &i__1, &a[k + + 1], &i__2) + ; + + } else { + +/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ +/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */ +/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */ + + i__1 = *n + 1; + dtrtri_("L", diag, &k, &a[k + 1], &i__1, info); + if (*info > 0) { + return 0; + } + i__1 = *n + 1; + i__2 = *n + 1; + dtrmm_("L", "L", "T", diag, &k, &k, &c_b13, &a[k + 1], &i__1, + a, &i__2); + i__1 = *n + 1; + dtrtri_("U", diag, &k, &a[k], &i__1, info); + if (*info > 0) { + *info += k; + } + if (*info > 0) { + return 0; + } + i__1 = *n + 1; + i__2 = *n + 1; + dtrmm_("R", "U", "N", diag, &k, &k, &c_b18, &a[k], &i__1, a, & + i__2); + } + } else { + +/* N is even and TRANSR = 'T' */ + + if (lower) { + +/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */ +/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */ +/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */ + + dtrtri_("U", diag, &k, &a[k], &k, info); + if (*info > 0) { + return 0; + } + dtrmm_("L", "U", "N", diag, &k, &k, &c_b13, &a[k], &k, &a[k * + (k + 1)], &k); + dtrtri_("L", diag, &k, a, &k, info); + if (*info > 0) { + *info += k; + } + if (*info > 0) { + return 0; + } + dtrmm_("R", "L", "T", diag, &k, &k, &c_b18, a, &k, &a[k * (k + + 1)], &k) + ; + } else { + +/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */ +/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */ +/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */ + + dtrtri_("U", diag, &k, &a[k * (k + 1)], &k, info); + if (*info > 0) { + return 0; + } + dtrmm_("R", "U", "T", diag, &k, &k, &c_b13, &a[k * (k + 1)], & + k, a, &k); + dtrtri_("L", diag, &k, &a[k * k], &k, info); + if (*info > 0) { + *info += k; + } + if (*info > 0) { + return 0; + } + dtrmm_("L", "L", "N", diag, &k, &k, &c_b18, &a[k * k], &k, a, + &k); + } + } + } + + return 0; + +/* End of DTFTRI */ + +} /* dtftri_ */ + diff --git a/lapack-netlib/SRC/dtfttp.c b/lapack-netlib/SRC/dtfttp.c new file mode 100644 index 000000000..afda65409 --- /dev/null +++ b/lapack-netlib/SRC/dtfttp.c @@ -0,0 +1,941 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTFTTP copies a triangular matrix from the rectangular full packed format (TF) to the standard +packed format (TP). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTFTTP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTFTTP( TRANSR, UPLO, N, ARF, AP, INFO ) */ + +/* CHARACTER TRANSR, UPLO */ +/* INTEGER INFO, N */ +/* DOUBLE PRECISION AP( 0: * ), ARF( 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTFTTP copies a triangular matrix A from rectangular full packed */ +/* > format (TF) to standard packed format (TP). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER*1 */ +/* > = 'N': ARF is in Normal format; */ +/* > = 'T': ARF is in Transpose format; */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ARF */ +/* > \verbatim */ +/* > ARF is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */ +/* > On entry, the upper or lower triangular matrix A stored in */ +/* > RFP format. For a further discussion see Notes below. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] AP */ +/* > \verbatim */ +/* > AP is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */ +/* > On exit, the upper or lower triangular matrix A, packed */ +/* > columnwise in a linear array. The j-th column of A is stored */ +/* > in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > We first consider Rectangular Full Packed (RFP) Format when N is */ +/* > even. We give an example where N = 6. */ +/* > */ +/* > AP is Upper AP is Lower */ +/* > */ +/* > 00 01 02 03 04 05 00 */ +/* > 11 12 13 14 15 10 11 */ +/* > 22 23 24 25 20 21 22 */ +/* > 33 34 35 30 31 32 33 */ +/* > 44 45 40 41 42 43 44 */ +/* > 55 50 51 52 53 54 55 */ +/* > */ +/* > */ +/* > Let TRANSR = 'N'. RFP holds AP as follows: */ +/* > For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ +/* > three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ +/* > the transpose of the first three columns of AP upper. */ +/* > For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ +/* > three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ +/* > the transpose of the last three columns of AP lower. */ +/* > This covers the case N even and TRANSR = 'N'. */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 03 04 05 33 43 53 */ +/* > 13 14 15 00 44 54 */ +/* > 23 24 25 10 11 55 */ +/* > 33 34 35 20 21 22 */ +/* > 00 44 45 30 31 32 */ +/* > 01 11 55 40 41 42 */ +/* > 02 12 22 50 51 52 */ +/* > */ +/* > Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* > transpose of RFP A above. One therefore gets: */ +/* > */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ +/* > 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ +/* > 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ +/* > */ +/* > */ +/* > We then consider Rectangular Full Packed (RFP) Format when N is */ +/* > odd. We give an example where N = 5. */ +/* > */ +/* > AP is Upper AP is Lower */ +/* > */ +/* > 00 01 02 03 04 00 */ +/* > 11 12 13 14 10 11 */ +/* > 22 23 24 20 21 22 */ +/* > 33 34 30 31 32 33 */ +/* > 44 40 41 42 43 44 */ +/* > */ +/* > */ +/* > Let TRANSR = 'N'. RFP holds AP as follows: */ +/* > For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ +/* > three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ +/* > the transpose of the first two columns of AP upper. */ +/* > For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ +/* > three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ +/* > the transpose of the last two columns of AP lower. */ +/* > This covers the case N odd and TRANSR = 'N'. */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 02 03 04 00 33 43 */ +/* > 12 13 14 10 11 44 */ +/* > 22 23 24 20 21 22 */ +/* > 00 33 34 30 31 32 */ +/* > 01 11 44 40 41 42 */ +/* > */ +/* > Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* > transpose of RFP A above. One therefore gets: */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 02 12 22 00 01 00 10 20 30 40 50 */ +/* > 03 13 23 33 11 33 11 21 31 41 51 */ +/* > 04 14 24 34 44 43 44 22 32 42 52 */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtfttp_(char *transr, char *uplo, integer *n, doublereal + *arf, doublereal *ap, integer *info) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, k; + logical normaltransr; + extern logical lsame_(char *, char *); + logical lower; + integer n1, n2, ij, jp, js, nt; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical nisodd; + integer lda, ijp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + *info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + if (! normaltransr && ! lsame_(transr, "T")) { + *info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTFTTP", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (normaltransr) { + ap[0] = arf[0]; + } else { + ap[0] = arf[0]; + } + return 0; + } + +/* Size of array ARF(0:NT-1) */ + + nt = *n * (*n + 1) / 2; + +/* Set N1 and N2 depending on LOWER */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + +/* If N is odd, set NISODD = .TRUE. */ +/* If N is even, set K = N/2 and NISODD = .FALSE. */ + +/* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) */ +/* where noe = 0 if n is even, noe = 1 if n is odd */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = FALSE_; + lda = *n + 1; + } else { + nisodd = TRUE_; + lda = *n; + } + +/* ARF^C has lda rows and n+1-noe cols */ + + if (! normaltransr) { + lda = (*n + 1) / 2; + } + +/* start execution: there are eight cases */ + + if (nisodd) { + +/* N is odd */ + + if (normaltransr) { + +/* N is odd and TRANSR = 'N' */ + + if (lower) { + +/* SRPA for LOWER, NORMAL and N is odd ( a(0:n-1,0:n1-1) ) */ +/* T1 -> a(0,0), T2 -> a(0,1), S -> a(n1,0) */ +/* T1 -> a(0), T2 -> a(n), S -> a(n1); lda = n */ + + ijp = 0; + jp = 0; + i__1 = n2; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + ij = i__ + jp; + ap[ijp] = arf[ij]; + ++ijp; + } + jp += lda; + } + i__1 = n2 - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = n2; + for (j = i__ + 1; j <= i__2; ++j) { + ij = i__ + j * lda; + ap[ijp] = arf[ij]; + ++ijp; + } + } + + } else { + +/* SRPA for UPPER, NORMAL and N is odd ( a(0:n-1,0:n2-1) */ +/* T1 -> a(n1+1,0), T2 -> a(n1,0), S -> a(0,0) */ +/* T1 -> a(n2), T2 -> a(n1), S -> a(0) */ + + ijp = 0; + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + ij = n2 + j; + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + ap[ijp] = arf[ij]; + ++ijp; + ij += lda; + } + } + js = 0; + i__1 = *n - 1; + for (j = n1; j <= i__1; ++j) { + ij = js; + i__2 = js + j; + for (ij = js; ij <= i__2; ++ij) { + ap[ijp] = arf[ij]; + ++ijp; + } + js += lda; + } + + } + + } else { + +/* N is odd and TRANSR = 'T' */ + + if (lower) { + +/* SRPA for LOWER, TRANSPOSE and N is odd */ +/* T1 -> A(0,0) , T2 -> A(1,0) , S -> A(0,n1) */ +/* T1 -> a(0+0) , T2 -> a(1+0) , S -> a(0+n1*n1); lda=n1 */ + + ijp = 0; + i__1 = n2; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = *n * lda - 1; + i__3 = lda; + for (ij = i__ * (lda + 1); i__3 < 0 ? ij >= i__2 : ij <= + i__2; ij += i__3) { + ap[ijp] = arf[ij]; + ++ijp; + } + } + js = 1; + i__1 = n2 - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + n2 - j - 1; + for (ij = js; ij <= i__3; ++ij) { + ap[ijp] = arf[ij]; + ++ijp; + } + js = js + lda + 1; + } + + } else { + +/* SRPA for UPPER, TRANSPOSE and N is odd */ +/* T1 -> A(0,n1+1), T2 -> A(0,n1), S -> A(0,0) */ +/* T1 -> a(n2*n2), T2 -> a(n1*n2), S -> a(0); lda = n2 */ + + ijp = 0; + js = n2 * lda; + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + j; + for (ij = js; ij <= i__3; ++ij) { + ap[ijp] = arf[ij]; + ++ijp; + } + js += lda; + } + i__1 = n1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__3 = i__ + (n1 + i__) * lda; + i__2 = lda; + for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij += + i__2) { + ap[ijp] = arf[ij]; + ++ijp; + } + } + + } + + } + + } else { + +/* N is even */ + + if (normaltransr) { + +/* N is even and TRANSR = 'N' */ + + if (lower) { + +/* SRPA for LOWER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ +/* T1 -> a(1,0), T2 -> a(0,0), S -> a(k+1,0) */ +/* T1 -> a(1), T2 -> a(0), S -> a(k+1) */ + + ijp = 0; + jp = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + ij = i__ + 1 + jp; + ap[ijp] = arf[ij]; + ++ijp; + } + jp += lda; + } + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = k - 1; + for (j = i__; j <= i__2; ++j) { + ij = i__ + j * lda; + ap[ijp] = arf[ij]; + ++ijp; + } + } + + } else { + +/* SRPA for UPPER, NORMAL, and N is even ( a(0:n,0:k-1) ) */ +/* T1 -> a(k+1,0) , T2 -> a(k,0), S -> a(0,0) */ +/* T1 -> a(k+1), T2 -> a(k), S -> a(0) */ + + ijp = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + ij = k + 1 + j; + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + ap[ijp] = arf[ij]; + ++ijp; + ij += lda; + } + } + js = 0; + i__1 = *n - 1; + for (j = k; j <= i__1; ++j) { + ij = js; + i__2 = js + j; + for (ij = js; ij <= i__2; ++ij) { + ap[ijp] = arf[ij]; + ++ijp; + } + js += lda; + } + + } + + } else { + +/* N is even and TRANSR = 'T' */ + + if (lower) { + +/* SRPA for LOWER, TRANSPOSE and N is even (see paper) */ +/* T1 -> B(0,1), T2 -> B(0,0), S -> B(0,k+1) */ +/* T1 -> a(0+k), T2 -> a(0+0), S -> a(0+k*(k+1)); lda=k */ + + ijp = 0; + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = (*n + 1) * lda - 1; + i__3 = lda; + for (ij = i__ + (i__ + 1) * lda; i__3 < 0 ? ij >= i__2 : + ij <= i__2; ij += i__3) { + ap[ijp] = arf[ij]; + ++ijp; + } + } + js = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + k - j - 1; + for (ij = js; ij <= i__3; ++ij) { + ap[ijp] = arf[ij]; + ++ijp; + } + js = js + lda + 1; + } + + } else { + +/* SRPA for UPPER, TRANSPOSE and N is even (see paper) */ +/* T1 -> B(0,k+1), T2 -> B(0,k), S -> B(0,0) */ +/* T1 -> a(0+k*(k+1)), T2 -> a(0+k*k), S -> a(0+0)); lda=k */ + + ijp = 0; + js = (k + 1) * lda; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + j; + for (ij = js; ij <= i__3; ++ij) { + ap[ijp] = arf[ij]; + ++ijp; + } + js += lda; + } + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__3 = i__ + (k + i__) * lda; + i__2 = lda; + for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij += + i__2) { + ap[ijp] = arf[ij]; + ++ijp; + } + } + + } + + } + + } + + return 0; + +/* End of DTFTTP */ + +} /* dtfttp_ */ + diff --git a/lapack-netlib/SRC/dtfttr.c b/lapack-netlib/SRC/dtfttr.c new file mode 100644 index 000000000..48d6b5637 --- /dev/null +++ b/lapack-netlib/SRC/dtfttr.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 DTFTTR copies a triangular matrix from the rectangular full packed format (TF) to the standard +full format (TR). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTFTTR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTFTTR( TRANSR, UPLO, N, ARF, A, LDA, INFO ) */ + +/* CHARACTER TRANSR, UPLO */ +/* INTEGER INFO, N, LDA */ +/* DOUBLE PRECISION A( 0: LDA-1, 0: * ), ARF( 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTFTTR copies a triangular matrix A from rectangular full packed */ +/* > format (TF) to standard full format (TR). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER*1 */ +/* > = 'N': ARF is in Normal format; */ +/* > = 'T': ARF is in Transpose format. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices ARF and A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ARF */ +/* > \verbatim */ +/* > ARF is DOUBLE PRECISION array, dimension (N*(N+1)/2). */ +/* > On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L') */ +/* > matrix A in RFP format. See the "Notes" below for more */ +/* > details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On exit, the triangular matrix A. If UPLO = 'U', the */ +/* > leading N-by-N upper triangular part of the array A contains */ +/* > the upper triangular matrix, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of the array A contains */ +/* > the lower triangular matrix, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > We first consider Rectangular Full Packed (RFP) Format when N is */ +/* > even. We give an example where N = 6. */ +/* > */ +/* > AP is Upper AP is Lower */ +/* > */ +/* > 00 01 02 03 04 05 00 */ +/* > 11 12 13 14 15 10 11 */ +/* > 22 23 24 25 20 21 22 */ +/* > 33 34 35 30 31 32 33 */ +/* > 44 45 40 41 42 43 44 */ +/* > 55 50 51 52 53 54 55 */ +/* > */ +/* > */ +/* > Let TRANSR = 'N'. RFP holds AP as follows: */ +/* > For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ +/* > three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ +/* > the transpose of the first three columns of AP upper. */ +/* > For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ +/* > three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ +/* > the transpose of the last three columns of AP lower. */ +/* > This covers the case N even and TRANSR = 'N'. */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 03 04 05 33 43 53 */ +/* > 13 14 15 00 44 54 */ +/* > 23 24 25 10 11 55 */ +/* > 33 34 35 20 21 22 */ +/* > 00 44 45 30 31 32 */ +/* > 01 11 55 40 41 42 */ +/* > 02 12 22 50 51 52 */ +/* > */ +/* > Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* > transpose of RFP A above. One therefore gets: */ +/* > */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ +/* > 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ +/* > 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ +/* > */ +/* > */ +/* > We then consider Rectangular Full Packed (RFP) Format when N is */ +/* > odd. We give an example where N = 5. */ +/* > */ +/* > AP is Upper AP is Lower */ +/* > */ +/* > 00 01 02 03 04 00 */ +/* > 11 12 13 14 10 11 */ +/* > 22 23 24 20 21 22 */ +/* > 33 34 30 31 32 33 */ +/* > 44 40 41 42 43 44 */ +/* > */ +/* > */ +/* > Let TRANSR = 'N'. RFP holds AP as follows: */ +/* > For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ +/* > three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ +/* > the transpose of the first two columns of AP upper. */ +/* > For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ +/* > three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ +/* > the transpose of the last two columns of AP lower. */ +/* > This covers the case N odd and TRANSR = 'N'. */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 02 03 04 00 33 43 */ +/* > 12 13 14 10 11 44 */ +/* > 22 23 24 20 21 22 */ +/* > 00 33 34 30 31 32 */ +/* > 01 11 44 40 41 42 */ +/* > */ +/* > Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* > transpose of RFP A above. One therefore gets: */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 02 12 22 00 01 00 10 20 30 40 50 */ +/* > 03 13 23 33 11 33 11 21 31 41 51 */ +/* > 04 14 24 34 44 43 44 22 32 42 52 */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dtfttr_(char *transr, char *uplo, integer *n, doublereal + *arf, doublereal *a, integer *lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer np1x2, i__, j, k, l; + logical normaltransr; + extern logical lsame_(char *, char *); + logical lower; + integer n1, n2, ij, nt; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical nisodd; + integer nx2; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda - 1 - 0 + 1; + a_offset = 0 + a_dim1 * 0; + a -= a_offset; + + /* Function Body */ + *info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + if (! normaltransr && ! lsame_(transr, "T")) { + *info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTFTTR", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 1) { + if (*n == 1) { + a[0] = arf[0]; + } + return 0; + } + +/* Size of array ARF(0:nt-1) */ + + nt = *n * (*n + 1) / 2; + +/* set N1 and N2 depending on LOWER: for N even N1=N2=K */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + +/* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. */ +/* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is */ +/* N--by--(N+1)/2. */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = FALSE_; + if (! lower) { + np1x2 = *n + *n + 2; + } + } else { + nisodd = TRUE_; + if (! lower) { + nx2 = *n + *n; + } + } + + if (nisodd) { + +/* N is odd */ + + if (normaltransr) { + +/* N is odd and TRANSR = 'N' */ + + if (lower) { + +/* N is odd, TRANSR = 'N', and UPLO = 'L' */ + + ij = 0; + i__1 = n2; + for (j = 0; j <= i__1; ++j) { + i__2 = n2 + j; + for (i__ = n1; i__ <= i__2; ++i__) { + a[n2 + j + i__ * a_dim1] = arf[ij]; + ++ij; + } + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + } + + } else { + +/* N is odd, TRANSR = 'N', and UPLO = 'U' */ + + ij = nt - *n; + i__1 = n1; + for (j = *n - 1; j >= i__1; --j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + i__2 = n1 - 1; + for (l = j - n1; l <= i__2; ++l) { + a[j - n1 + l * a_dim1] = arf[ij]; + ++ij; + } + ij -= nx2; + } + + } + + } else { + +/* N is odd and TRANSR = 'T' */ + + if (lower) { + +/* N is odd, TRANSR = 'T', and UPLO = 'L' */ + + ij = 0; + i__1 = n2 - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + a[j + i__ * a_dim1] = arf[ij]; + ++ij; + } + i__2 = *n - 1; + for (i__ = n1 + j; i__ <= i__2; ++i__) { + a[i__ + (n1 + j) * a_dim1] = arf[ij]; + ++ij; + } + } + i__1 = *n - 1; + for (j = n2; j <= i__1; ++j) { + i__2 = n1 - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + a[j + i__ * a_dim1] = arf[ij]; + ++ij; + } + } + + } else { + +/* N is odd, TRANSR = 'T', and UPLO = 'U' */ + + ij = 0; + i__1 = n1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = n1; i__ <= i__2; ++i__) { + a[j + i__ * a_dim1] = arf[ij]; + ++ij; + } + } + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + i__2 = *n - 1; + for (l = n2 + j; l <= i__2; ++l) { + a[n2 + j + l * a_dim1] = arf[ij]; + ++ij; + } + } + + } + + } + + } else { + +/* N is even */ + + if (normaltransr) { + +/* N is even and TRANSR = 'N' */ + + if (lower) { + +/* N is even, TRANSR = 'N', and UPLO = 'L' */ + + ij = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = k + j; + for (i__ = k; i__ <= i__2; ++i__) { + a[k + j + i__ * a_dim1] = arf[ij]; + ++ij; + } + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + } + + } else { + +/* N is even, TRANSR = 'N', and UPLO = 'U' */ + + ij = nt - *n - 1; + i__1 = k; + for (j = *n - 1; j >= i__1; --j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + i__2 = k - 1; + for (l = j - k; l <= i__2; ++l) { + a[j - k + l * a_dim1] = arf[ij]; + ++ij; + } + ij -= np1x2; + } + + } + + } else { + +/* N is even and TRANSR = 'T' */ + + if (lower) { + +/* N is even, TRANSR = 'T', and UPLO = 'L' */ + + ij = 0; + j = k; + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + a[j + i__ * a_dim1] = arf[ij]; + ++ij; + } + i__2 = *n - 1; + for (i__ = k + 1 + j; i__ <= i__2; ++i__) { + a[i__ + (k + 1 + j) * a_dim1] = arf[ij]; + ++ij; + } + } + i__1 = *n - 1; + for (j = k - 1; j <= i__1; ++j) { + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + a[j + i__ * a_dim1] = arf[ij]; + ++ij; + } + } + + } else { + +/* N is even, TRANSR = 'T', and UPLO = 'U' */ + + ij = 0; + i__1 = k; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = k; i__ <= i__2; ++i__) { + a[j + i__ * a_dim1] = arf[ij]; + ++ij; + } + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + i__2 = *n - 1; + for (l = k + 1 + j; l <= i__2; ++l) { + a[k + 1 + j + l * a_dim1] = arf[ij]; + ++ij; + } + } +/* Note that here, on exit of the loop, J = K-1 */ + i__1 = j; + for (i__ = 0; i__ <= i__1; ++i__) { + a[i__ + j * a_dim1] = arf[ij]; + ++ij; + } + + } + + } + + } + + return 0; + +/* End of DTFTTR */ + +} /* dtfttr_ */ + diff --git a/lapack-netlib/SRC/dtgevc.c b/lapack-netlib/SRC/dtgevc.c new file mode 100644 index 000000000..3508d24be --- /dev/null +++ b/lapack-netlib/SRC/dtgevc.c @@ -0,0 +1,1846 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTGEVC */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTGEVC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL, */ +/* LDVL, VR, LDVR, MM, M, WORK, INFO ) */ + +/* CHARACTER HOWMNY, SIDE */ +/* INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N */ +/* LOGICAL SELECT( * ) */ +/* DOUBLE PRECISION P( LDP, * ), S( LDS, * ), VL( LDVL, * ), */ +/* $ VR( LDVR, * ), WORK( * ) */ + + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTGEVC computes some or all of the right and/or left eigenvectors of */ +/* > a pair of real matrices (S,P), where S is a quasi-triangular matrix */ +/* > and P is upper triangular. Matrix pairs of this type are produced by */ +/* > the generalized Schur factorization of a matrix pair (A,B): */ +/* > */ +/* > A = Q*S*Z**T, B = Q*P*Z**T */ +/* > */ +/* > as computed by DGGHRD + DHGEQZ. */ +/* > */ +/* > The right eigenvector x and the left eigenvector y of (S,P) */ +/* > corresponding to an eigenvalue w are defined by: */ +/* > */ +/* > S*x = w*P*x, (y**H)*S = w*(y**H)*P, */ +/* > */ +/* > where y**H denotes the conjugate tranpose of y. */ +/* > The eigenvalues are not input to this routine, but are computed */ +/* > directly from the diagonal blocks of S and P. */ +/* > */ +/* > This routine returns the matrices X and/or Y of right and left */ +/* > eigenvectors of (S,P), or the products Z*X and/or Q*Y, */ +/* > where Z and Q are input matrices. */ +/* > If Q and Z are the orthogonal factors from the generalized Schur */ +/* > factorization of a matrix pair (A,B), then Z*X and Q*Y */ +/* > are the matrices of right and left eigenvectors of (A,B). */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'R': compute right eigenvectors only; */ +/* > = 'L': compute left eigenvectors only; */ +/* > = 'B': compute both right and left eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] HOWMNY */ +/* > \verbatim */ +/* > HOWMNY is CHARACTER*1 */ +/* > = 'A': compute all right and/or left eigenvectors; */ +/* > = 'B': compute all right and/or left eigenvectors, */ +/* > backtransformed by the matrices in VR and/or VL; */ +/* > = 'S': compute selected right and/or left eigenvectors, */ +/* > specified by the logical array SELECT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > If HOWMNY='S', SELECT specifies the eigenvectors to be */ +/* > computed. If w(j) is a real eigenvalue, the corresponding */ +/* > real eigenvector is computed if SELECT(j) is .TRUE.. */ +/* > If w(j) and w(j+1) are the real and imaginary parts of a */ +/* > complex eigenvalue, the corresponding complex eigenvector */ +/* > is computed if either SELECT(j) or SELECT(j+1) is .TRUE., */ +/* > and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is */ +/* > set to .FALSE.. */ +/* > Not referenced if HOWMNY = 'A' or 'B'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices S and P. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] S */ +/* > \verbatim */ +/* > S is DOUBLE PRECISION array, dimension (LDS,N) */ +/* > The upper quasi-triangular matrix S from a generalized Schur */ +/* > factorization, as computed by DHGEQZ. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDS */ +/* > \verbatim */ +/* > LDS is INTEGER */ +/* > The leading dimension of array S. LDS >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is DOUBLE PRECISION array, dimension (LDP,N) */ +/* > The upper triangular matrix P from a generalized Schur */ +/* > factorization, as computed by DHGEQZ. */ +/* > 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks */ +/* > of S must be in positive diagonal form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDP */ +/* > \verbatim */ +/* > LDP is INTEGER */ +/* > The leading dimension of array P. LDP >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VL */ +/* > \verbatim */ +/* > VL is DOUBLE PRECISION array, dimension (LDVL,MM) */ +/* > On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */ +/* > contain an N-by-N matrix Q (usually the orthogonal matrix Q */ +/* > of left Schur vectors returned by DHGEQZ). */ +/* > On exit, if SIDE = 'L' or 'B', VL contains: */ +/* > if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P); */ +/* > if HOWMNY = 'B', the matrix Q*Y; */ +/* > if HOWMNY = 'S', the left eigenvectors of (S,P) specified by */ +/* > SELECT, stored consecutively in the columns of */ +/* > VL, in the same order as their eigenvalues. */ +/* > */ +/* > A complex eigenvector corresponding to a complex eigenvalue */ +/* > is stored in two consecutive columns, the first holding the */ +/* > real part, and the second the imaginary part. */ +/* > */ +/* > Not referenced if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of array VL. LDVL >= 1, and if */ +/* > SIDE = 'L' or 'B', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VR */ +/* > \verbatim */ +/* > VR is DOUBLE PRECISION array, dimension (LDVR,MM) */ +/* > On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */ +/* > contain an N-by-N matrix Z (usually the orthogonal matrix Z */ +/* > of right Schur vectors returned by DHGEQZ). */ +/* > */ +/* > On exit, if SIDE = 'R' or 'B', VR contains: */ +/* > if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P); */ +/* > if HOWMNY = 'B' or 'b', the matrix Z*X; */ +/* > if HOWMNY = 'S' or 's', the right eigenvectors of (S,P) */ +/* > specified by SELECT, stored consecutively in the */ +/* > columns of VR, in the same order as their */ +/* > eigenvalues. */ +/* > */ +/* > A complex eigenvector corresponding to a complex eigenvalue */ +/* > is stored in two consecutive columns, the first holding the */ +/* > real part and the second the imaginary part. */ +/* > */ +/* > Not referenced if SIDE = 'L'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the array VR. LDVR >= 1, and if */ +/* > SIDE = 'R' or 'B', LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MM */ +/* > \verbatim */ +/* > MM is INTEGER */ +/* > The number of columns in the arrays VL and/or VR. MM >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of columns in the arrays VL and/or VR actually */ +/* > used to store the eigenvectors. If HOWMNY = 'A' or 'B', M */ +/* > is set to N. Each selected real eigenvector occupies one */ +/* > column and each selected complex eigenvector occupies two */ +/* > columns. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (6*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex */ +/* > eigenvalue. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleGEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Allocation of workspace: */ +/* > ---------- -- --------- */ +/* > */ +/* > WORK( j ) = 1-norm of j-th column of A, above the diagonal */ +/* > WORK( N+j ) = 1-norm of j-th column of B, above the diagonal */ +/* > WORK( 2*N+1:3*N ) = real part of eigenvector */ +/* > WORK( 3*N+1:4*N ) = imaginary part of eigenvector */ +/* > WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector */ +/* > WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector */ +/* > */ +/* > Rowwise vs. columnwise solution methods: */ +/* > ------- -- ---------- -------- ------- */ +/* > */ +/* > Finding a generalized eigenvector consists basically of solving the */ +/* > singular triangular system */ +/* > */ +/* > (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left) */ +/* > */ +/* > Consider finding the i-th right eigenvector (assume all eigenvalues */ +/* > are real). The equation to be solved is: */ +/* > n i */ +/* > 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1 */ +/* > k=j k=j */ +/* > */ +/* > where C = (A - w B) (The components v(i+1:n) are 0.) */ +/* > */ +/* > The "rowwise" method is: */ +/* > */ +/* > (1) v(i) := 1 */ +/* > for j = i-1,. . .,1: */ +/* > i */ +/* > (2) compute s = - sum C(j,k) v(k) and */ +/* > k=j+1 */ +/* > */ +/* > (3) v(j) := s / C(j,j) */ +/* > */ +/* > Step 2 is sometimes called the "dot product" step, since it is an */ +/* > inner product between the j-th row and the portion of the eigenvector */ +/* > that has been computed so far. */ +/* > */ +/* > The "columnwise" method consists basically in doing the sums */ +/* > for all the rows in parallel. As each v(j) is computed, the */ +/* > contribution of v(j) times the j-th column of C is added to the */ +/* > partial sums. Since FORTRAN arrays are stored columnwise, this has */ +/* > the advantage that at each step, the elements of C that are accessed */ +/* > are adjacent to one another, whereas with the rowwise method, the */ +/* > elements accessed at a step are spaced LDS (and LDP) words apart. */ +/* > */ +/* > When finding left eigenvectors, the matrix in question is the */ +/* > transpose of the one in storage, so the rowwise method then */ +/* > actually accesses columns of A and B at each step, and so is the */ +/* > preferred method. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtgevc_(char *side, char *howmny, logical *select, + integer *n, doublereal *s, integer *lds, doublereal *p, integer *ldp, + doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, integer + *mm, integer *m, doublereal *work, integer *info) +{ + /* System generated locals */ + integer p_dim1, p_offset, s_dim1, s_offset, vl_dim1, vl_offset, vr_dim1, + vr_offset, i__1, i__2, i__3, i__4, i__5; + doublereal d__1, d__2, d__3, d__4, d__5, d__6; + + /* Local variables */ + integer ibeg, ieig, iend; + doublereal dmin__, temp, xmax, sump[4] /* was [2][2] */, sums[4] + /* was [2][2] */; + extern /* Subroutine */ int dlag2_(doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *); + doublereal cim2a, cim2b, cre2a, cre2b, temp2, bdiag[2]; + integer i__, j; + doublereal acoef, scale; + logical ilall; + integer iside; + doublereal sbeta; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *); + logical il2by2; + integer iinfo; + doublereal small; + logical compl; + doublereal anorm, bnorm; + logical compr; + extern /* Subroutine */ int dlaln2_(logical *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, doublereal * + , doublereal *, integer *, doublereal *, doublereal *, integer *); + doublereal temp2i; + extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); + doublereal temp2r; + integer ja; + logical ilabad, ilbbad; + integer jc, je, na; + doublereal acoefa, bcoefa, cimaga, cimagb; + logical ilback; + integer im; + doublereal bcoefi, ascale, bscale, creala; + integer jr; + doublereal crealb; + extern doublereal dlamch_(char *); + doublereal bcoefr; + integer jw, nw; + doublereal salfar, safmin; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *); + doublereal xscale, bignum; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical ilcomp, ilcplx; + integer ihwmny; + doublereal big; + logical lsa, lsb; + doublereal ulp, sum[4] /* was [2][2] */; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + + +/* ===================================================================== */ + + +/* Decode and Test the input parameters */ + + /* Parameter adjustments */ + --select; + s_dim1 = *lds; + s_offset = 1 + s_dim1 * 1; + s -= s_offset; + p_dim1 = *ldp; + p_offset = 1 + p_dim1 * 1; + p -= p_offset; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --work; + + /* Function Body */ + if (lsame_(howmny, "A")) { + ihwmny = 1; + ilall = TRUE_; + ilback = FALSE_; + } else if (lsame_(howmny, "S")) { + ihwmny = 2; + ilall = FALSE_; + ilback = FALSE_; + } else if (lsame_(howmny, "B")) { + ihwmny = 3; + ilall = TRUE_; + ilback = TRUE_; + } else { + ihwmny = -1; + ilall = TRUE_; + } + + if (lsame_(side, "R")) { + iside = 1; + compl = FALSE_; + compr = TRUE_; + } else if (lsame_(side, "L")) { + iside = 2; + compl = TRUE_; + compr = FALSE_; + } else if (lsame_(side, "B")) { + iside = 3; + compl = TRUE_; + compr = TRUE_; + } else { + iside = -1; + } + + *info = 0; + if (iside < 0) { + *info = -1; + } else if (ihwmny < 0) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*lds < f2cmax(1,*n)) { + *info = -6; + } else if (*ldp < f2cmax(1,*n)) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTGEVC", &i__1, (ftnlen)6); + return 0; + } + +/* Count the number of eigenvectors to be computed */ + + if (! ilall) { + im = 0; + ilcplx = FALSE_; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (ilcplx) { + ilcplx = FALSE_; + goto L10; + } + if (j < *n) { + if (s[j + 1 + j * s_dim1] != 0.) { + ilcplx = TRUE_; + } + } + if (ilcplx) { + if (select[j] || select[j + 1]) { + im += 2; + } + } else { + if (select[j]) { + ++im; + } + } +L10: + ; + } + } else { + im = *n; + } + +/* Check 2-by-2 diagonal blocks of A, B */ + + ilabad = FALSE_; + ilbbad = FALSE_; + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { + if (s[j + 1 + j * s_dim1] != 0.) { + if (p[j + j * p_dim1] == 0. || p[j + 1 + (j + 1) * p_dim1] == 0. + || p[j + (j + 1) * p_dim1] != 0.) { + ilbbad = TRUE_; + } + if (j < *n - 1) { + if (s[j + 2 + (j + 1) * s_dim1] != 0.) { + ilabad = TRUE_; + } + } + } +/* L20: */ + } + + if (ilabad) { + *info = -5; + } else if (ilbbad) { + *info = -7; + } else if (compl && *ldvl < *n || *ldvl < 1) { + *info = -10; + } else if (compr && *ldvr < *n || *ldvr < 1) { + *info = -12; + } else if (*mm < im) { + *info = -13; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTGEVC", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + *m = im; + if (*n == 0) { + return 0; + } + +/* Machine Constants */ + + safmin = dlamch_("Safe minimum"); + big = 1. / safmin; + dlabad_(&safmin, &big); + ulp = dlamch_("Epsilon") * dlamch_("Base"); + small = safmin * *n / ulp; + big = 1. / small; + bignum = 1. / (safmin * *n); + +/* Compute the 1-norm of each column of the strictly upper triangular */ +/* part (i.e., excluding all elements belonging to the diagonal */ +/* blocks) of A and B to check for possible overflow in the */ +/* triangular solver. */ + + anorm = (d__1 = s[s_dim1 + 1], abs(d__1)); + if (*n > 1) { + anorm += (d__1 = s[s_dim1 + 2], abs(d__1)); + } + bnorm = (d__1 = p[p_dim1 + 1], abs(d__1)); + work[1] = 0.; + work[*n + 1] = 0.; + + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + temp = 0.; + temp2 = 0.; + if (s[j + (j - 1) * s_dim1] == 0.) { + iend = j - 1; + } else { + iend = j - 2; + } + i__2 = iend; + for (i__ = 1; i__ <= i__2; ++i__) { + temp += (d__1 = s[i__ + j * s_dim1], abs(d__1)); + temp2 += (d__1 = p[i__ + j * p_dim1], abs(d__1)); +/* L30: */ + } + work[j] = temp; + work[*n + j] = temp2; +/* Computing MIN */ + i__3 = j + 1; + i__2 = f2cmin(i__3,*n); + for (i__ = iend + 1; i__ <= i__2; ++i__) { + temp += (d__1 = s[i__ + j * s_dim1], abs(d__1)); + temp2 += (d__1 = p[i__ + j * p_dim1], abs(d__1)); +/* L40: */ + } + anorm = f2cmax(anorm,temp); + bnorm = f2cmax(bnorm,temp2); +/* L50: */ + } + + ascale = 1. / f2cmax(anorm,safmin); + bscale = 1. / f2cmax(bnorm,safmin); + +/* Left eigenvectors */ + + if (compl) { + ieig = 0; + +/* Main loop over eigenvalues */ + + ilcplx = FALSE_; + i__1 = *n; + for (je = 1; je <= i__1; ++je) { + +/* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or */ +/* (b) this would be the second of a complex pair. */ +/* Check for complex eigenvalue, so as to be sure of which */ +/* entry(-ies) of SELECT to look at. */ + + if (ilcplx) { + ilcplx = FALSE_; + goto L220; + } + nw = 1; + if (je < *n) { + if (s[je + 1 + je * s_dim1] != 0.) { + ilcplx = TRUE_; + nw = 2; + } + } + if (ilall) { + ilcomp = TRUE_; + } else if (ilcplx) { + ilcomp = select[je] || select[je + 1]; + } else { + ilcomp = select[je]; + } + if (! ilcomp) { + goto L220; + } + +/* Decide if (a) singular pencil, (b) real eigenvalue, or */ +/* (c) complex eigenvalue. */ + + if (! ilcplx) { + if ((d__1 = s[je + je * s_dim1], abs(d__1)) <= safmin && ( + d__2 = p[je + je * p_dim1], abs(d__2)) <= safmin) { + +/* Singular matrix pencil -- return unit eigenvector */ + + ++ieig; + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vl[jr + ieig * vl_dim1] = 0.; +/* L60: */ + } + vl[ieig + ieig * vl_dim1] = 1.; + goto L220; + } + } + +/* Clear vector */ + + i__2 = nw * *n; + for (jr = 1; jr <= i__2; ++jr) { + work[(*n << 1) + jr] = 0.; +/* L70: */ + } +/* T */ +/* Compute coefficients in ( a A - b B ) y = 0 */ +/* a is ACOEF */ +/* b is BCOEFR + i*BCOEFI */ + + if (! ilcplx) { + +/* Real eigenvalue */ + +/* Computing MAX */ + d__3 = (d__1 = s[je + je * s_dim1], abs(d__1)) * ascale, d__4 + = (d__2 = p[je + je * p_dim1], abs(d__2)) * bscale, + d__3 = f2cmax(d__3,d__4); + temp = 1. / f2cmax(d__3,safmin); + salfar = temp * s[je + je * s_dim1] * ascale; + sbeta = temp * p[je + je * p_dim1] * bscale; + acoef = sbeta * ascale; + bcoefr = salfar * bscale; + bcoefi = 0.; + +/* Scale to avoid underflow */ + + scale = 1.; + lsa = abs(sbeta) >= safmin && abs(acoef) < small; + lsb = abs(salfar) >= safmin && abs(bcoefr) < small; + if (lsa) { + scale = small / abs(sbeta) * f2cmin(anorm,big); + } + if (lsb) { +/* Computing MAX */ + d__1 = scale, d__2 = small / abs(salfar) * f2cmin(bnorm,big); + scale = f2cmax(d__1,d__2); + } + if (lsa || lsb) { +/* Computing MIN */ +/* Computing MAX */ + d__3 = 1., d__4 = abs(acoef), d__3 = f2cmax(d__3,d__4), d__4 + = abs(bcoefr); + d__1 = scale, d__2 = 1. / (safmin * f2cmax(d__3,d__4)); + scale = f2cmin(d__1,d__2); + if (lsa) { + acoef = ascale * (scale * sbeta); + } else { + acoef = scale * acoef; + } + if (lsb) { + bcoefr = bscale * (scale * salfar); + } else { + bcoefr = scale * bcoefr; + } + } + acoefa = abs(acoef); + bcoefa = abs(bcoefr); + +/* First component is 1 */ + + work[(*n << 1) + je] = 1.; + xmax = 1.; + } else { + +/* Complex eigenvalue */ + + d__1 = safmin * 100.; + dlag2_(&s[je + je * s_dim1], lds, &p[je + je * p_dim1], ldp, & + d__1, &acoef, &temp, &bcoefr, &temp2, &bcoefi); + bcoefi = -bcoefi; + if (bcoefi == 0.) { + *info = je; + return 0; + } + +/* Scale to avoid over/underflow */ + + acoefa = abs(acoef); + bcoefa = abs(bcoefr) + abs(bcoefi); + scale = 1.; + if (acoefa * ulp < safmin && acoefa >= safmin) { + scale = safmin / ulp / acoefa; + } + if (bcoefa * ulp < safmin && bcoefa >= safmin) { +/* Computing MAX */ + d__1 = scale, d__2 = safmin / ulp / bcoefa; + scale = f2cmax(d__1,d__2); + } + if (safmin * acoefa > ascale) { + scale = ascale / (safmin * acoefa); + } + if (safmin * bcoefa > bscale) { +/* Computing MIN */ + d__1 = scale, d__2 = bscale / (safmin * bcoefa); + scale = f2cmin(d__1,d__2); + } + if (scale != 1.) { + acoef = scale * acoef; + acoefa = abs(acoef); + bcoefr = scale * bcoefr; + bcoefi = scale * bcoefi; + bcoefa = abs(bcoefr) + abs(bcoefi); + } + +/* Compute first two components of eigenvector */ + + temp = acoef * s[je + 1 + je * s_dim1]; + temp2r = acoef * s[je + je * s_dim1] - bcoefr * p[je + je * + p_dim1]; + temp2i = -bcoefi * p[je + je * p_dim1]; + if (abs(temp) > abs(temp2r) + abs(temp2i)) { + work[(*n << 1) + je] = 1.; + work[*n * 3 + je] = 0.; + work[(*n << 1) + je + 1] = -temp2r / temp; + work[*n * 3 + je + 1] = -temp2i / temp; + } else { + work[(*n << 1) + je + 1] = 1.; + work[*n * 3 + je + 1] = 0.; + temp = acoef * s[je + (je + 1) * s_dim1]; + work[(*n << 1) + je] = (bcoefr * p[je + 1 + (je + 1) * + p_dim1] - acoef * s[je + 1 + (je + 1) * s_dim1]) / + temp; + work[*n * 3 + je] = bcoefi * p[je + 1 + (je + 1) * p_dim1] + / temp; + } +/* Computing MAX */ + d__5 = (d__1 = work[(*n << 1) + je], abs(d__1)) + (d__2 = + work[*n * 3 + je], abs(d__2)), d__6 = (d__3 = work[(* + n << 1) + je + 1], abs(d__3)) + (d__4 = work[*n * 3 + + je + 1], abs(d__4)); + xmax = f2cmax(d__5,d__6); + } + +/* Computing MAX */ + d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm, d__1 = + f2cmax(d__1,d__2); + dmin__ = f2cmax(d__1,safmin); + +/* T */ +/* Triangular solve of (a A - b B) y = 0 */ + +/* T */ +/* (rowwise in (a A - b B) , or columnwise in (a A - b B) ) */ + + il2by2 = FALSE_; + + i__2 = *n; + for (j = je + nw; j <= i__2; ++j) { + if (il2by2) { + il2by2 = FALSE_; + goto L160; + } + + na = 1; + bdiag[0] = p[j + j * p_dim1]; + if (j < *n) { + if (s[j + 1 + j * s_dim1] != 0.) { + il2by2 = TRUE_; + bdiag[1] = p[j + 1 + (j + 1) * p_dim1]; + na = 2; + } + } + +/* Check whether scaling is necessary for dot products */ + + xscale = 1. / f2cmax(1.,xmax); +/* Computing MAX */ + d__1 = work[j], d__2 = work[*n + j], d__1 = f2cmax(d__1,d__2), + d__2 = acoefa * work[j] + bcoefa * work[*n + j]; + temp = f2cmax(d__1,d__2); + if (il2by2) { +/* Computing MAX */ + d__1 = temp, d__2 = work[j + 1], d__1 = f2cmax(d__1,d__2), + d__2 = work[*n + j + 1], d__1 = f2cmax(d__1,d__2), + d__2 = acoefa * work[j + 1] + bcoefa * work[*n + + j + 1]; + temp = f2cmax(d__1,d__2); + } + if (temp > bignum * xscale) { + i__3 = nw - 1; + for (jw = 0; jw <= i__3; ++jw) { + i__4 = j - 1; + for (jr = je; jr <= i__4; ++jr) { + work[(jw + 2) * *n + jr] = xscale * work[(jw + 2) + * *n + jr]; +/* L80: */ + } +/* L90: */ + } + xmax *= xscale; + } + +/* Compute dot products */ + +/* j-1 */ +/* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k) */ +/* k=je */ + +/* To reduce the op count, this is done as */ + +/* _ j-1 _ j-1 */ +/* a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) ) */ +/* k=je k=je */ + +/* which may cause underflow problems if A or B are close */ +/* to underflow. (E.g., less than SMALL.) */ + + + i__3 = nw; + for (jw = 1; jw <= i__3; ++jw) { + i__4 = na; + for (ja = 1; ja <= i__4; ++ja) { + sums[ja + (jw << 1) - 3] = 0.; + sump[ja + (jw << 1) - 3] = 0.; + + i__5 = j - 1; + for (jr = je; jr <= i__5; ++jr) { + sums[ja + (jw << 1) - 3] += s[jr + (j + ja - 1) * + s_dim1] * work[(jw + 1) * *n + jr]; + sump[ja + (jw << 1) - 3] += p[jr + (j + ja - 1) * + p_dim1] * work[(jw + 1) * *n + jr]; +/* L100: */ + } +/* L110: */ + } +/* L120: */ + } + + i__3 = na; + for (ja = 1; ja <= i__3; ++ja) { + if (ilcplx) { + sum[ja - 1] = -acoef * sums[ja - 1] + bcoefr * sump[ + ja - 1] - bcoefi * sump[ja + 1]; + sum[ja + 1] = -acoef * sums[ja + 1] + bcoefr * sump[ + ja + 1] + bcoefi * sump[ja - 1]; + } else { + sum[ja - 1] = -acoef * sums[ja - 1] + bcoefr * sump[ + ja - 1]; + } +/* L130: */ + } + +/* T */ +/* Solve ( a A - b B ) y = SUM(,) */ +/* with scaling and perturbation of the denominator */ + + dlaln2_(&c_true, &na, &nw, &dmin__, &acoef, &s[j + j * s_dim1] + , lds, bdiag, &bdiag[1], sum, &c__2, &bcoefr, &bcoefi, + &work[(*n << 1) + j], n, &scale, &temp, &iinfo); + if (scale < 1.) { + i__3 = nw - 1; + for (jw = 0; jw <= i__3; ++jw) { + i__4 = j - 1; + for (jr = je; jr <= i__4; ++jr) { + work[(jw + 2) * *n + jr] = scale * work[(jw + 2) * + *n + jr]; +/* L140: */ + } +/* L150: */ + } + xmax = scale * xmax; + } + xmax = f2cmax(xmax,temp); +L160: + ; + } + +/* Copy eigenvector to VL, back transforming if */ +/* HOWMNY='B'. */ + + ++ieig; + if (ilback) { + i__2 = nw - 1; + for (jw = 0; jw <= i__2; ++jw) { + i__3 = *n + 1 - je; + dgemv_("N", n, &i__3, &c_b34, &vl[je * vl_dim1 + 1], ldvl, + &work[(jw + 2) * *n + je], &c__1, &c_b36, &work[( + jw + 4) * *n + 1], &c__1); +/* L170: */ + } + dlacpy_(" ", n, &nw, &work[(*n << 2) + 1], n, &vl[je * + vl_dim1 + 1], ldvl); + ibeg = 1; + } else { + dlacpy_(" ", n, &nw, &work[(*n << 1) + 1], n, &vl[ieig * + vl_dim1 + 1], ldvl); + ibeg = je; + } + +/* Scale eigenvector */ + + xmax = 0.; + if (ilcplx) { + i__2 = *n; + for (j = ibeg; j <= i__2; ++j) { +/* Computing MAX */ + d__3 = xmax, d__4 = (d__1 = vl[j + ieig * vl_dim1], abs( + d__1)) + (d__2 = vl[j + (ieig + 1) * vl_dim1], + abs(d__2)); + xmax = f2cmax(d__3,d__4); +/* L180: */ + } + } else { + i__2 = *n; + for (j = ibeg; j <= i__2; ++j) { +/* Computing MAX */ + d__2 = xmax, d__3 = (d__1 = vl[j + ieig * vl_dim1], abs( + d__1)); + xmax = f2cmax(d__2,d__3); +/* L190: */ + } + } + + if (xmax > safmin) { + xscale = 1. / xmax; + + i__2 = nw - 1; + for (jw = 0; jw <= i__2; ++jw) { + i__3 = *n; + for (jr = ibeg; jr <= i__3; ++jr) { + vl[jr + (ieig + jw) * vl_dim1] = xscale * vl[jr + ( + ieig + jw) * vl_dim1]; +/* L200: */ + } +/* L210: */ + } + } + ieig = ieig + nw - 1; + +L220: + ; + } + } + +/* Right eigenvectors */ + + if (compr) { + ieig = im + 1; + +/* Main loop over eigenvalues */ + + ilcplx = FALSE_; + for (je = *n; je >= 1; --je) { + +/* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or */ +/* (b) this would be the second of a complex pair. */ +/* Check for complex eigenvalue, so as to be sure of which */ +/* entry(-ies) of SELECT to look at -- if complex, SELECT(JE) */ +/* or SELECT(JE-1). */ +/* If this is a complex pair, the 2-by-2 diagonal block */ +/* corresponding to the eigenvalue is in rows/columns JE-1:JE */ + + if (ilcplx) { + ilcplx = FALSE_; + goto L500; + } + nw = 1; + if (je > 1) { + if (s[je + (je - 1) * s_dim1] != 0.) { + ilcplx = TRUE_; + nw = 2; + } + } + if (ilall) { + ilcomp = TRUE_; + } else if (ilcplx) { + ilcomp = select[je] || select[je - 1]; + } else { + ilcomp = select[je]; + } + if (! ilcomp) { + goto L500; + } + +/* Decide if (a) singular pencil, (b) real eigenvalue, or */ +/* (c) complex eigenvalue. */ + + if (! ilcplx) { + if ((d__1 = s[je + je * s_dim1], abs(d__1)) <= safmin && ( + d__2 = p[je + je * p_dim1], abs(d__2)) <= safmin) { + +/* Singular matrix pencil -- unit eigenvector */ + + --ieig; + i__1 = *n; + for (jr = 1; jr <= i__1; ++jr) { + vr[jr + ieig * vr_dim1] = 0.; +/* L230: */ + } + vr[ieig + ieig * vr_dim1] = 1.; + goto L500; + } + } + +/* Clear vector */ + + i__1 = nw - 1; + for (jw = 0; jw <= i__1; ++jw) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + work[(jw + 2) * *n + jr] = 0.; +/* L240: */ + } +/* L250: */ + } + +/* Compute coefficients in ( a A - b B ) x = 0 */ +/* a is ACOEF */ +/* b is BCOEFR + i*BCOEFI */ + + if (! ilcplx) { + +/* Real eigenvalue */ + +/* Computing MAX */ + d__3 = (d__1 = s[je + je * s_dim1], abs(d__1)) * ascale, d__4 + = (d__2 = p[je + je * p_dim1], abs(d__2)) * bscale, + d__3 = f2cmax(d__3,d__4); + temp = 1. / f2cmax(d__3,safmin); + salfar = temp * s[je + je * s_dim1] * ascale; + sbeta = temp * p[je + je * p_dim1] * bscale; + acoef = sbeta * ascale; + bcoefr = salfar * bscale; + bcoefi = 0.; + +/* Scale to avoid underflow */ + + scale = 1.; + lsa = abs(sbeta) >= safmin && abs(acoef) < small; + lsb = abs(salfar) >= safmin && abs(bcoefr) < small; + if (lsa) { + scale = small / abs(sbeta) * f2cmin(anorm,big); + } + if (lsb) { +/* Computing MAX */ + d__1 = scale, d__2 = small / abs(salfar) * f2cmin(bnorm,big); + scale = f2cmax(d__1,d__2); + } + if (lsa || lsb) { +/* Computing MIN */ +/* Computing MAX */ + d__3 = 1., d__4 = abs(acoef), d__3 = f2cmax(d__3,d__4), d__4 + = abs(bcoefr); + d__1 = scale, d__2 = 1. / (safmin * f2cmax(d__3,d__4)); + scale = f2cmin(d__1,d__2); + if (lsa) { + acoef = ascale * (scale * sbeta); + } else { + acoef = scale * acoef; + } + if (lsb) { + bcoefr = bscale * (scale * salfar); + } else { + bcoefr = scale * bcoefr; + } + } + acoefa = abs(acoef); + bcoefa = abs(bcoefr); + +/* First component is 1 */ + + work[(*n << 1) + je] = 1.; + xmax = 1.; + +/* Compute contribution from column JE of A and B to sum */ +/* (See "Further Details", above.) */ + + i__1 = je - 1; + for (jr = 1; jr <= i__1; ++jr) { + work[(*n << 1) + jr] = bcoefr * p[jr + je * p_dim1] - + acoef * s[jr + je * s_dim1]; +/* L260: */ + } + } else { + +/* Complex eigenvalue */ + + d__1 = safmin * 100.; + dlag2_(&s[je - 1 + (je - 1) * s_dim1], lds, &p[je - 1 + (je - + 1) * p_dim1], ldp, &d__1, &acoef, &temp, &bcoefr, & + temp2, &bcoefi); + if (bcoefi == 0.) { + *info = je - 1; + return 0; + } + +/* Scale to avoid over/underflow */ + + acoefa = abs(acoef); + bcoefa = abs(bcoefr) + abs(bcoefi); + scale = 1.; + if (acoefa * ulp < safmin && acoefa >= safmin) { + scale = safmin / ulp / acoefa; + } + if (bcoefa * ulp < safmin && bcoefa >= safmin) { +/* Computing MAX */ + d__1 = scale, d__2 = safmin / ulp / bcoefa; + scale = f2cmax(d__1,d__2); + } + if (safmin * acoefa > ascale) { + scale = ascale / (safmin * acoefa); + } + if (safmin * bcoefa > bscale) { +/* Computing MIN */ + d__1 = scale, d__2 = bscale / (safmin * bcoefa); + scale = f2cmin(d__1,d__2); + } + if (scale != 1.) { + acoef = scale * acoef; + acoefa = abs(acoef); + bcoefr = scale * bcoefr; + bcoefi = scale * bcoefi; + bcoefa = abs(bcoefr) + abs(bcoefi); + } + +/* Compute first two components of eigenvector */ +/* and contribution to sums */ + + temp = acoef * s[je + (je - 1) * s_dim1]; + temp2r = acoef * s[je + je * s_dim1] - bcoefr * p[je + je * + p_dim1]; + temp2i = -bcoefi * p[je + je * p_dim1]; + if (abs(temp) >= abs(temp2r) + abs(temp2i)) { + work[(*n << 1) + je] = 1.; + work[*n * 3 + je] = 0.; + work[(*n << 1) + je - 1] = -temp2r / temp; + work[*n * 3 + je - 1] = -temp2i / temp; + } else { + work[(*n << 1) + je - 1] = 1.; + work[*n * 3 + je - 1] = 0.; + temp = acoef * s[je - 1 + je * s_dim1]; + work[(*n << 1) + je] = (bcoefr * p[je - 1 + (je - 1) * + p_dim1] - acoef * s[je - 1 + (je - 1) * s_dim1]) / + temp; + work[*n * 3 + je] = bcoefi * p[je - 1 + (je - 1) * p_dim1] + / temp; + } + +/* Computing MAX */ + d__5 = (d__1 = work[(*n << 1) + je], abs(d__1)) + (d__2 = + work[*n * 3 + je], abs(d__2)), d__6 = (d__3 = work[(* + n << 1) + je - 1], abs(d__3)) + (d__4 = work[*n * 3 + + je - 1], abs(d__4)); + xmax = f2cmax(d__5,d__6); + +/* Compute contribution from columns JE and JE-1 */ +/* of A and B to the sums. */ + + creala = acoef * work[(*n << 1) + je - 1]; + cimaga = acoef * work[*n * 3 + je - 1]; + crealb = bcoefr * work[(*n << 1) + je - 1] - bcoefi * work[*n + * 3 + je - 1]; + cimagb = bcoefi * work[(*n << 1) + je - 1] + bcoefr * work[*n + * 3 + je - 1]; + cre2a = acoef * work[(*n << 1) + je]; + cim2a = acoef * work[*n * 3 + je]; + cre2b = bcoefr * work[(*n << 1) + je] - bcoefi * work[*n * 3 + + je]; + cim2b = bcoefi * work[(*n << 1) + je] + bcoefr * work[*n * 3 + + je]; + i__1 = je - 2; + for (jr = 1; jr <= i__1; ++jr) { + work[(*n << 1) + jr] = -creala * s[jr + (je - 1) * s_dim1] + + crealb * p[jr + (je - 1) * p_dim1] - cre2a * s[ + jr + je * s_dim1] + cre2b * p[jr + je * p_dim1]; + work[*n * 3 + jr] = -cimaga * s[jr + (je - 1) * s_dim1] + + cimagb * p[jr + (je - 1) * p_dim1] - cim2a * s[jr + + je * s_dim1] + cim2b * p[jr + je * p_dim1]; +/* L270: */ + } + } + +/* Computing MAX */ + d__1 = ulp * acoefa * anorm, d__2 = ulp * bcoefa * bnorm, d__1 = + f2cmax(d__1,d__2); + dmin__ = f2cmax(d__1,safmin); + +/* Columnwise triangular solve of (a A - b B) x = 0 */ + + il2by2 = FALSE_; + for (j = je - nw; j >= 1; --j) { + +/* If a 2-by-2 block, is in position j-1:j, wait until */ +/* next iteration to process it (when it will be j:j+1) */ + + if (! il2by2 && j > 1) { + if (s[j + (j - 1) * s_dim1] != 0.) { + il2by2 = TRUE_; + goto L370; + } + } + bdiag[0] = p[j + j * p_dim1]; + if (il2by2) { + na = 2; + bdiag[1] = p[j + 1 + (j + 1) * p_dim1]; + } else { + na = 1; + } + +/* Compute x(j) (and x(j+1), if 2-by-2 block) */ + + dlaln2_(&c_false, &na, &nw, &dmin__, &acoef, &s[j + j * + s_dim1], lds, bdiag, &bdiag[1], &work[(*n << 1) + j], + n, &bcoefr, &bcoefi, sum, &c__2, &scale, &temp, & + iinfo); + if (scale < 1.) { + + i__1 = nw - 1; + for (jw = 0; jw <= i__1; ++jw) { + i__2 = je; + for (jr = 1; jr <= i__2; ++jr) { + work[(jw + 2) * *n + jr] = scale * work[(jw + 2) * + *n + jr]; +/* L280: */ + } +/* L290: */ + } + } +/* Computing MAX */ + d__1 = scale * xmax; + xmax = f2cmax(d__1,temp); + + i__1 = nw; + for (jw = 1; jw <= i__1; ++jw) { + i__2 = na; + for (ja = 1; ja <= i__2; ++ja) { + work[(jw + 1) * *n + j + ja - 1] = sum[ja + (jw << 1) + - 3]; +/* L300: */ + } +/* L310: */ + } + +/* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling */ + + if (j > 1) { + +/* Check whether scaling is necessary for sum. */ + + xscale = 1. / f2cmax(1.,xmax); + temp = acoefa * work[j] + bcoefa * work[*n + j]; + if (il2by2) { +/* Computing MAX */ + d__1 = temp, d__2 = acoefa * work[j + 1] + bcoefa * + work[*n + j + 1]; + temp = f2cmax(d__1,d__2); + } +/* Computing MAX */ + d__1 = f2cmax(temp,acoefa); + temp = f2cmax(d__1,bcoefa); + if (temp > bignum * xscale) { + + i__1 = nw - 1; + for (jw = 0; jw <= i__1; ++jw) { + i__2 = je; + for (jr = 1; jr <= i__2; ++jr) { + work[(jw + 2) * *n + jr] = xscale * work[(jw + + 2) * *n + jr]; +/* L320: */ + } +/* L330: */ + } + xmax *= xscale; + } + +/* Compute the contributions of the off-diagonals of */ +/* column j (and j+1, if 2-by-2 block) of A and B to the */ +/* sums. */ + + + i__1 = na; + for (ja = 1; ja <= i__1; ++ja) { + if (ilcplx) { + creala = acoef * work[(*n << 1) + j + ja - 1]; + cimaga = acoef * work[*n * 3 + j + ja - 1]; + crealb = bcoefr * work[(*n << 1) + j + ja - 1] - + bcoefi * work[*n * 3 + j + ja - 1]; + cimagb = bcoefi * work[(*n << 1) + j + ja - 1] + + bcoefr * work[*n * 3 + j + ja - 1]; + i__2 = j - 1; + for (jr = 1; jr <= i__2; ++jr) { + work[(*n << 1) + jr] = work[(*n << 1) + jr] - + creala * s[jr + (j + ja - 1) * s_dim1] + + crealb * p[jr + (j + ja - 1) * + p_dim1]; + work[*n * 3 + jr] = work[*n * 3 + jr] - + cimaga * s[jr + (j + ja - 1) * s_dim1] + + cimagb * p[jr + (j + ja - 1) * + p_dim1]; +/* L340: */ + } + } else { + creala = acoef * work[(*n << 1) + j + ja - 1]; + crealb = bcoefr * work[(*n << 1) + j + ja - 1]; + i__2 = j - 1; + for (jr = 1; jr <= i__2; ++jr) { + work[(*n << 1) + jr] = work[(*n << 1) + jr] - + creala * s[jr + (j + ja - 1) * s_dim1] + + crealb * p[jr + (j + ja - 1) * + p_dim1]; +/* L350: */ + } + } +/* L360: */ + } + } + + il2by2 = FALSE_; +L370: + ; + } + +/* Copy eigenvector to VR, back transforming if */ +/* HOWMNY='B'. */ + + ieig -= nw; + if (ilback) { + + i__1 = nw - 1; + for (jw = 0; jw <= i__1; ++jw) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + work[(jw + 4) * *n + jr] = work[(jw + 2) * *n + 1] * + vr[jr + vr_dim1]; +/* L380: */ + } + +/* A series of compiler directives to defeat */ +/* vectorization for the next loop */ + + + i__2 = je; + for (jc = 2; jc <= i__2; ++jc) { + i__3 = *n; + for (jr = 1; jr <= i__3; ++jr) { + work[(jw + 4) * *n + jr] += work[(jw + 2) * *n + + jc] * vr[jr + jc * vr_dim1]; +/* L390: */ + } +/* L400: */ + } +/* L410: */ + } + + i__1 = nw - 1; + for (jw = 0; jw <= i__1; ++jw) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + (ieig + jw) * vr_dim1] = work[(jw + 4) * *n + + jr]; +/* L420: */ + } +/* L430: */ + } + + iend = *n; + } else { + i__1 = nw - 1; + for (jw = 0; jw <= i__1; ++jw) { + i__2 = *n; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + (ieig + jw) * vr_dim1] = work[(jw + 2) * *n + + jr]; +/* L440: */ + } +/* L450: */ + } + + iend = je; + } + +/* Scale eigenvector */ + + xmax = 0.; + if (ilcplx) { + i__1 = iend; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + d__3 = xmax, d__4 = (d__1 = vr[j + ieig * vr_dim1], abs( + d__1)) + (d__2 = vr[j + (ieig + 1) * vr_dim1], + abs(d__2)); + xmax = f2cmax(d__3,d__4); +/* L460: */ + } + } else { + i__1 = iend; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + d__2 = xmax, d__3 = (d__1 = vr[j + ieig * vr_dim1], abs( + d__1)); + xmax = f2cmax(d__2,d__3); +/* L470: */ + } + } + + if (xmax > safmin) { + xscale = 1. / xmax; + i__1 = nw - 1; + for (jw = 0; jw <= i__1; ++jw) { + i__2 = iend; + for (jr = 1; jr <= i__2; ++jr) { + vr[jr + (ieig + jw) * vr_dim1] = xscale * vr[jr + ( + ieig + jw) * vr_dim1]; +/* L480: */ + } +/* L490: */ + } + } +L500: + ; + } + } + + return 0; + +/* End of DTGEVC */ + +} /* dtgevc_ */ + diff --git a/lapack-netlib/SRC/dtgex2.c b/lapack-netlib/SRC/dtgex2.c new file mode 100644 index 000000000..281b32492 --- /dev/null +++ b/lapack-netlib/SRC/dtgex2.c @@ -0,0 +1,1179 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTGEX2 swaps adjacent diagonal blocks in an upper (quasi) triangular matrix pair by an orthogon +al equivalence transformation. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTGEX2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, */ +/* LDZ, J1, N1, N2, WORK, LWORK, INFO ) */ + +/* LOGICAL WANTQ, WANTZ */ +/* INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, LWORK, N, N1, N2 */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), */ +/* $ WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22) */ +/* > of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair */ +/* > (A, B) by an orthogonal equivalence transformation. */ +/* > */ +/* > (A, B) must be in generalized real Schur canonical form (as returned */ +/* > by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 */ +/* > diagonal blocks. B is upper triangular. */ +/* > */ +/* > Optionally, the matrices Q and Z of generalized Schur vectors are */ +/* > updated. */ +/* > */ +/* > Q(in) * A(in) * Z(in)**T = Q(out) * A(out) * Z(out)**T */ +/* > Q(in) * B(in) * Z(in)**T = Q(out) * B(out) * Z(out)**T */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] WANTQ */ +/* > \verbatim */ +/* > WANTQ is LOGICAL */ +/* > .TRUE. : update the left transformation matrix Q; */ +/* > .FALSE.: do not update Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTZ */ +/* > \verbatim */ +/* > WANTZ is LOGICAL */ +/* > .TRUE. : update the right transformation matrix Z; */ +/* > .FALSE.: do not update Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimensions (LDA,N) */ +/* > On entry, the matrix A in the pair (A, B). */ +/* > On exit, the updated matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimensions (LDB,N) */ +/* > On entry, the matrix B in the pair (A, B). */ +/* > On exit, the updated matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is DOUBLE PRECISION array, dimension (LDQ,N) */ +/* > On entry, if WANTQ = .TRUE., the orthogonal matrix Q. */ +/* > On exit, the updated matrix Q. */ +/* > Not referenced if WANTQ = .FALSE.. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= 1. */ +/* > If WANTQ = .TRUE., LDQ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION array, dimension (LDZ,N) */ +/* > On entry, if WANTZ =.TRUE., the orthogonal matrix Z. */ +/* > On exit, the updated matrix Z. */ +/* > Not referenced if WANTZ = .FALSE.. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1. */ +/* > If WANTZ = .TRUE., LDZ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] J1 */ +/* > \verbatim */ +/* > J1 is INTEGER */ +/* > The index to the first block (A11, B11). 1 <= J1 <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N1 */ +/* > \verbatim */ +/* > N1 is INTEGER */ +/* > The order of the first block (A11, B11). N1 = 0, 1 or 2. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N2 */ +/* > \verbatim */ +/* > N2 is INTEGER */ +/* > The order of the second block (A22, B22). N2 = 0, 1 or 2. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > LWORK >= MAX( 1, N*(N2+N1), (N2+N1)*(N2+N1)*2 ) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > =0: Successful exit */ +/* > >0: If INFO = 1, the transformed matrix (A, B) would be */ +/* > too far from generalized Schur form; the blocks are */ +/* > not swapped and (A, B) and (Q, Z) are unchanged. */ +/* > The problem of swapping is too ill-conditioned. */ +/* > <0: If INFO = -16: LWORK is too small. Appropriate value */ +/* > for LWORK is returned in WORK(1). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleGEauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > In the current code both weak and strong stability tests are */ +/* > performed. The user can omit the strong stability test by changing */ +/* > the internal logical parameter WANDS to .FALSE.. See ref. [2] for */ +/* > details. */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* > Umea University, S-901 87 Umea, Sweden. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > \verbatim */ +/* > */ +/* > [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */ +/* > Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */ +/* > M.S. Moonen et al (eds), Linear Algebra for Large Scale and */ +/* > Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */ +/* > */ +/* > [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */ +/* > Eigenvalues of a Regular Matrix Pair (A, B) and Condition */ +/* > Estimation: Theory, Algorithms and Software, */ +/* > Report UMINF - 94.04, Department of Computing Science, Umea */ +/* > University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */ +/* > Note 87. To appear in Numerical Algorithms, 1996. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtgex2_(logical *wantq, logical *wantz, integer *n, + doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * + q, integer *ldq, doublereal *z__, integer *ldz, integer *j1, integer * + n1, integer *n2, doublereal *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, + z_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + logical weak; + doublereal ddum; + integer idum; + doublereal taul[4], dsum; + extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *); + doublereal taur[4], scpy[16] /* was [4][4] */, tcpy[16] /* + was [4][4] */, f, g; + integer i__, m; + doublereal s[16] /* was [4][4] */, t[16] /* was [4][4] */; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + doublereal scale, bqra21, brqa21; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + doublereal licop[16] /* was [4][4] */; + integer linfo; + doublereal ircop[16] /* was [4][4] */, dnorm; + integer iwork[4]; + extern /* Subroutine */ int dlagv2_(doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal * + , doublereal *, doublereal *, doublereal *), dgeqr2_(integer *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + integer *), dgerq2_(integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *), dorg2r_(integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + doublereal *, integer *), dorgr2_(integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *), + dorm2r_(char *, char *, integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *), dormr2_(char *, char *, + integer *, integer *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *); + doublereal be[2], ai[2]; + extern /* Subroutine */ int dtgsy2_(char *, integer *, integer *, integer + *, doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + integer *, integer *, integer *); + doublereal ar[2], sa, sb, li[16] /* was [4][4] */; + extern doublereal dlamch_(char *); + doublereal dscale, ir[16] /* was [4][4] */, ss, ws; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *), + dlartg_(doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *), dlaset_(char *, integer *, integer *, doublereal *, + doublereal *, doublereal *, integer *), dlassq_(integer * + , doublereal *, integer *, doublereal *, doublereal *); + logical dtrong; + doublereal thresh, smlnum, 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 */ + + +/* ===================================================================== */ +/* Replaced various illegal calls to DCOPY by calls to DLASET, or by DO */ +/* loops. Sven Hammarling, 1/5/02. */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + + /* Function Body */ + *info = 0; + +/* Quick return if possible */ + + if (*n <= 1 || *n1 <= 0 || *n2 <= 0) { + return 0; + } + if (*n1 > *n || *j1 + *n1 > *n) { + return 0; + } + m = *n1 + *n2; +/* Computing MAX */ + i__1 = 1, i__2 = *n * m, i__1 = f2cmax(i__1,i__2), i__2 = m * m << 1; + if (*lwork < f2cmax(i__1,i__2)) { + *info = -16; +/* Computing MAX */ + i__1 = 1, i__2 = *n * m, i__1 = f2cmax(i__1,i__2), i__2 = m * m << 1; + work[1] = (doublereal) f2cmax(i__1,i__2); + return 0; + } + + weak = FALSE_; + dtrong = FALSE_; + +/* Make a local copy of selected block */ + + dlaset_("Full", &c__4, &c__4, &c_b5, &c_b5, li, &c__4); + dlaset_("Full", &c__4, &c__4, &c_b5, &c_b5, ir, &c__4); + dlacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, s, &c__4); + dlacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, t, &c__4); + +/* Compute threshold for testing acceptance of swapping. */ + + eps = dlamch_("P"); + smlnum = dlamch_("S") / eps; + dscale = 0.; + dsum = 1.; + dlacpy_("Full", &m, &m, s, &c__4, &work[1], &m); + i__1 = m * m; + dlassq_(&i__1, &work[1], &c__1, &dscale, &dsum); + dlacpy_("Full", &m, &m, t, &c__4, &work[1], &m); + i__1 = m * m; + dlassq_(&i__1, &work[1], &c__1, &dscale, &dsum); + dnorm = dscale * sqrt(dsum); + +/* THRES has been changed from */ +/* THRESH = MAX( TEN*EPS*SA, SMLNUM ) */ +/* to */ +/* THRESH = MAX( TWENTY*EPS*SA, SMLNUM ) */ +/* on 04/01/10. */ +/* "Bug" reported by Ondra Kamenik, confirmed by Julie Langou, fixed by */ +/* Jim Demmel and Guillaume Revy. See forum post 1783. */ + +/* Computing MAX */ + d__1 = eps * 20. * dnorm; + thresh = f2cmax(d__1,smlnum); + + if (m == 2) { + +/* CASE 1: Swap 1-by-1 and 1-by-1 blocks. */ + +/* Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks */ +/* using Givens rotations and perform the swap tentatively. */ + + f = s[5] * t[0] - t[5] * s[0]; + g = s[5] * t[4] - t[5] * s[4]; + sb = abs(t[5]); + sa = abs(s[5]); + dlartg_(&f, &g, &ir[4], ir, &ddum); + ir[1] = -ir[4]; + ir[5] = ir[0]; + drot_(&c__2, s, &c__1, &s[4], &c__1, ir, &ir[1]); + drot_(&c__2, t, &c__1, &t[4], &c__1, ir, &ir[1]); + if (sa >= sb) { + dlartg_(s, &s[1], li, &li[1], &ddum); + } else { + dlartg_(t, &t[1], li, &li[1], &ddum); + } + drot_(&c__2, s, &c__4, &s[1], &c__4, li, &li[1]); + drot_(&c__2, t, &c__4, &t[1], &c__4, li, &li[1]); + li[5] = li[0]; + li[4] = -li[1]; + +/* Weak stability test: */ +/* |S21| + |T21| <= O(EPS * F-norm((S, T))) */ + + ws = abs(s[1]) + abs(t[1]); + weak = ws <= thresh; + if (! weak) { + goto L70; + } + + if (TRUE_) { + +/* Strong stability test: */ +/* F-norm((A-QL**T*S*QR, B-QL**T*T*QR)) <= O(EPS*F-norm((A,B))) */ + + dlacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, &work[m * m + + 1], &m); + dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, & + work[1], &m); + dgemm_("N", "T", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, & + c_b42, &work[m * m + 1], &m); + dscale = 0.; + dsum = 1.; + i__1 = m * m; + dlassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); + + dlacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, &work[m * m + + 1], &m); + dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, & + work[1], &m); + dgemm_("N", "T", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, & + c_b42, &work[m * m + 1], &m); + i__1 = m * m; + dlassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); + ss = dscale * sqrt(dsum); + dtrong = ss <= thresh; + if (! dtrong) { + goto L70; + } + } + +/* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and */ +/* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */ + + i__1 = *j1 + 1; + drot_(&i__1, &a[*j1 * a_dim1 + 1], &c__1, &a[(*j1 + 1) * a_dim1 + 1], + &c__1, ir, &ir[1]); + i__1 = *j1 + 1; + drot_(&i__1, &b[*j1 * b_dim1 + 1], &c__1, &b[(*j1 + 1) * b_dim1 + 1], + &c__1, ir, &ir[1]); + i__1 = *n - *j1 + 1; + drot_(&i__1, &a[*j1 + *j1 * a_dim1], lda, &a[*j1 + 1 + *j1 * a_dim1], + lda, li, &li[1]); + i__1 = *n - *j1 + 1; + drot_(&i__1, &b[*j1 + *j1 * b_dim1], ldb, &b[*j1 + 1 + *j1 * b_dim1], + ldb, li, &li[1]); + +/* Set N1-by-N2 (2,1) - blocks to ZERO. */ + + a[*j1 + 1 + *j1 * a_dim1] = 0.; + b[*j1 + 1 + *j1 * b_dim1] = 0.; + +/* Accumulate transformations into Q and Z if requested. */ + + if (*wantz) { + drot_(n, &z__[*j1 * z_dim1 + 1], &c__1, &z__[(*j1 + 1) * z_dim1 + + 1], &c__1, ir, &ir[1]); + } + if (*wantq) { + drot_(n, &q[*j1 * q_dim1 + 1], &c__1, &q[(*j1 + 1) * q_dim1 + 1], + &c__1, li, &li[1]); + } + +/* Exit with INFO = 0 if swap was successfully performed. */ + + return 0; + + } else { + +/* CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2 */ +/* and 2-by-2 blocks. */ + +/* Solve the generalized Sylvester equation */ +/* S11 * R - L * S22 = SCALE * S12 */ +/* T11 * R - L * T22 = SCALE * T12 */ +/* for R and L. Solutions in LI and IR. */ + + dlacpy_("Full", n1, n2, &t[(*n1 + 1 << 2) - 4], &c__4, li, &c__4); + dlacpy_("Full", n1, n2, &s[(*n1 + 1 << 2) - 4], &c__4, &ir[*n2 + 1 + ( + *n1 + 1 << 2) - 5], &c__4); + dtgsy2_("N", &c__0, n1, n2, s, &c__4, &s[*n1 + 1 + (*n1 + 1 << 2) - 5] + , &c__4, &ir[*n2 + 1 + (*n1 + 1 << 2) - 5], &c__4, t, &c__4, & + t[*n1 + 1 + (*n1 + 1 << 2) - 5], &c__4, li, &c__4, &scale, & + dsum, &dscale, iwork, &idum, &linfo); + +/* Compute orthogonal matrix QL: */ + +/* QL**T * LI = [ TL ] */ +/* [ 0 ] */ +/* where */ +/* LI = [ -L ] */ +/* [ SCALE * identity(N2) ] */ + + i__1 = *n2; + for (i__ = 1; i__ <= i__1; ++i__) { + dscal_(n1, &c_b48, &li[(i__ << 2) - 4], &c__1); + li[*n1 + i__ + (i__ << 2) - 5] = scale; +/* L10: */ + } + dgeqr2_(&m, n2, li, &c__4, taul, &work[1], &linfo); + if (linfo != 0) { + goto L70; + } + dorg2r_(&m, &m, n2, li, &c__4, taul, &work[1], &linfo); + if (linfo != 0) { + goto L70; + } + +/* Compute orthogonal matrix RQ: */ + +/* IR * RQ**T = [ 0 TR], */ + +/* where IR = [ SCALE * identity(N1), R ] */ + + i__1 = *n1; + for (i__ = 1; i__ <= i__1; ++i__) { + ir[*n2 + i__ + (i__ << 2) - 5] = scale; +/* L20: */ + } + dgerq2_(n1, &m, &ir[*n2], &c__4, taur, &work[1], &linfo); + if (linfo != 0) { + goto L70; + } + dorgr2_(&m, &m, n1, ir, &c__4, taur, &work[1], &linfo); + if (linfo != 0) { + goto L70; + } + +/* Perform the swapping tentatively: */ + + dgemm_("T", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, & + work[1], &m); + dgemm_("N", "T", &m, &m, &m, &c_b42, &work[1], &m, ir, &c__4, &c_b5, + s, &c__4); + dgemm_("T", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, & + work[1], &m); + dgemm_("N", "T", &m, &m, &m, &c_b42, &work[1], &m, ir, &c__4, &c_b5, + t, &c__4); + dlacpy_("F", &m, &m, s, &c__4, scpy, &c__4); + dlacpy_("F", &m, &m, t, &c__4, tcpy, &c__4); + dlacpy_("F", &m, &m, ir, &c__4, ircop, &c__4); + dlacpy_("F", &m, &m, li, &c__4, licop, &c__4); + +/* Triangularize the B-part by an RQ factorization. */ +/* Apply transformation (from left) to A-part, giving S. */ + + dgerq2_(&m, &m, t, &c__4, taur, &work[1], &linfo); + if (linfo != 0) { + goto L70; + } + dormr2_("R", "T", &m, &m, &m, t, &c__4, taur, s, &c__4, &work[1], & + linfo); + if (linfo != 0) { + goto L70; + } + dormr2_("L", "N", &m, &m, &m, t, &c__4, taur, ir, &c__4, &work[1], & + linfo); + if (linfo != 0) { + goto L70; + } + +/* Compute F-norm(S21) in BRQA21. (T21 is 0.) */ + + dscale = 0.; + dsum = 1.; + i__1 = *n2; + for (i__ = 1; i__ <= i__1; ++i__) { + dlassq_(n1, &s[*n2 + 1 + (i__ << 2) - 5], &c__1, &dscale, &dsum); +/* L30: */ + } + brqa21 = dscale * sqrt(dsum); + +/* Triangularize the B-part by a QR factorization. */ +/* Apply transformation (from right) to A-part, giving S. */ + + dgeqr2_(&m, &m, tcpy, &c__4, taul, &work[1], &linfo); + if (linfo != 0) { + goto L70; + } + dorm2r_("L", "T", &m, &m, &m, tcpy, &c__4, taul, scpy, &c__4, &work[1] + , info); + dorm2r_("R", "N", &m, &m, &m, tcpy, &c__4, taul, licop, &c__4, &work[ + 1], info); + if (linfo != 0) { + goto L70; + } + +/* Compute F-norm(S21) in BQRA21. (T21 is 0.) */ + + dscale = 0.; + dsum = 1.; + i__1 = *n2; + for (i__ = 1; i__ <= i__1; ++i__) { + dlassq_(n1, &scpy[*n2 + 1 + (i__ << 2) - 5], &c__1, &dscale, & + dsum); +/* L40: */ + } + bqra21 = dscale * sqrt(dsum); + +/* Decide which method to use. */ +/* Weak stability test: */ +/* F-norm(S21) <= O(EPS * F-norm((S, T))) */ + + if (bqra21 <= brqa21 && bqra21 <= thresh) { + dlacpy_("F", &m, &m, scpy, &c__4, s, &c__4); + dlacpy_("F", &m, &m, tcpy, &c__4, t, &c__4); + dlacpy_("F", &m, &m, ircop, &c__4, ir, &c__4); + dlacpy_("F", &m, &m, licop, &c__4, li, &c__4); + } else if (brqa21 >= thresh) { + goto L70; + } + +/* Set lower triangle of B-part to zero */ + + i__1 = m - 1; + i__2 = m - 1; + dlaset_("Lower", &i__1, &i__2, &c_b5, &c_b5, &t[1], &c__4); + + if (TRUE_) { + +/* Strong stability test: */ +/* F-norm((A-QL*S*QR**T, B-QL*T*QR**T)) <= O(EPS*F-norm((A,B))) */ + + dlacpy_("Full", &m, &m, &a[*j1 + *j1 * a_dim1], lda, &work[m * m + + 1], &m); + dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, s, &c__4, &c_b5, & + work[1], &m); + dgemm_("N", "N", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, & + c_b42, &work[m * m + 1], &m); + dscale = 0.; + dsum = 1.; + i__1 = m * m; + dlassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); + + dlacpy_("Full", &m, &m, &b[*j1 + *j1 * b_dim1], ldb, &work[m * m + + 1], &m); + dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, t, &c__4, &c_b5, & + work[1], &m); + dgemm_("N", "N", &m, &m, &m, &c_b48, &work[1], &m, ir, &c__4, & + c_b42, &work[m * m + 1], &m); + i__1 = m * m; + dlassq_(&i__1, &work[m * m + 1], &c__1, &dscale, &dsum); + ss = dscale * sqrt(dsum); + dtrong = ss <= thresh; + if (! dtrong) { + goto L70; + } + + } + +/* If the swap is accepted ("weakly" and "strongly"), apply the */ +/* transformations and set N1-by-N2 (2,1)-block to zero. */ + + dlaset_("Full", n1, n2, &c_b5, &c_b5, &s[*n2], &c__4); + +/* copy back M-by-M diagonal block starting at index J1 of (A, B) */ + + dlacpy_("F", &m, &m, s, &c__4, &a[*j1 + *j1 * a_dim1], lda) + ; + dlacpy_("F", &m, &m, t, &c__4, &b[*j1 + *j1 * b_dim1], ldb) + ; + dlaset_("Full", &c__4, &c__4, &c_b5, &c_b5, t, &c__4); + +/* Standardize existing 2-by-2 blocks. */ + + dlaset_("Full", &m, &m, &c_b5, &c_b5, &work[1], &m); + work[1] = 1.; + t[0] = 1.; + idum = *lwork - m * m - 2; + if (*n2 > 1) { + dlagv2_(&a[*j1 + *j1 * a_dim1], lda, &b[*j1 + *j1 * b_dim1], ldb, + ar, ai, be, &work[1], &work[2], t, &t[1]); + work[m + 1] = -work[2]; + work[m + 2] = work[1]; + t[*n2 + (*n2 << 2) - 5] = t[0]; + t[4] = -t[1]; + } + work[m * m] = 1.; + t[m + (m << 2) - 5] = 1.; + + if (*n1 > 1) { + dlagv2_(&a[*j1 + *n2 + (*j1 + *n2) * a_dim1], lda, &b[*j1 + *n2 + + (*j1 + *n2) * b_dim1], ldb, taur, taul, &work[m * m + 1], + &work[*n2 * m + *n2 + 1], &work[*n2 * m + *n2 + 2], &t[* + n2 + 1 + (*n2 + 1 << 2) - 5], &t[m + (m - 1 << 2) - 5]); + work[m * m] = work[*n2 * m + *n2 + 1]; + work[m * m - 1] = -work[*n2 * m + *n2 + 2]; + t[m + (m << 2) - 5] = t[*n2 + 1 + (*n2 + 1 << 2) - 5]; + t[m - 1 + (m << 2) - 5] = -t[m + (m - 1 << 2) - 5]; + } + dgemm_("T", "N", n2, n1, n2, &c_b42, &work[1], &m, &a[*j1 + (*j1 + * + n2) * a_dim1], lda, &c_b5, &work[m * m + 1], n2); + dlacpy_("Full", n2, n1, &work[m * m + 1], n2, &a[*j1 + (*j1 + *n2) * + a_dim1], lda); + dgemm_("T", "N", n2, n1, n2, &c_b42, &work[1], &m, &b[*j1 + (*j1 + * + n2) * b_dim1], ldb, &c_b5, &work[m * m + 1], n2); + dlacpy_("Full", n2, n1, &work[m * m + 1], n2, &b[*j1 + (*j1 + *n2) * + b_dim1], ldb); + dgemm_("N", "N", &m, &m, &m, &c_b42, li, &c__4, &work[1], &m, &c_b5, & + work[m * m + 1], &m); + dlacpy_("Full", &m, &m, &work[m * m + 1], &m, li, &c__4); + dgemm_("N", "N", n2, n1, n1, &c_b42, &a[*j1 + (*j1 + *n2) * a_dim1], + lda, &t[*n2 + 1 + (*n2 + 1 << 2) - 5], &c__4, &c_b5, &work[1], + n2); + dlacpy_("Full", n2, n1, &work[1], n2, &a[*j1 + (*j1 + *n2) * a_dim1], + lda); + dgemm_("N", "N", n2, n1, n1, &c_b42, &b[*j1 + (*j1 + *n2) * b_dim1], + ldb, &t[*n2 + 1 + (*n2 + 1 << 2) - 5], &c__4, &c_b5, &work[1], + n2); + dlacpy_("Full", n2, n1, &work[1], n2, &b[*j1 + (*j1 + *n2) * b_dim1], + ldb); + dgemm_("T", "N", &m, &m, &m, &c_b42, ir, &c__4, t, &c__4, &c_b5, & + work[1], &m); + dlacpy_("Full", &m, &m, &work[1], &m, ir, &c__4); + +/* Accumulate transformations into Q and Z if requested. */ + + if (*wantq) { + dgemm_("N", "N", n, &m, &m, &c_b42, &q[*j1 * q_dim1 + 1], ldq, li, + &c__4, &c_b5, &work[1], n); + dlacpy_("Full", n, &m, &work[1], n, &q[*j1 * q_dim1 + 1], ldq); + + } + + if (*wantz) { + dgemm_("N", "N", n, &m, &m, &c_b42, &z__[*j1 * z_dim1 + 1], ldz, + ir, &c__4, &c_b5, &work[1], n); + dlacpy_("Full", n, &m, &work[1], n, &z__[*j1 * z_dim1 + 1], ldz); + + } + +/* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and */ +/* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)). */ + + i__ = *j1 + m; + if (i__ <= *n) { + i__1 = *n - i__ + 1; + dgemm_("T", "N", &m, &i__1, &m, &c_b42, li, &c__4, &a[*j1 + i__ * + a_dim1], lda, &c_b5, &work[1], &m); + i__1 = *n - i__ + 1; + dlacpy_("Full", &m, &i__1, &work[1], &m, &a[*j1 + i__ * a_dim1], + lda); + i__1 = *n - i__ + 1; + dgemm_("T", "N", &m, &i__1, &m, &c_b42, li, &c__4, &b[*j1 + i__ * + b_dim1], ldb, &c_b5, &work[1], &m); + i__1 = *n - i__ + 1; + dlacpy_("Full", &m, &i__1, &work[1], &m, &b[*j1 + i__ * b_dim1], + ldb); + } + i__ = *j1 - 1; + if (i__ > 0) { + dgemm_("N", "N", &i__, &m, &m, &c_b42, &a[*j1 * a_dim1 + 1], lda, + ir, &c__4, &c_b5, &work[1], &i__); + dlacpy_("Full", &i__, &m, &work[1], &i__, &a[*j1 * a_dim1 + 1], + lda); + dgemm_("N", "N", &i__, &m, &m, &c_b42, &b[*j1 * b_dim1 + 1], ldb, + ir, &c__4, &c_b5, &work[1], &i__); + dlacpy_("Full", &i__, &m, &work[1], &i__, &b[*j1 * b_dim1 + 1], + ldb); + } + +/* Exit with INFO = 0 if swap was successfully performed. */ + + return 0; + + } + +/* Exit with INFO = 1 if swap was rejected. */ + +L70: + + *info = 1; + return 0; + +/* End of DTGEX2 */ + +} /* dtgex2_ */ + diff --git a/lapack-netlib/SRC/dtgexc.c b/lapack-netlib/SRC/dtgexc.c new file mode 100644 index 000000000..39af99d97 --- /dev/null +++ b/lapack-netlib/SRC/dtgexc.c @@ -0,0 +1,979 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTGEXC */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTGEXC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, */ +/* LDZ, IFST, ILST, WORK, LWORK, INFO ) */ + +/* LOGICAL WANTQ, WANTZ */ +/* INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, LWORK, N */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ), */ +/* $ WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTGEXC reorders the generalized real Schur decomposition of a real */ +/* > matrix pair (A,B) using an orthogonal equivalence transformation */ +/* > */ +/* > (A, B) = Q * (A, B) * Z**T, */ +/* > */ +/* > so that the diagonal block of (A, B) with row index IFST is moved */ +/* > to row ILST. */ +/* > */ +/* > (A, B) must be in generalized real Schur canonical form (as returned */ +/* > by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2 */ +/* > diagonal blocks. B is upper triangular. */ +/* > */ +/* > Optionally, the matrices Q and Z of generalized Schur vectors are */ +/* > updated. */ +/* > */ +/* > Q(in) * A(in) * Z(in)**T = Q(out) * A(out) * Z(out)**T */ +/* > Q(in) * B(in) * Z(in)**T = Q(out) * B(out) * Z(out)**T */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] WANTQ */ +/* > \verbatim */ +/* > WANTQ is LOGICAL */ +/* > .TRUE. : update the left transformation matrix Q; */ +/* > .FALSE.: do not update Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTZ */ +/* > \verbatim */ +/* > WANTZ is LOGICAL */ +/* > .TRUE. : update the right transformation matrix Z; */ +/* > .FALSE.: do not update Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the matrix A in generalized real Schur canonical */ +/* > form. */ +/* > On exit, the updated matrix A, again in generalized */ +/* > real Schur canonical form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,N) */ +/* > On entry, the matrix B in generalized real Schur canonical */ +/* > form (A,B). */ +/* > On exit, the updated matrix B, again in generalized */ +/* > real Schur canonical form (A,B). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is DOUBLE PRECISION array, dimension (LDQ,N) */ +/* > On entry, if WANTQ = .TRUE., the orthogonal matrix Q. */ +/* > On exit, the updated matrix Q. */ +/* > If WANTQ = .FALSE., Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= 1. */ +/* > If WANTQ = .TRUE., LDQ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION array, dimension (LDZ,N) */ +/* > On entry, if WANTZ = .TRUE., the orthogonal matrix Z. */ +/* > On exit, the updated matrix Z. */ +/* > If WANTZ = .FALSE., Z is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1. */ +/* > If WANTZ = .TRUE., LDZ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] IFST */ +/* > \verbatim */ +/* > IFST is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ILST */ +/* > \verbatim */ +/* > ILST is INTEGER */ +/* > Specify the reordering of the diagonal blocks of (A, B). */ +/* > The block with row index IFST is moved to row ILST, by a */ +/* > sequence of swapping between adjacent blocks. */ +/* > On exit, if IFST pointed on entry to the second row of */ +/* > a 2-by-2 block, it is changed to point to the first row; */ +/* > ILST always points to the first row of the block in its */ +/* > final position (which may differ from its input value by */ +/* > +1 or -1). 1 <= IFST, ILST <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > LWORK >= 1 when N <= 1, otherwise LWORK >= 4*N + 16. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > =0: successful exit. */ +/* > <0: if INFO = -i, the i-th argument had an illegal value. */ +/* > =1: The transformed matrix pair (A, B) would be too far */ +/* > from generalized Schur form; the problem is ill- */ +/* > conditioned. (A, B) may have been partially reordered, */ +/* > and ILST points to the first row of the current */ +/* > position of the block being moved. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleGEcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* > Umea University, S-901 87 Umea, Sweden. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > \verbatim */ +/* > */ +/* > [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */ +/* > Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */ +/* > M.S. Moonen et al (eds), Linear Algebra for Large Scale and */ +/* > Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtgexc_(logical *wantq, logical *wantz, integer *n, + doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * + q, integer *ldq, doublereal *z__, integer *ldz, integer *ifst, + integer *ilst, doublereal *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, + z_offset, i__1; + + /* Local variables */ + integer here, lwmin; + extern /* Subroutine */ int dtgex2_(logical *, logical *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *, integer *, integer + *, doublereal *, integer *, integer *), xerbla_(char *, integer *, ftnlen); + integer nbnext; + logical lquery; + integer nbf, nbl; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and test input arguments. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } else if (*ldq < 1 || *wantq && *ldq < f2cmax(1,*n)) { + *info = -9; + } else if (*ldz < 1 || *wantz && *ldz < f2cmax(1,*n)) { + *info = -11; + } else if (*ifst < 1 || *ifst > *n) { + *info = -12; + } else if (*ilst < 1 || *ilst > *n) { + *info = -13; + } + + if (*info == 0) { + if (*n <= 1) { + lwmin = 1; + } else { + lwmin = (*n << 2) + 16; + } + work[1] = (doublereal) lwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -15; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTGEXC", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n <= 1) { + return 0; + } + +/* Determine the first row of the specified block and find out */ +/* if it is 1-by-1 or 2-by-2. */ + + if (*ifst > 1) { + if (a[*ifst + (*ifst - 1) * a_dim1] != 0.) { + --(*ifst); + } + } + nbf = 1; + if (*ifst < *n) { + if (a[*ifst + 1 + *ifst * a_dim1] != 0.) { + nbf = 2; + } + } + +/* Determine the first row of the final block */ +/* and find out if it is 1-by-1 or 2-by-2. */ + + if (*ilst > 1) { + if (a[*ilst + (*ilst - 1) * a_dim1] != 0.) { + --(*ilst); + } + } + nbl = 1; + if (*ilst < *n) { + if (a[*ilst + 1 + *ilst * a_dim1] != 0.) { + nbl = 2; + } + } + if (*ifst == *ilst) { + return 0; + } + + if (*ifst < *ilst) { + +/* Update ILST. */ + + if (nbf == 2 && nbl == 1) { + --(*ilst); + } + if (nbf == 1 && nbl == 2) { + ++(*ilst); + } + + here = *ifst; + +L10: + +/* Swap with next one below. */ + + if (nbf == 1 || nbf == 2) { + +/* Current block either 1-by-1 or 2-by-2. */ + + nbnext = 1; + if (here + nbf + 1 <= *n) { + if (a[here + nbf + 1 + (here + nbf) * a_dim1] != 0.) { + nbnext = 2; + } + } + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[ + q_offset], ldq, &z__[z_offset], ldz, &here, &nbf, &nbnext, + &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + here += nbnext; + +/* Test if 2-by-2 block breaks into two 1-by-1 blocks. */ + + if (nbf == 2) { + if (a[here + 1 + here * a_dim1] == 0.) { + nbf = 3; + } + } + + } else { + +/* Current block consists of two 1-by-1 blocks, each of which */ +/* must be swapped individually. */ + + nbnext = 1; + if (here + 3 <= *n) { + if (a[here + 3 + (here + 2) * a_dim1] != 0.) { + nbnext = 2; + } + } + i__1 = here + 1; + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[ + q_offset], ldq, &z__[z_offset], ldz, &i__1, &c__1, & + nbnext, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + if (nbnext == 1) { + +/* Swap two 1-by-1 blocks. */ + + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, + &q[q_offset], ldq, &z__[z_offset], ldz, &here, &c__1, + &c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + ++here; + + } else { + +/* Recompute NBNEXT in case of 2-by-2 split. */ + + if (a[here + 2 + (here + 1) * a_dim1] == 0.) { + nbnext = 1; + } + if (nbnext == 2) { + +/* 2-by-2 block did not split. */ + + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], + ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & + here, &c__1, &nbnext, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + here += 2; + } else { + +/* 2-by-2 block did split. */ + + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], + ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & + here, &c__1, &c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + ++here; + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], + ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & + here, &c__1, &c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + ++here; + } + + } + } + if (here < *ilst) { + goto L10; + } + } else { + here = *ifst; + +L20: + +/* Swap with next one below. */ + + if (nbf == 1 || nbf == 2) { + +/* Current block either 1-by-1 or 2-by-2. */ + + nbnext = 1; + if (here >= 3) { + if (a[here - 1 + (here - 2) * a_dim1] != 0.) { + nbnext = 2; + } + } + i__1 = here - nbnext; + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[ + q_offset], ldq, &z__[z_offset], ldz, &i__1, &nbnext, &nbf, + &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + here -= nbnext; + +/* Test if 2-by-2 block breaks into two 1-by-1 blocks. */ + + if (nbf == 2) { + if (a[here + 1 + here * a_dim1] == 0.) { + nbf = 3; + } + } + + } else { + +/* Current block consists of two 1-by-1 blocks, each of which */ +/* must be swapped individually. */ + + nbnext = 1; + if (here >= 3) { + if (a[here - 1 + (here - 2) * a_dim1] != 0.) { + nbnext = 2; + } + } + i__1 = here - nbnext; + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, &q[ + q_offset], ldq, &z__[z_offset], ldz, &i__1, &nbnext, & + c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + if (nbnext == 1) { + +/* Swap two 1-by-1 blocks. */ + + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], ldb, + &q[q_offset], ldq, &z__[z_offset], ldz, &here, & + nbnext, &c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + --here; + } else { + +/* Recompute NBNEXT in case of 2-by-2 split. */ + + if (a[here + (here - 1) * a_dim1] == 0.) { + nbnext = 1; + } + if (nbnext == 2) { + +/* 2-by-2 block did not split. */ + + i__1 = here - 1; + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], + ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & + i__1, &c__2, &c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + here += -2; + } else { + +/* 2-by-2 block did split. */ + + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], + ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & + here, &c__1, &c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + --here; + dtgex2_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], + ldb, &q[q_offset], ldq, &z__[z_offset], ldz, & + here, &c__1, &c__1, &work[1], lwork, info); + if (*info != 0) { + *ilst = here; + return 0; + } + --here; + } + } + } + if (here > *ilst) { + goto L20; + } + } + *ilst = here; + work[1] = (doublereal) lwmin; + return 0; + +/* End of DTGEXC */ + +} /* dtgexc_ */ + diff --git a/lapack-netlib/SRC/dtgsen.c b/lapack-netlib/SRC/dtgsen.c new file mode 100644 index 000000000..ac2ac8021 --- /dev/null +++ b/lapack-netlib/SRC/dtgsen.c @@ -0,0 +1,1335 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTGSEN */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTGSEN + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTGSEN( IJOB, WANTQ, WANTZ, SELECT, N, A, LDA, B, LDB, */ +/* ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, M, PL, */ +/* PR, DIF, WORK, LWORK, IWORK, LIWORK, INFO ) */ + +/* LOGICAL WANTQ, WANTZ */ +/* INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK, */ +/* $ M, N */ +/* DOUBLE PRECISION PL, PR */ +/* LOGICAL SELECT( * ) */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ), */ +/* $ B( LDB, * ), BETA( * ), DIF( * ), Q( LDQ, * ), */ +/* $ WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTGSEN reorders the generalized real Schur decomposition of a real */ +/* > matrix pair (A, B) (in terms of an orthonormal equivalence trans- */ +/* > formation Q**T * (A, B) * Z), so that a selected cluster of eigenvalues */ +/* > appears in the leading diagonal blocks of the upper quasi-triangular */ +/* > matrix A and the upper triangular B. The leading columns of Q and */ +/* > Z form orthonormal bases of the corresponding left and right eigen- */ +/* > spaces (deflating subspaces). (A, B) must be in generalized real */ +/* > Schur canonical form (as returned by DGGES), i.e. A is block upper */ +/* > triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper */ +/* > triangular. */ +/* > */ +/* > DTGSEN also computes the generalized eigenvalues */ +/* > */ +/* > w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j) */ +/* > */ +/* > of the reordered matrix pair (A, B). */ +/* > */ +/* > Optionally, DTGSEN computes the estimates of reciprocal condition */ +/* > numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11), */ +/* > (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s) */ +/* > between the matrix pairs (A11, B11) and (A22,B22) that correspond to */ +/* > the selected cluster and the eigenvalues outside the cluster, resp., */ +/* > and norms of "projections" onto left and right eigenspaces w.r.t. */ +/* > the selected cluster in the (1,1)-block. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] IJOB */ +/* > \verbatim */ +/* > IJOB is INTEGER */ +/* > Specifies whether condition numbers are required for the */ +/* > cluster of eigenvalues (PL and PR) or the deflating subspaces */ +/* > (Difu and Difl): */ +/* > =0: Only reorder w.r.t. SELECT. No extras. */ +/* > =1: Reciprocal of norms of "projections" onto left and right */ +/* > eigenspaces w.r.t. the selected cluster (PL and PR). */ +/* > =2: Upper bounds on Difu and Difl. F-norm-based estimate */ +/* > (DIF(1:2)). */ +/* > =3: Estimate of Difu and Difl. 1-norm-based estimate */ +/* > (DIF(1:2)). */ +/* > About 5 times as expensive as IJOB = 2. */ +/* > =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic */ +/* > version to get it all. */ +/* > =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTQ */ +/* > \verbatim */ +/* > WANTQ is LOGICAL */ +/* > .TRUE. : update the left transformation matrix Q; */ +/* > .FALSE.: do not update Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] WANTZ */ +/* > \verbatim */ +/* > WANTZ is LOGICAL */ +/* > .TRUE. : update the right transformation matrix Z; */ +/* > .FALSE.: do not update Z. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > SELECT specifies the eigenvalues in the selected cluster. */ +/* > To select a real eigenvalue w(j), SELECT(j) must be set to */ +/* > .TRUE.. To select a complex conjugate pair of eigenvalues */ +/* > w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, */ +/* > either SELECT(j) or SELECT(j+1) or both must be set to */ +/* > .TRUE.; a complex conjugate pair of eigenvalues must be */ +/* > either both included in the cluster or both excluded. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension(LDA,N) */ +/* > On entry, the upper quasi-triangular matrix A, with (A, B) in */ +/* > generalized real Schur canonical form. */ +/* > On exit, A is overwritten by the reordered matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension(LDB,N) */ +/* > On entry, the upper triangular matrix B, with (A, B) in */ +/* > generalized real Schur canonical form. */ +/* > On exit, B is overwritten by the reordered matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAR */ +/* > \verbatim */ +/* > ALPHAR is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHAI */ +/* > \verbatim */ +/* > ALPHAI is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION array, dimension (N) */ +/* > */ +/* > On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will */ +/* > be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i */ +/* > and BETA(j),j=1,...,N are the diagonals of the complex Schur */ +/* > form (S,T) that would result if the 2-by-2 diagonal blocks of */ +/* > the real generalized Schur form of (A,B) were further reduced */ +/* > to triangular form using complex unitary transformations. */ +/* > If ALPHAI(j) is zero, then the j-th eigenvalue is real; if */ +/* > positive, then the j-th and (j+1)-st eigenvalues are a */ +/* > complex conjugate pair, with ALPHAI(j+1) negative. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is DOUBLE PRECISION array, dimension (LDQ,N) */ +/* > On entry, if WANTQ = .TRUE., Q is an N-by-N matrix. */ +/* > On exit, Q has been postmultiplied by the left orthogonal */ +/* > transformation matrix which reorder (A, B); The leading M */ +/* > columns of Q form orthonormal bases for the specified pair of */ +/* > left eigenspaces (deflating subspaces). */ +/* > If WANTQ = .FALSE., Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= 1; */ +/* > and if WANTQ = .TRUE., LDQ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is DOUBLE PRECISION array, dimension (LDZ,N) */ +/* > On entry, if WANTZ = .TRUE., Z is an N-by-N matrix. */ +/* > On exit, Z has been postmultiplied by the left orthogonal */ +/* > transformation matrix which reorder (A, B); The leading M */ +/* > columns of Z form orthonormal bases for the specified pair of */ +/* > left eigenspaces (deflating subspaces). */ +/* > If WANTZ = .FALSE., Z is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1; */ +/* > If WANTZ = .TRUE., LDZ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The dimension of the specified pair of left and right eigen- */ +/* > spaces (deflating subspaces). 0 <= M <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PL */ +/* > \verbatim */ +/* > PL is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PR */ +/* > \verbatim */ +/* > PR is DOUBLE PRECISION */ +/* > */ +/* > If IJOB = 1, 4 or 5, PL, PR are lower bounds on the */ +/* > reciprocal of the norm of "projections" onto left and right */ +/* > eigenspaces with respect to the selected cluster. */ +/* > 0 < PL, PR <= 1. */ +/* > If M = 0 or M = N, PL = PR = 1. */ +/* > If IJOB = 0, 2 or 3, PL and PR are not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DIF */ +/* > \verbatim */ +/* > DIF is DOUBLE PRECISION array, dimension (2). */ +/* > If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl. */ +/* > If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on */ +/* > Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based */ +/* > estimates of Difu and Difl. */ +/* > If M = 0 or N, DIF(1:2) = F-norm([A, B]). */ +/* > If IJOB = 0 or 1, DIF is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= 4*N+16. */ +/* > If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)). */ +/* > If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)). */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */ +/* > On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the array IWORK. LIWORK >= 1. */ +/* > If IJOB = 1, 2 or 4, LIWORK >= N+6. */ +/* > If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6). */ +/* > */ +/* > If LIWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal size of the IWORK array, */ +/* > returns this value as the first entry of the IWORK array, and */ +/* > no error message related to LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > =0: Successful exit. */ +/* > <0: If INFO = -i, the i-th argument had an illegal value. */ +/* > =1: Reordering of (A, B) failed because the transformed */ +/* > matrix pair (A, B) would be too far from generalized */ +/* > Schur form; the problem is very ill-conditioned. */ +/* > (A, B) may have been partially reordered. */ +/* > If requested, 0 is returned in DIF(*), PL and PR. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTGSEN first collects the selected eigenvalues by computing */ +/* > orthogonal U and W that move them to the top left corner of (A, B). */ +/* > In other words, the selected eigenvalues are the eigenvalues of */ +/* > (A11, B11) in: */ +/* > */ +/* > U**T*(A, B)*W = (A11 A12) (B11 B12) n1 */ +/* > ( 0 A22),( 0 B22) n2 */ +/* > n1 n2 n1 n2 */ +/* > */ +/* > where N = n1+n2 and U**T means the transpose of U. The first n1 columns */ +/* > of U and W span the specified pair of left and right eigenspaces */ +/* > (deflating subspaces) of (A, B). */ +/* > */ +/* > If (A, B) has been obtained from the generalized real Schur */ +/* > decomposition of a matrix pair (C, D) = Q*(A, B)*Z**T, then the */ +/* > reordered generalized real Schur form of (C, D) is given by */ +/* > */ +/* > (C, D) = (Q*U)*(U**T*(A, B)*W)*(Z*W)**T, */ +/* > */ +/* > and the first n1 columns of Q*U and Z*W span the corresponding */ +/* > deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.). */ +/* > */ +/* > Note that if the selected eigenvalue is sufficiently ill-conditioned, */ +/* > then its value may differ significantly from its value before */ +/* > reordering. */ +/* > */ +/* > The reciprocal condition numbers of the left and right eigenspaces */ +/* > spanned by the first n1 columns of U and W (or Q*U and Z*W) may */ +/* > be returned in DIF(1:2), corresponding to Difu and Difl, resp. */ +/* > */ +/* > The Difu and Difl are defined as: */ +/* > */ +/* > Difu[(A11, B11), (A22, B22)] = sigma-f2cmin( Zu ) */ +/* > and */ +/* > Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)], */ +/* > */ +/* > where sigma-f2cmin(Zu) is the smallest singular value of the */ +/* > (2*n1*n2)-by-(2*n1*n2) matrix */ +/* > */ +/* > Zu = [ kron(In2, A11) -kron(A22**T, In1) ] */ +/* > [ kron(In2, B11) -kron(B22**T, In1) ]. */ +/* > */ +/* > Here, Inx is the identity matrix of size nx and A22**T is the */ +/* > transpose of A22. kron(X, Y) is the Kronecker product between */ +/* > the matrices X and Y. */ +/* > */ +/* > When DIF(2) is small, small changes in (A, B) can cause large changes */ +/* > in the deflating subspace. An approximate (asymptotic) bound on the */ +/* > maximum angular error in the computed deflating subspaces is */ +/* > */ +/* > EPS * norm((A, B)) / DIF(2), */ +/* > */ +/* > where EPS is the machine precision. */ +/* > */ +/* > The reciprocal norm of the projectors on the left and right */ +/* > eigenspaces associated with (A11, B11) may be returned in PL and PR. */ +/* > They are computed as follows. First we compute L and R so that */ +/* > P*(A, B)*Q is block diagonal, where */ +/* > */ +/* > P = ( I -L ) n1 Q = ( I R ) n1 */ +/* > ( 0 I ) n2 and ( 0 I ) n2 */ +/* > n1 n2 n1 n2 */ +/* > */ +/* > and (L, R) is the solution to the generalized Sylvester equation */ +/* > */ +/* > A11*R - L*A22 = -A12 */ +/* > B11*R - L*B22 = -B12 */ +/* > */ +/* > Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2). */ +/* > An approximate (asymptotic) bound on the average absolute error of */ +/* > the selected eigenvalues is */ +/* > */ +/* > EPS * norm((A, B)) / PL. */ +/* > */ +/* > There are also global error bounds which valid for perturbations up */ +/* > to a certain restriction: A lower bound (x) on the smallest */ +/* > F-norm(E,F) for which an eigenvalue of (A11, B11) may move and */ +/* > coalesce with an eigenvalue of (A22, B22) under perturbation (E,F), */ +/* > (i.e. (A + E, B + F), is */ +/* > */ +/* > x = f2cmin(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*f2cmax(1/PL,1/PR)). */ +/* > */ +/* > An approximate bound on x can be computed from DIF(1:2), PL and PR. */ +/* > */ +/* > If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed */ +/* > (L', R') and unperturbed (L, R) left and right deflating subspaces */ +/* > associated with the selected cluster in the (1,1)-blocks can be */ +/* > bounded as */ +/* > */ +/* > f2cmax-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2)) */ +/* > f2cmax-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2)) */ +/* > */ +/* > See LAPACK User's Guide section 4.11 or the following references */ +/* > for more information. */ +/* > */ +/* > Note that if the default method for computing the Frobenius-norm- */ +/* > based estimate DIF is not wanted (see DLATDF), then the parameter */ +/* > IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF */ +/* > (IJOB = 2 will be used)). See DTGSYL for more details. */ +/* > \endverbatim */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* > Umea University, S-901 87 Umea, Sweden. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > \verbatim */ +/* > */ +/* > [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */ +/* > Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */ +/* > M.S. Moonen et al (eds), Linear Algebra for Large Scale and */ +/* > Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */ +/* > */ +/* > [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */ +/* > Eigenvalues of a Regular Matrix Pair (A, B) and Condition */ +/* > Estimation: Theory, Algorithms and Software, */ +/* > Report UMINF - 94.04, Department of Computing Science, Umea */ +/* > University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */ +/* > Note 87. To appear in Numerical Algorithms, 1996. */ +/* > */ +/* > [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */ +/* > for Solving the Generalized Sylvester Equation and Estimating the */ +/* > Separation between Regular Matrix Pairs, Report UMINF - 93.23, */ +/* > Department of Computing Science, Umea University, S-901 87 Umea, */ +/* > Sweden, December 1993, Revised April 1994, Also as LAPACK Working */ +/* > Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1, */ +/* > 1996. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtgsen_(integer *ijob, logical *wantq, logical *wantz, + logical *select, integer *n, doublereal *a, integer *lda, doublereal * + b, integer *ldb, doublereal *alphar, doublereal *alphai, doublereal * + beta, doublereal *q, integer *ldq, doublereal *z__, integer *ldz, + integer *m, doublereal *pl, doublereal *pr, doublereal *dif, + doublereal *work, integer *lwork, integer *iwork, integer *liwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, z_dim1, + z_offset, i__1, i__2; + doublereal d__1; + + /* Local variables */ + integer kase; + logical pair; + integer ierr; + doublereal dsum; + logical swap; + extern /* Subroutine */ int dlag2_(doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *); + integer i__, k, isave[3]; + logical wantd; + integer lwmin; + logical wantp; + integer n1, n2; + extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + logical wantd1, wantd2; + integer kk; + extern doublereal dlamch_(char *); + doublereal dscale; + integer ks; + doublereal rdscal; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen), dtgexc_(logical *, logical *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, integer *, + integer *, doublereal *, integer *, integer *), dlassq_(integer *, + doublereal *, integer *, doublereal *, doublereal *); + integer liwmin; + extern /* Subroutine */ int dtgsyl_(char *, integer *, integer *, integer + *, doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + integer *, integer *, integer *); + doublereal smlnum; + integer mn2; + logical lquery; + integer ijb; + doublereal eps; + + +/* -- 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 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + --select; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alphar; + --alphai; + --beta; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --dif; + --work; + --iwork; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1 || *liwork == -1; + + if (*ijob < 0 || *ijob > 5) { + *info = -1; + } else if (*n < 0) { + *info = -5; + } else if (*lda < f2cmax(1,*n)) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } else if (*ldq < 1 || *wantq && *ldq < *n) { + *info = -14; + } else if (*ldz < 1 || *wantz && *ldz < *n) { + *info = -16; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTGSEN", &i__1, (ftnlen)6); + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + smlnum = dlamch_("S") / eps; + ierr = 0; + + wantp = *ijob == 1 || *ijob >= 4; + wantd1 = *ijob == 2 || *ijob == 4; + wantd2 = *ijob == 3 || *ijob == 5; + wantd = wantd1 || wantd2; + +/* Set M to the dimension of the specified pair of deflating */ +/* subspaces. */ + + *m = 0; + pair = FALSE_; + if (! lquery || *ijob != 0) { + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = FALSE_; + } else { + if (k < *n) { + if (a[k + 1 + k * a_dim1] == 0.) { + if (select[k]) { + ++(*m); + } + } else { + pair = TRUE_; + if (select[k] || select[k + 1]) { + *m += 2; + } + } + } else { + if (select[*n]) { + ++(*m); + } + } + } +/* L10: */ + } + } + + if (*ijob == 1 || *ijob == 2 || *ijob == 4) { +/* Computing MAX */ + i__1 = 1, i__2 = (*n << 2) + 16, i__1 = f2cmax(i__1,i__2), i__2 = (*m << + 1) * (*n - *m); + lwmin = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = 1, i__2 = *n + 6; + liwmin = f2cmax(i__1,i__2); + } else if (*ijob == 3 || *ijob == 5) { +/* Computing MAX */ + i__1 = 1, i__2 = (*n << 2) + 16, i__1 = f2cmax(i__1,i__2), i__2 = (*m << + 2) * (*n - *m); + lwmin = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = 1, i__2 = (*m << 1) * (*n - *m), i__1 = f2cmax(i__1,i__2), i__2 = + *n + 6; + liwmin = f2cmax(i__1,i__2); + } else { +/* Computing MAX */ + i__1 = 1, i__2 = (*n << 2) + 16; + lwmin = f2cmax(i__1,i__2); + liwmin = 1; + } + + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -22; + } else if (*liwork < liwmin && ! lquery) { + *info = -24; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTGSEN", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible. */ + + if (*m == *n || *m == 0) { + if (wantp) { + *pl = 1.; + *pr = 1.; + } + if (wantd) { + dscale = 0.; + dsum = 1.; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dlassq_(n, &a[i__ * a_dim1 + 1], &c__1, &dscale, &dsum); + dlassq_(n, &b[i__ * b_dim1 + 1], &c__1, &dscale, &dsum); +/* L20: */ + } + dif[1] = dscale * sqrt(dsum); + dif[2] = dif[1]; + } + goto L60; + } + +/* Collect the selected blocks at the top-left corner of (A, B). */ + + ks = 0; + pair = FALSE_; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = FALSE_; + } else { + + swap = select[k]; + if (k < *n) { + if (a[k + 1 + k * a_dim1] != 0.) { + pair = TRUE_; + swap = swap || select[k + 1]; + } + } + + if (swap) { + ++ks; + +/* Swap the K-th block to position KS. */ +/* Perform the reordering of diagonal blocks in (A, B) */ +/* by orthogonal transformation matrices and update */ +/* Q and Z accordingly (if requested): */ + + kk = k; + if (k != ks) { + dtgexc_(wantq, wantz, n, &a[a_offset], lda, &b[b_offset], + ldb, &q[q_offset], ldq, &z__[z_offset], ldz, &kk, + &ks, &work[1], lwork, &ierr); + } + + if (ierr > 0) { + +/* Swap is rejected: exit. */ + + *info = 1; + if (wantp) { + *pl = 0.; + *pr = 0.; + } + if (wantd) { + dif[1] = 0.; + dif[2] = 0.; + } + goto L60; + } + + if (pair) { + ++ks; + } + } + } +/* L30: */ + } + if (wantp) { + +/* Solve generalized Sylvester equation for R and L */ +/* and compute PL and PR. */ + + n1 = *m; + n2 = *n - *m; + i__ = n1 + 1; + ijb = 0; + dlacpy_("Full", &n1, &n2, &a[i__ * a_dim1 + 1], lda, &work[1], &n1); + dlacpy_("Full", &n1, &n2, &b[i__ * b_dim1 + 1], ldb, &work[n1 * n2 + + 1], &n1); + i__1 = *lwork - (n1 << 1) * n2; + dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ * a_dim1] + , lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ + i__ * + b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, &dif[1], & + work[(n1 * n2 << 1) + 1], &i__1, &iwork[1], &ierr); + +/* Estimate the reciprocal of norms of "projections" onto left */ +/* and right eigenspaces. */ + + rdscal = 0.; + dsum = 1.; + i__1 = n1 * n2; + dlassq_(&i__1, &work[1], &c__1, &rdscal, &dsum); + *pl = rdscal * sqrt(dsum); + if (*pl == 0.) { + *pl = 1.; + } else { + *pl = dscale / (sqrt(dscale * dscale / *pl + *pl) * sqrt(*pl)); + } + rdscal = 0.; + dsum = 1.; + i__1 = n1 * n2; + dlassq_(&i__1, &work[n1 * n2 + 1], &c__1, &rdscal, &dsum); + *pr = rdscal * sqrt(dsum); + if (*pr == 0.) { + *pr = 1.; + } else { + *pr = dscale / (sqrt(dscale * dscale / *pr + *pr) * sqrt(*pr)); + } + } + + if (wantd) { + +/* Compute estimates of Difu and Difl. */ + + if (wantd1) { + n1 = *m; + n2 = *n - *m; + i__ = n1 + 1; + ijb = 3; + +/* Frobenius norm-based Difu-estimate. */ + + i__1 = *lwork - (n1 << 1) * n2; + dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + i__ * + a_dim1], lda, &work[1], &n1, &b[b_offset], ldb, &b[i__ + + i__ * b_dim1], ldb, &work[n1 * n2 + 1], &n1, &dscale, & + dif[1], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], & + ierr); + +/* Frobenius norm-based Difl-estimate. */ + + i__1 = *lwork - (n1 << 1) * n2; + dtgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, &a[ + a_offset], lda, &work[1], &n2, &b[i__ + i__ * b_dim1], + ldb, &b[b_offset], ldb, &work[n1 * n2 + 1], &n2, &dscale, + &dif[2], &work[(n1 << 1) * n2 + 1], &i__1, &iwork[1], & + ierr); + } else { + + +/* Compute 1-norm-based estimates of Difu and Difl using */ +/* reversed communication with DLACN2. In each step a */ +/* generalized Sylvester equation or a transposed variant */ +/* is solved. */ + + kase = 0; + n1 = *m; + n2 = *n - *m; + i__ = n1 + 1; + ijb = 0; + mn2 = (n1 << 1) * n2; + +/* 1-norm-based estimate of Difu. */ + +L40: + dlacn2_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[1], &kase, + isave); + if (kase != 0) { + if (kase == 1) { + +/* Solve generalized Sylvester equation. */ + + i__1 = *lwork - (n1 << 1) * n2; + dtgsyl_("N", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + + i__ * a_dim1], lda, &work[1], &n1, &b[b_offset], + ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 + + 1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 + + 1], &i__1, &iwork[1], &ierr); + } else { + +/* Solve the transposed variant. */ + + i__1 = *lwork - (n1 << 1) * n2; + dtgsyl_("T", &ijb, &n1, &n2, &a[a_offset], lda, &a[i__ + + i__ * a_dim1], lda, &work[1], &n1, &b[b_offset], + ldb, &b[i__ + i__ * b_dim1], ldb, &work[n1 * n2 + + 1], &n1, &dscale, &dif[1], &work[(n1 << 1) * n2 + + 1], &i__1, &iwork[1], &ierr); + } + goto L40; + } + dif[1] = dscale / dif[1]; + +/* 1-norm-based estimate of Difl. */ + +L50: + dlacn2_(&mn2, &work[mn2 + 1], &work[1], &iwork[1], &dif[2], &kase, + isave); + if (kase != 0) { + if (kase == 1) { + +/* Solve generalized Sylvester equation. */ + + i__1 = *lwork - (n1 << 1) * n2; + dtgsyl_("N", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, + &a[a_offset], lda, &work[1], &n2, &b[i__ + i__ * + b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 + + 1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 + + 1], &i__1, &iwork[1], &ierr); + } else { + +/* Solve the transposed variant. */ + + i__1 = *lwork - (n1 << 1) * n2; + dtgsyl_("T", &ijb, &n2, &n1, &a[i__ + i__ * a_dim1], lda, + &a[a_offset], lda, &work[1], &n2, &b[i__ + i__ * + b_dim1], ldb, &b[b_offset], ldb, &work[n1 * n2 + + 1], &n2, &dscale, &dif[2], &work[(n1 << 1) * n2 + + 1], &i__1, &iwork[1], &ierr); + } + goto L50; + } + dif[2] = dscale / dif[2]; + + } + } + +L60: + +/* Compute generalized eigenvalues of reordered pair (A, B) and */ +/* normalize the generalized Schur form. */ + + pair = FALSE_; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = FALSE_; + } else { + + if (k < *n) { + if (a[k + 1 + k * a_dim1] != 0.) { + pair = TRUE_; + } + } + + if (pair) { + +/* Compute the eigenvalue(s) at position K. */ + + work[1] = a[k + k * a_dim1]; + work[2] = a[k + 1 + k * a_dim1]; + work[3] = a[k + (k + 1) * a_dim1]; + work[4] = a[k + 1 + (k + 1) * a_dim1]; + work[5] = b[k + k * b_dim1]; + work[6] = b[k + 1 + k * b_dim1]; + work[7] = b[k + (k + 1) * b_dim1]; + work[8] = b[k + 1 + (k + 1) * b_dim1]; + d__1 = smlnum * eps; + dlag2_(&work[1], &c__2, &work[5], &c__2, &d__1, &beta[k], & + beta[k + 1], &alphar[k], &alphar[k + 1], &alphai[k]); + alphai[k + 1] = -alphai[k]; + + } else { + + if (d_sign(&c_b28, &b[k + k * b_dim1]) < 0.) { + +/* If B(K,K) is negative, make it positive */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + a[k + i__ * a_dim1] = -a[k + i__ * a_dim1]; + b[k + i__ * b_dim1] = -b[k + i__ * b_dim1]; + if (*wantq) { + q[i__ + k * q_dim1] = -q[i__ + k * q_dim1]; + } +/* L70: */ + } + } + + alphar[k] = a[k + k * a_dim1]; + alphai[k] = 0.; + beta[k] = b[k + k * b_dim1]; + + } + } +/* L80: */ + } + + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + + return 0; + +/* End of DTGSEN */ + +} /* dtgsen_ */ + diff --git a/lapack-netlib/SRC/dtgsja.c b/lapack-netlib/SRC/dtgsja.c new file mode 100644 index 000000000..a3eb0953f --- /dev/null +++ b/lapack-netlib/SRC/dtgsja.c @@ -0,0 +1,1128 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTGSJA */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTGSJA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTGSJA( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, */ +/* LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, */ +/* Q, LDQ, WORK, NCALL MYCYCLE, INFO ) */ + +/* CHARACTER JOBQ, JOBU, JOBV */ +/* INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, */ +/* $ NCALL MYCYCLE, P */ +/* DOUBLE PRECISION TOLA, TOLB */ +/* DOUBLE PRECISION A( LDA, * ), ALPHA( * ), B( LDB, * ), */ +/* $ BETA( * ), Q( LDQ, * ), U( LDU, * ), */ +/* $ V( LDV, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTGSJA computes the generalized singular value decomposition (GSVD) */ +/* > of two real upper triangular (or trapezoidal) matrices A and B. */ +/* > */ +/* > On entry, it is assumed that matrices A and B have the following */ +/* > forms, which may be obtained by the preprocessing subroutine DGGSVP */ +/* > from a general M-by-N matrix A and P-by-N matrix B: */ +/* > */ +/* > N-K-L K L */ +/* > A = K ( 0 A12 A13 ) if M-K-L >= 0; */ +/* > L ( 0 0 A23 ) */ +/* > M-K-L ( 0 0 0 ) */ +/* > */ +/* > N-K-L K L */ +/* > A = K ( 0 A12 A13 ) if M-K-L < 0; */ +/* > M-K ( 0 0 A23 ) */ +/* > */ +/* > N-K-L K L */ +/* > B = L ( 0 0 B13 ) */ +/* > P-L ( 0 0 0 ) */ +/* > */ +/* > where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular */ +/* > upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0, */ +/* > otherwise A23 is (M-K)-by-L upper trapezoidal. */ +/* > */ +/* > On exit, */ +/* > */ +/* > U**T *A*Q = D1*( 0 R ), V**T *B*Q = D2*( 0 R ), */ +/* > */ +/* > where U, V and Q are orthogonal matrices. */ +/* > R is a nonsingular upper triangular matrix, and D1 and D2 are */ +/* > ``diagonal'' matrices, which are of the following structures: */ +/* > */ +/* > If M-K-L >= 0, */ +/* > */ +/* > K L */ +/* > D1 = K ( I 0 ) */ +/* > L ( 0 C ) */ +/* > M-K-L ( 0 0 ) */ +/* > */ +/* > K L */ +/* > D2 = L ( 0 S ) */ +/* > P-L ( 0 0 ) */ +/* > */ +/* > N-K-L K L */ +/* > ( 0 R ) = K ( 0 R11 R12 ) K */ +/* > L ( 0 0 R22 ) L */ +/* > */ +/* > where */ +/* > */ +/* > C = diag( ALPHA(K+1), ... , ALPHA(K+L) ), */ +/* > S = diag( BETA(K+1), ... , BETA(K+L) ), */ +/* > C**2 + S**2 = I. */ +/* > */ +/* > R is stored in A(1:K+L,N-K-L+1:N) on exit. */ +/* > */ +/* > If M-K-L < 0, */ +/* > */ +/* > K M-K K+L-M */ +/* > D1 = K ( I 0 0 ) */ +/* > M-K ( 0 C 0 ) */ +/* > */ +/* > K M-K K+L-M */ +/* > D2 = M-K ( 0 S 0 ) */ +/* > K+L-M ( 0 0 I ) */ +/* > P-L ( 0 0 0 ) */ +/* > */ +/* > N-K-L K M-K K+L-M */ +/* > ( 0 R ) = K ( 0 R11 R12 R13 ) */ +/* > M-K ( 0 0 R22 R23 ) */ +/* > K+L-M ( 0 0 0 R33 ) */ +/* > */ +/* > where */ +/* > C = diag( ALPHA(K+1), ... , ALPHA(M) ), */ +/* > S = diag( BETA(K+1), ... , BETA(M) ), */ +/* > C**2 + S**2 = I. */ +/* > */ +/* > R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored */ +/* > ( 0 R22 R23 ) */ +/* > in B(M-K+1:L,N+M-K-L+1:N) on exit. */ +/* > */ +/* > The computation of the orthogonal transformation matrices U, V or Q */ +/* > is optional. These matrices may either be formed explicitly, or they */ +/* > may be postmultiplied into input matrices U1, V1, or Q1. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBU */ +/* > \verbatim */ +/* > JOBU is CHARACTER*1 */ +/* > = 'U': U must contain an orthogonal matrix U1 on entry, and */ +/* > the product U1*U is returned; */ +/* > = 'I': U is initialized to the unit matrix, and the */ +/* > orthogonal matrix U is returned; */ +/* > = 'N': U is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBV */ +/* > \verbatim */ +/* > JOBV is CHARACTER*1 */ +/* > = 'V': V must contain an orthogonal matrix V1 on entry, and */ +/* > the product V1*V is returned; */ +/* > = 'I': V is initialized to the unit matrix, and the */ +/* > orthogonal matrix V is returned; */ +/* > = 'N': V is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBQ */ +/* > \verbatim */ +/* > JOBQ is CHARACTER*1 */ +/* > = 'Q': Q must contain an orthogonal matrix Q1 on entry, and */ +/* > the product Q1*Q is returned; */ +/* > = 'I': Q is initialized to the unit matrix, and the */ +/* > orthogonal matrix Q is returned; */ +/* > = 'N': Q is not computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows of the matrix B. P >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > */ +/* > K and L specify the subblocks in the input matrices A and B: */ +/* > A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N) */ +/* > of A and B, whose GSVD is going to be computed by DTGSJA. */ +/* > See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the M-by-N matrix A. */ +/* > On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular */ +/* > matrix R or part of R. See Purpose for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,N) */ +/* > On entry, the P-by-N matrix B. */ +/* > On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains */ +/* > a part of R. See Purpose for details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,P). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOLA */ +/* > \verbatim */ +/* > TOLA is DOUBLE PRECISION */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TOLB */ +/* > \verbatim */ +/* > TOLB is DOUBLE PRECISION */ +/* > */ +/* > TOLA and TOLB are the convergence criteria for the Jacobi- */ +/* > Kogbetliantz iteration procedure. Generally, they are the */ +/* > same as used in the preprocessing step, say */ +/* > TOLA = f2cmax(M,N)*norm(A)*MAZHEPS, */ +/* > TOLB = f2cmax(P,N)*norm(B)*MAZHEPS. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHA */ +/* > \verbatim */ +/* > ALPHA is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION array, dimension (N) */ +/* > */ +/* > On exit, ALPHA and BETA contain the generalized singular */ +/* > value pairs of A and B; */ +/* > ALPHA(1:K) = 1, */ +/* > BETA(1:K) = 0, */ +/* > and if M-K-L >= 0, */ +/* > ALPHA(K+1:K+L) = diag(C), */ +/* > BETA(K+1:K+L) = diag(S), */ +/* > or if M-K-L < 0, */ +/* > ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0 */ +/* > BETA(K+1:M) = S, BETA(M+1:K+L) = 1. */ +/* > Furthermore, if K+L < N, */ +/* > ALPHA(K+L+1:N) = 0 and */ +/* > BETA(K+L+1:N) = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] U */ +/* > \verbatim */ +/* > U is DOUBLE PRECISION array, dimension (LDU,M) */ +/* > On entry, if JOBU = 'U', U must contain a matrix U1 (usually */ +/* > the orthogonal matrix returned by DGGSVP). */ +/* > On exit, */ +/* > if JOBU = 'I', U contains the orthogonal matrix U; */ +/* > if JOBU = 'U', U contains the product U1*U. */ +/* > If JOBU = 'N', U is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > The leading dimension of the array U. LDU >= f2cmax(1,M) if */ +/* > JOBU = 'U'; LDU >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] V */ +/* > \verbatim */ +/* > V is DOUBLE PRECISION array, dimension (LDV,P) */ +/* > On entry, if JOBV = 'V', V must contain a matrix V1 (usually */ +/* > the orthogonal matrix returned by DGGSVP). */ +/* > On exit, */ +/* > if JOBV = 'I', V contains the orthogonal matrix V; */ +/* > if JOBV = 'V', V contains the product V1*V. */ +/* > If JOBV = 'N', V is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. LDV >= f2cmax(1,P) if */ +/* > JOBV = 'V'; LDV >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is DOUBLE PRECISION array, dimension (LDQ,N) */ +/* > On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually */ +/* > the orthogonal matrix returned by DGGSVP). */ +/* > On exit, */ +/* > if JOBQ = 'I', Q contains the orthogonal matrix Q; */ +/* > if JOBQ = 'Q', Q contains the product Q1*Q. */ +/* > If JOBQ = 'N', Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= f2cmax(1,N) if */ +/* > JOBQ = 'Q'; LDQ >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] NCALL MYCYCLE */ +/* > \verbatim */ +/* > NCALL MYCYCLE is INTEGER */ +/* > The number of cycles required for convergence. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > = 1: the procedure does not converge after MAXIT cycles. */ +/* > \endverbatim */ +/* > */ +/* > \verbatim */ +/* > Internal Parameters */ +/* > =================== */ +/* > */ +/* > MAXIT INTEGER */ +/* > MAXIT specifies the total loops that the iterative procedure */ +/* > may take. If after MAXIT cycles, the routine fails to */ +/* > converge, we return INFO = 1. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce */ +/* > f2cmin(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L */ +/* > matrix B13 to the form: */ +/* > */ +/* > U1**T *A13*Q1 = C1*R1; V1**T *B13*Q1 = S1*R1, */ +/* > */ +/* > where U1, V1 and Q1 are orthogonal matrix, and Z**T is the transpose */ +/* > of Z. C1 and S1 are diagonal matrices satisfying */ +/* > */ +/* > C1**2 + S1**2 = I, */ +/* > */ +/* > and R1 is an L-by-L nonsingular upper triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtgsja_(char *jobu, char *jobv, char *jobq, integer *m, + integer *p, integer *n, integer *k, integer *l, doublereal *a, + integer *lda, doublereal *b, integer *ldb, doublereal *tola, + doublereal *tolb, doublereal *alpha, doublereal *beta, doublereal *u, + integer *ldu, doublereal *v, integer *ldv, doublereal *q, integer * + ldq, doublereal *work, integer *ncallmycycle, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, q_dim1, q_offset, u_dim1, + u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4; + doublereal d__1; + + /* Local variables */ + extern /* Subroutine */ int drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *); + integer kcallmycycle, i__, j; + doublereal gamma; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + doublereal a1; + logical initq; + doublereal a2, a3, b1; + logical initu, initv, wantq, upper; + doublereal b2, b3; + logical wantu, wantv; + doublereal error, ssmin; + extern /* Subroutine */ int dlags2_(logical *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *), dlapll_(integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *), dlartg_( + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *), dlaset_(char *, integer *, integer *, doublereal *, + doublereal *, doublereal *, integer *), xerbla_(char *, + integer *, ftnlen); +// extern integer myhuge_(doublereal *); + doublereal csq, csu, csv, snq, rwk, snu, snv; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --alpha; + --beta; + u_dim1 = *ldu; + u_offset = 1 + u_dim1 * 1; + u -= u_offset; + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --work; + + /* Function Body */ + initu = lsame_(jobu, "I"); + wantu = initu || lsame_(jobu, "U"); + + initv = lsame_(jobv, "I"); + wantv = initv || lsame_(jobv, "V"); + + initq = lsame_(jobq, "I"); + wantq = initq || lsame_(jobq, "Q"); + + *info = 0; + if (! (initu || wantu || lsame_(jobu, "N"))) { + *info = -1; + } else if (! (initv || wantv || lsame_(jobv, "N"))) + { + *info = -2; + } else if (! (initq || wantq || lsame_(jobq, "N"))) + { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*p < 0) { + *info = -5; + } else if (*n < 0) { + *info = -6; + } else if (*lda < f2cmax(1,*m)) { + *info = -10; + } else if (*ldb < f2cmax(1,*p)) { + *info = -12; + } else if (*ldu < 1 || wantu && *ldu < *m) { + *info = -18; + } else if (*ldv < 1 || wantv && *ldv < *p) { + *info = -20; + } else if (*ldq < 1 || wantq && *ldq < *n) { + *info = -22; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTGSJA", &i__1, (ftnlen)6); + return 0; + } + +/* Initialize U, V and Q, if necessary */ + + if (initu) { + dlaset_("Full", m, m, &c_b1, &c_b15, &u[u_offset], ldu); + } + if (initv) { + dlaset_("Full", p, p, &c_b1, &c_b15, &v[v_offset], ldv); + } + if (initq) { + dlaset_("Full", n, n, &c_b1, &c_b15, &q[q_offset], ldq); + } + +/* Loop until convergence */ + + upper = FALSE_; + for (kcallmycycle = 1; kcallmycycle <= 40; ++kcallmycycle) { + + upper = ! upper; + + i__1 = *l - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *l; + for (j = i__ + 1; j <= i__2; ++j) { + + a1 = 0.; + a2 = 0.; + a3 = 0.; + if (*k + i__ <= *m) { + a1 = a[*k + i__ + (*n - *l + i__) * a_dim1]; + } + if (*k + j <= *m) { + a3 = a[*k + j + (*n - *l + j) * a_dim1]; + } + + b1 = b[i__ + (*n - *l + i__) * b_dim1]; + b3 = b[j + (*n - *l + j) * b_dim1]; + + if (upper) { + if (*k + i__ <= *m) { + a2 = a[*k + i__ + (*n - *l + j) * a_dim1]; + } + b2 = b[i__ + (*n - *l + j) * b_dim1]; + } else { + if (*k + j <= *m) { + a2 = a[*k + j + (*n - *l + i__) * a_dim1]; + } + b2 = b[j + (*n - *l + i__) * b_dim1]; + } + + dlags2_(&upper, &a1, &a2, &a3, &b1, &b2, &b3, &csu, &snu, & + csv, &snv, &csq, &snq); + +/* Update (K+I)-th and (K+J)-th rows of matrix A: U**T *A */ + + if (*k + j <= *m) { + drot_(l, &a[*k + j + (*n - *l + 1) * a_dim1], lda, &a[*k + + i__ + (*n - *l + 1) * a_dim1], lda, &csu, &snu); + } + +/* Update I-th and J-th rows of matrix B: V**T *B */ + + drot_(l, &b[j + (*n - *l + 1) * b_dim1], ldb, &b[i__ + (*n - * + l + 1) * b_dim1], ldb, &csv, &snv); + +/* Update (N-L+I)-th and (N-L+J)-th columns of matrices */ +/* A and B: A*Q and B*Q */ + +/* Computing MIN */ + i__4 = *k + *l; + i__3 = f2cmin(i__4,*m); + drot_(&i__3, &a[(*n - *l + j) * a_dim1 + 1], &c__1, &a[(*n - * + l + i__) * a_dim1 + 1], &c__1, &csq, &snq); + + drot_(l, &b[(*n - *l + j) * b_dim1 + 1], &c__1, &b[(*n - *l + + i__) * b_dim1 + 1], &c__1, &csq, &snq); + + if (upper) { + if (*k + i__ <= *m) { + a[*k + i__ + (*n - *l + j) * a_dim1] = 0.; + } + b[i__ + (*n - *l + j) * b_dim1] = 0.; + } else { + if (*k + j <= *m) { + a[*k + j + (*n - *l + i__) * a_dim1] = 0.; + } + b[j + (*n - *l + i__) * b_dim1] = 0.; + } + +/* Update orthogonal matrices U, V, Q, if desired. */ + + if (wantu && *k + j <= *m) { + drot_(m, &u[(*k + j) * u_dim1 + 1], &c__1, &u[(*k + i__) * + u_dim1 + 1], &c__1, &csu, &snu); + } + + if (wantv) { + drot_(p, &v[j * v_dim1 + 1], &c__1, &v[i__ * v_dim1 + 1], + &c__1, &csv, &snv); + } + + if (wantq) { + drot_(n, &q[(*n - *l + j) * q_dim1 + 1], &c__1, &q[(*n - * + l + i__) * q_dim1 + 1], &c__1, &csq, &snq); + } + +/* L10: */ + } +/* L20: */ + } + + if (! upper) { + +/* The matrices A13 and B13 were lower triangular at the start */ +/* of the cycle, and are now upper triangular. */ + +/* Convergence test: test the parallelism of the corresponding */ +/* rows of A and B. */ + + error = 0.; +/* Computing MIN */ + i__2 = *l, i__3 = *m - *k; + i__1 = f2cmin(i__2,i__3); + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *l - i__ + 1; + dcopy_(&i__2, &a[*k + i__ + (*n - *l + i__) * a_dim1], lda, & + work[1], &c__1); + i__2 = *l - i__ + 1; + dcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &work[* + l + 1], &c__1); + i__2 = *l - i__ + 1; + dlapll_(&i__2, &work[1], &c__1, &work[*l + 1], &c__1, &ssmin); + error = f2cmax(error,ssmin); +/* L30: */ + } + + if (abs(error) <= f2cmin(*tola,*tolb)) { + goto L50; + } + } + +/* End of cycle loop */ + +/* L40: */ + } + +/* The algorithm has not converged after MAXIT cycles. */ + + *info = 1; + goto L100; + +L50: + +/* If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged. */ +/* Compute the generalized singular value pairs (ALPHA, BETA), and */ +/* set the triangular matrix R to array A. */ + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + alpha[i__] = 1.; + beta[i__] = 0.; +/* L60: */ + } + +/* Computing MIN */ + i__2 = *l, i__3 = *m - *k; + i__1 = f2cmin(i__2,i__3); + for (i__ = 1; i__ <= i__1; ++i__) { + + a1 = a[*k + i__ + (*n - *l + i__) * a_dim1]; + b1 = b[i__ + (*n - *l + i__) * b_dim1]; + gamma = b1 / a1; + + if (gamma <= (doublereal) myhuge_(&c_b1) && gamma >= -((doublereal) + myhuge_(&c_b1))) { + +/* change sign if necessary */ + + if (gamma < 0.) { + i__2 = *l - i__ + 1; + dscal_(&i__2, &c_b44, &b[i__ + (*n - *l + i__) * b_dim1], ldb) + ; + if (wantv) { + dscal_(p, &c_b44, &v[i__ * v_dim1 + 1], &c__1); + } + } + + d__1 = abs(gamma); + dlartg_(&d__1, &c_b15, &beta[*k + i__], &alpha[*k + i__], &rwk); + + if (alpha[*k + i__] >= beta[*k + i__]) { + i__2 = *l - i__ + 1; + d__1 = 1. / alpha[*k + i__]; + dscal_(&i__2, &d__1, &a[*k + i__ + (*n - *l + i__) * a_dim1], + lda); + } else { + i__2 = *l - i__ + 1; + d__1 = 1. / beta[*k + i__]; + dscal_(&i__2, &d__1, &b[i__ + (*n - *l + i__) * b_dim1], ldb); + i__2 = *l - i__ + 1; + dcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k + + i__ + (*n - *l + i__) * a_dim1], lda); + } + + } else { + + alpha[*k + i__] = 0.; + beta[*k + i__] = 1.; + i__2 = *l - i__ + 1; + dcopy_(&i__2, &b[i__ + (*n - *l + i__) * b_dim1], ldb, &a[*k + + i__ + (*n - *l + i__) * a_dim1], lda); + + } + +/* L70: */ + } + +/* Post-assignment */ + + i__1 = *k + *l; + for (i__ = *m + 1; i__ <= i__1; ++i__) { + alpha[i__] = 0.; + beta[i__] = 1.; +/* L80: */ + } + + if (*k + *l < *n) { + i__1 = *n; + for (i__ = *k + *l + 1; i__ <= i__1; ++i__) { + alpha[i__] = 0.; + beta[i__] = 0.; +/* L90: */ + } + } + +L100: + *ncallmycycle = kcallmycycle; + return 0; + +/* End of DTGSJA */ + +} /* dtgsja_ */ + diff --git a/lapack-netlib/SRC/dtgsna.c b/lapack-netlib/SRC/dtgsna.c new file mode 100644 index 000000000..9a44448b3 --- /dev/null +++ b/lapack-netlib/SRC/dtgsna.c @@ -0,0 +1,1173 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTGSNA */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTGSNA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, */ +/* LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, */ +/* IWORK, INFO ) */ + +/* CHARACTER HOWMNY, JOB */ +/* INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N */ +/* LOGICAL SELECT( * ) */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DIF( * ), S( * ), */ +/* $ VL( LDVL, * ), VR( LDVR, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTGSNA estimates reciprocal condition numbers for specified */ +/* > eigenvalues and/or eigenvectors of a matrix pair (A, B) in */ +/* > generalized real Schur canonical form (or of any matrix pair */ +/* > (Q*A*Z**T, Q*B*Z**T) with orthogonal matrices Q and Z, where */ +/* > Z**T denotes the transpose of Z. */ +/* > */ +/* > (A, B) must be in generalized real Schur form (as returned by DGGES), */ +/* > i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal */ +/* > blocks. B is upper triangular. */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOB */ +/* > \verbatim */ +/* > JOB is CHARACTER*1 */ +/* > Specifies whether condition numbers are required for */ +/* > eigenvalues (S) or eigenvectors (DIF): */ +/* > = 'E': for eigenvalues only (S); */ +/* > = 'V': for eigenvectors only (DIF); */ +/* > = 'B': for both eigenvalues and eigenvectors (S and DIF). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] HOWMNY */ +/* > \verbatim */ +/* > HOWMNY is CHARACTER*1 */ +/* > = 'A': compute condition numbers for all eigenpairs; */ +/* > = 'S': compute condition numbers for selected eigenpairs */ +/* > specified by the array SELECT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > If HOWMNY = 'S', SELECT specifies the eigenpairs for which */ +/* > condition numbers are required. To select condition numbers */ +/* > for the eigenpair corresponding to a real eigenvalue w(j), */ +/* > SELECT(j) must be set to .TRUE.. To select condition numbers */ +/* > corresponding to a complex conjugate pair of eigenvalues w(j) */ +/* > and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be */ +/* > set to .TRUE.. */ +/* > If HOWMNY = 'A', SELECT is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the square matrix pair (A, B). N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > The upper quasi-triangular matrix A in the pair (A,B). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,N) */ +/* > The upper triangular matrix B in the pair (A,B). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VL */ +/* > \verbatim */ +/* > VL is DOUBLE PRECISION array, dimension (LDVL,M) */ +/* > If JOB = 'E' or 'B', VL must contain left eigenvectors of */ +/* > (A, B), corresponding to the eigenpairs specified by HOWMNY */ +/* > and SELECT. The eigenvectors must be stored in consecutive */ +/* > columns of VL, as returned by DTGEVC. */ +/* > If JOB = 'V', VL is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the array VL. LDVL >= 1. */ +/* > If JOB = 'E' or 'B', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VR */ +/* > \verbatim */ +/* > VR is DOUBLE PRECISION array, dimension (LDVR,M) */ +/* > If JOB = 'E' or 'B', VR must contain right eigenvectors of */ +/* > (A, B), corresponding to the eigenpairs specified by HOWMNY */ +/* > and SELECT. The eigenvectors must be stored in consecutive */ +/* > columns ov VR, as returned by DTGEVC. */ +/* > If JOB = 'V', VR is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the array VR. LDVR >= 1. */ +/* > If JOB = 'E' or 'B', LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is DOUBLE PRECISION array, dimension (MM) */ +/* > If JOB = 'E' or 'B', the reciprocal condition numbers of the */ +/* > selected eigenvalues, stored in consecutive elements of the */ +/* > array. For a complex conjugate pair of eigenvalues two */ +/* > consecutive elements of S are set to the same value. Thus */ +/* > S(j), DIF(j), and the j-th columns of VL and VR all */ +/* > correspond to the same eigenpair (but not in general the */ +/* > j-th eigenpair, unless all eigenpairs are selected). */ +/* > If JOB = 'V', S is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DIF */ +/* > \verbatim */ +/* > DIF is DOUBLE PRECISION array, dimension (MM) */ +/* > If JOB = 'V' or 'B', the estimated reciprocal condition */ +/* > numbers of the selected eigenvectors, stored in consecutive */ +/* > elements of the array. For a complex eigenvector two */ +/* > consecutive elements of DIF are set to the same value. If */ +/* > the eigenvalues cannot be reordered to compute DIF(j), DIF(j) */ +/* > is set to 0; this can only occur when the true value would be */ +/* > very small anyway. */ +/* > If JOB = 'E', DIF is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MM */ +/* > \verbatim */ +/* > MM is INTEGER */ +/* > The number of elements in the arrays S and DIF. MM >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of elements of the arrays S and DIF used to store */ +/* > the specified condition numbers; for each selected real */ +/* > eigenvalue one element is used, and for each selected complex */ +/* > conjugate pair of eigenvalues, two elements are used. */ +/* > If HOWMNY = 'A', M is set to N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,N). */ +/* > If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N + 6) */ +/* > If JOB = 'E', IWORK is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > =0: Successful exit */ +/* > <0: If INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The reciprocal of the condition number of a generalized eigenvalue */ +/* > w = (a, b) is defined as */ +/* > */ +/* > S(w) = (|u**TAv|**2 + |u**TBv|**2)**(1/2) / (norm(u)*norm(v)) */ +/* > */ +/* > where u and v are the left and right eigenvectors of (A, B) */ +/* > corresponding to w; |z| denotes the absolute value of the complex */ +/* > number, and norm(u) denotes the 2-norm of the vector u. */ +/* > The pair (a, b) corresponds to an eigenvalue w = a/b (= u**TAv/u**TBv) */ +/* > of the matrix pair (A, B). If both a and b equal zero, then (A B) is */ +/* > singular and S(I) = -1 is returned. */ +/* > */ +/* > An approximate error bound on the chordal distance between the i-th */ +/* > computed generalized eigenvalue w and the corresponding exact */ +/* > eigenvalue lambda is */ +/* > */ +/* > chord(w, lambda) <= EPS * norm(A, B) / S(I) */ +/* > */ +/* > where EPS is the machine precision. */ +/* > */ +/* > The reciprocal of the condition number DIF(i) of right eigenvector u */ +/* > and left eigenvector v corresponding to the generalized eigenvalue w */ +/* > is defined as follows: */ +/* > */ +/* > a) If the i-th eigenvalue w = (a,b) is real */ +/* > */ +/* > Suppose U and V are orthogonal transformations such that */ +/* > */ +/* > U**T*(A, B)*V = (S, T) = ( a * ) ( b * ) 1 */ +/* > ( 0 S22 ),( 0 T22 ) n-1 */ +/* > 1 n-1 1 n-1 */ +/* > */ +/* > Then the reciprocal condition number DIF(i) is */ +/* > */ +/* > Difl((a, b), (S22, T22)) = sigma-f2cmin( Zl ), */ +/* > */ +/* > where sigma-f2cmin(Zl) denotes the smallest singular value of the */ +/* > 2(n-1)-by-2(n-1) matrix */ +/* > */ +/* > Zl = [ kron(a, In-1) -kron(1, S22) ] */ +/* > [ kron(b, In-1) -kron(1, T22) ] . */ +/* > */ +/* > Here In-1 is the identity matrix of size n-1. kron(X, Y) is the */ +/* > Kronecker product between the matrices X and Y. */ +/* > */ +/* > Note that if the default method for computing DIF(i) is wanted */ +/* > (see DLATDF), then the parameter DIFDRI (see below) should be */ +/* > changed from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). */ +/* > See DTGSYL for more details. */ +/* > */ +/* > b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair, */ +/* > */ +/* > Suppose U and V are orthogonal transformations such that */ +/* > */ +/* > U**T*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2 */ +/* > ( 0 S22 ),( 0 T22) n-2 */ +/* > 2 n-2 2 n-2 */ +/* > */ +/* > and (S11, T11) corresponds to the complex conjugate eigenvalue */ +/* > pair (w, conjg(w)). There exist unitary matrices U1 and V1 such */ +/* > that */ +/* > */ +/* > U1**T*S11*V1 = ( s11 s12 ) and U1**T*T11*V1 = ( t11 t12 ) */ +/* > ( 0 s22 ) ( 0 t22 ) */ +/* > */ +/* > where the generalized eigenvalues w = s11/t11 and */ +/* > conjg(w) = s22/t22. */ +/* > */ +/* > Then the reciprocal condition number DIF(i) is bounded by */ +/* > */ +/* > f2cmin( d1, f2cmax( 1, |real(s11)/real(s22)| )*d2 ) */ +/* > */ +/* > where, d1 = Difl((s11, t11), (s22, t22)) = sigma-f2cmin(Z1), where */ +/* > Z1 is the complex 2-by-2 matrix */ +/* > */ +/* > Z1 = [ s11 -s22 ] */ +/* > [ t11 -t22 ], */ +/* > */ +/* > This is done by computing (using real arithmetic) the */ +/* > roots of the characteristical polynomial det(Z1**T * Z1 - lambda I), */ +/* > where Z1**T denotes the transpose of Z1 and det(X) denotes */ +/* > the determinant of X. */ +/* > */ +/* > and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an */ +/* > upper bound on sigma-f2cmin(Z2), where Z2 is (2n-2)-by-(2n-2) */ +/* > */ +/* > Z2 = [ kron(S11**T, In-2) -kron(I2, S22) ] */ +/* > [ kron(T11**T, In-2) -kron(I2, T22) ] */ +/* > */ +/* > Note that if the default method for computing DIF is wanted (see */ +/* > DLATDF), then the parameter DIFDRI (see below) should be changed */ +/* > from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). See DTGSYL */ +/* > for more details. */ +/* > */ +/* > For each eigenvalue/vector specified by SELECT, DIF stores a */ +/* > Frobenius norm-based estimate of Difl. */ +/* > */ +/* > An approximate error bound for the i-th computed eigenvector VL(i) or */ +/* > VR(i) is given by */ +/* > */ +/* > EPS * norm(A, B) / DIF(i). */ +/* > */ +/* > See ref. [2-3] for more details and further references. */ +/* > \endverbatim */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* > Umea University, S-901 87 Umea, Sweden. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > \verbatim */ +/* > */ +/* > [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the */ +/* > Generalized Real Schur Form of a Regular Matrix Pair (A, B), in */ +/* > M.S. Moonen et al (eds), Linear Algebra for Large Scale and */ +/* > Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218. */ +/* > */ +/* > [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified */ +/* > Eigenvalues of a Regular Matrix Pair (A, B) and Condition */ +/* > Estimation: Theory, Algorithms and Software, */ +/* > Report UMINF - 94.04, Department of Computing Science, Umea */ +/* > University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working */ +/* > Note 87. To appear in Numerical Algorithms, 1996. */ +/* > */ +/* > [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */ +/* > for Solving the Generalized Sylvester Equation and Estimating the */ +/* > Separation between Regular Matrix Pairs, Report UMINF - 93.23, */ +/* > Department of Computing Science, Umea University, S-901 87 Umea, */ +/* > Sweden, December 1993, Revised April 1994, Also as LAPACK Working */ +/* > Note 75. To appear in ACM Trans. on Math. Software, Vol 22, */ +/* > No 1, 1996. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtgsna_(char *job, char *howmny, logical *select, + integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, + doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr, + doublereal *s, doublereal *dif, integer *mm, integer *m, doublereal * + work, integer *lwork, integer *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, vl_dim1, vl_offset, vr_dim1, + vr_offset, i__1, i__2; + doublereal d__1, d__2; + + /* Local variables */ + doublereal beta, cond; + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + logical pair; + integer ierr; + doublereal uhav, uhbv; + integer ifst; + doublereal lnrm; + integer ilst; + doublereal rnrm; + extern /* Subroutine */ int dlag2_(doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *); + extern doublereal dnrm2_(integer *, doublereal *, integer *); + doublereal root1, root2; + integer i__, k; + doublereal scale; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *); + doublereal uhavi, uhbvi, tmpii, c1, c2; + integer lwmin; + logical wants; + doublereal tmpir; + integer n1, n2; + doublereal tmpri, dummy[1], tmprr; + extern doublereal dlapy2_(doublereal *, doublereal *); + doublereal dummy1[1]; + extern doublereal dlamch_(char *); + integer ks; + doublereal alphai; + integer iz; + doublereal alphar; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen), dtgexc_(logical *, logical *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, integer *, + integer *, doublereal *, integer *, integer *); + logical wantbh, wantdf, somcon; + doublereal alprqt; + extern /* Subroutine */ int dtgsyl_(char *, integer *, integer *, integer + *, doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + integer *, integer *, integer *); + doublereal smlnum; + logical lquery; + doublereal eps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + --select; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --s; + --dif; + --work; + --iwork; + + /* Function Body */ + wantbh = lsame_(job, "B"); + wants = lsame_(job, "E") || wantbh; + wantdf = lsame_(job, "V") || wantbh; + + somcon = lsame_(howmny, "S"); + + *info = 0; + lquery = *lwork == -1; + + if (! wants && ! wantdf) { + *info = -1; + } else if (! lsame_(howmny, "A") && ! somcon) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else if (wants && *ldvl < *n) { + *info = -10; + } else if (wants && *ldvr < *n) { + *info = -12; + } else { + +/* Set M to the number of eigenpairs for which condition numbers */ +/* are required, and test MM. */ + + if (somcon) { + *m = 0; + pair = FALSE_; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = FALSE_; + } else { + if (k < *n) { + if (a[k + 1 + k * a_dim1] == 0.) { + if (select[k]) { + ++(*m); + } + } else { + pair = TRUE_; + if (select[k] || select[k + 1]) { + *m += 2; + } + } + } else { + if (select[*n]) { + ++(*m); + } + } + } +/* L10: */ + } + } else { + *m = *n; + } + + if (*n == 0) { + lwmin = 1; + } else if (lsame_(job, "V") || lsame_(job, + "B")) { + lwmin = (*n << 1) * (*n + 2) + 16; + } else { + lwmin = *n; + } + work[1] = (doublereal) lwmin; + + if (*mm < *m) { + *info = -15; + } else if (*lwork < lwmin && ! lquery) { + *info = -18; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTGSNA", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + smlnum = dlamch_("S") / eps; + ks = 0; + pair = FALSE_; + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + +/* Determine whether A(k,k) begins a 1-by-1 or 2-by-2 block. */ + + if (pair) { + pair = FALSE_; + goto L20; + } else { + if (k < *n) { + pair = a[k + 1 + k * a_dim1] != 0.; + } + } + +/* Determine whether condition numbers are required for the k-th */ +/* eigenpair. */ + + if (somcon) { + if (pair) { + if (! select[k] && ! select[k + 1]) { + goto L20; + } + } else { + if (! select[k]) { + goto L20; + } + } + } + + ++ks; + + if (wants) { + +/* Compute the reciprocal condition number of the k-th */ +/* eigenvalue. */ + + if (pair) { + +/* Complex eigenvalue pair. */ + + d__1 = dnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1); + d__2 = dnrm2_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1); + rnrm = dlapy2_(&d__1, &d__2); + d__1 = dnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1); + d__2 = dnrm2_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1); + lnrm = dlapy2_(&d__1, &d__2); + dgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[ks * vr_dim1 + + 1], &c__1, &c_b21, &work[1], &c__1); + tmprr = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], & + c__1); + tmpri = ddot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1], + &c__1); + dgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[(ks + 1) * + vr_dim1 + 1], &c__1, &c_b21, &work[1], &c__1); + tmpii = ddot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1], + &c__1); + tmpir = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], & + c__1); + uhav = tmprr + tmpii; + uhavi = tmpir - tmpri; + dgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[ks * vr_dim1 + + 1], &c__1, &c_b21, &work[1], &c__1); + tmprr = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], & + c__1); + tmpri = ddot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1], + &c__1); + dgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[(ks + 1) * + vr_dim1 + 1], &c__1, &c_b21, &work[1], &c__1); + tmpii = ddot_(n, &work[1], &c__1, &vl[(ks + 1) * vl_dim1 + 1], + &c__1); + tmpir = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], & + c__1); + uhbv = tmprr + tmpii; + uhbvi = tmpir - tmpri; + uhav = dlapy2_(&uhav, &uhavi); + uhbv = dlapy2_(&uhbv, &uhbvi); + cond = dlapy2_(&uhav, &uhbv); + s[ks] = cond / (rnrm * lnrm); + s[ks + 1] = s[ks]; + + } else { + +/* Real eigenvalue. */ + + rnrm = dnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1); + lnrm = dnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1); + dgemv_("N", n, n, &c_b19, &a[a_offset], lda, &vr[ks * vr_dim1 + + 1], &c__1, &c_b21, &work[1], &c__1); + uhav = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1) + ; + dgemv_("N", n, n, &c_b19, &b[b_offset], ldb, &vr[ks * vr_dim1 + + 1], &c__1, &c_b21, &work[1], &c__1); + uhbv = ddot_(n, &work[1], &c__1, &vl[ks * vl_dim1 + 1], &c__1) + ; + cond = dlapy2_(&uhav, &uhbv); + if (cond == 0.) { + s[ks] = -1.; + } else { + s[ks] = cond / (rnrm * lnrm); + } + } + } + + if (wantdf) { + if (*n == 1) { + dif[ks] = dlapy2_(&a[a_dim1 + 1], &b[b_dim1 + 1]); + goto L20; + } + +/* Estimate the reciprocal condition number of the k-th */ +/* eigenvectors. */ + if (pair) { + +/* Copy the 2-by 2 pencil beginning at (A(k,k), B(k, k)). */ +/* Compute the eigenvalue(s) at position K. */ + + work[1] = a[k + k * a_dim1]; + work[2] = a[k + 1 + k * a_dim1]; + work[3] = a[k + (k + 1) * a_dim1]; + work[4] = a[k + 1 + (k + 1) * a_dim1]; + work[5] = b[k + k * b_dim1]; + work[6] = b[k + 1 + k * b_dim1]; + work[7] = b[k + (k + 1) * b_dim1]; + work[8] = b[k + 1 + (k + 1) * b_dim1]; + d__1 = smlnum * eps; + dlag2_(&work[1], &c__2, &work[5], &c__2, &d__1, &beta, dummy1, + &alphar, dummy, &alphai); + alprqt = 1.; + c1 = (alphar * alphar + alphai * alphai + beta * beta) * 2.; + c2 = beta * 4. * beta * alphai * alphai; + root1 = c1 + sqrt(c1 * c1 - c2 * 4.); + root2 = c2 / root1; + root1 /= 2.; +/* Computing MIN */ + d__1 = sqrt(root1), d__2 = sqrt(root2); + cond = f2cmin(d__1,d__2); + } + +/* Copy the matrix (A, B) to the array WORK and swap the */ +/* diagonal block beginning at A(k,k) to the (1,1) position. */ + + dlacpy_("Full", n, n, &a[a_offset], lda, &work[1], n); + dlacpy_("Full", n, n, &b[b_offset], ldb, &work[*n * *n + 1], n); + ifst = k; + ilst = 1; + + i__2 = *lwork - (*n << 1) * *n; + dtgexc_(&c_false, &c_false, n, &work[1], n, &work[*n * *n + 1], n, + dummy, &c__1, dummy1, &c__1, &ifst, &ilst, &work[(*n * * + n << 1) + 1], &i__2, &ierr); + + if (ierr > 0) { + +/* Ill-conditioned problem - swap rejected. */ + + dif[ks] = 0.; + } else { + +/* Reordering successful, solve generalized Sylvester */ +/* equation for R and L, */ +/* A22 * R - L * A11 = A12 */ +/* B22 * R - L * B11 = B12, */ +/* and compute estimate of Difl((A11,B11), (A22, B22)). */ + + n1 = 1; + if (work[2] != 0.) { + n1 = 2; + } + n2 = *n - n1; + if (n2 == 0) { + dif[ks] = cond; + } else { + i__ = *n * *n + 1; + iz = (*n << 1) * *n + 1; + i__2 = *lwork - (*n << 1) * *n; + dtgsyl_("N", &c__3, &n2, &n1, &work[*n * n1 + n1 + 1], n, + &work[1], n, &work[n1 + 1], n, &work[*n * n1 + n1 + + i__], n, &work[i__], n, &work[n1 + i__], n, & + scale, &dif[ks], &work[iz + 1], &i__2, &iwork[1], + &ierr); + + if (pair) { +/* Computing MIN */ + d__1 = f2cmax(1.,alprqt) * dif[ks]; + dif[ks] = f2cmin(d__1,cond); + } + } + } + if (pair) { + dif[ks + 1] = dif[ks]; + } + } + if (pair) { + ++ks; + } + +L20: + ; + } + work[1] = (doublereal) lwmin; + return 0; + +/* End of DTGSNA */ + +} /* dtgsna_ */ + diff --git a/lapack-netlib/SRC/dtgsy2.c b/lapack-netlib/SRC/dtgsy2.c new file mode 100644 index 000000000..b9c862e63 --- /dev/null +++ b/lapack-netlib/SRC/dtgsy2.c @@ -0,0 +1,1588 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTGSY2 solves the generalized Sylvester equation (unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTGSY2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, */ +/* LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL, */ +/* IWORK, PQ, INFO ) */ + +/* CHARACTER TRANS */ +/* INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N, */ +/* $ PQ */ +/* DOUBLE PRECISION RDSCAL, RDSUM, SCALE */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), */ +/* $ D( LDD, * ), E( LDE, * ), F( LDF, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTGSY2 solves the generalized Sylvester equation: */ +/* > */ +/* > A * R - L * B = scale * C (1) */ +/* > D * R - L * E = scale * F, */ +/* > */ +/* > using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices, */ +/* > (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M, */ +/* > N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E) */ +/* > must be in generalized Schur canonical form, i.e. A, B are upper */ +/* > quasi triangular and D, E are upper triangular. The solution (R, L) */ +/* > overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor */ +/* > chosen to avoid overflow. */ +/* > */ +/* > In matrix notation solving equation (1) corresponds to solve */ +/* > Z*x = scale*b, where Z is defined as */ +/* > */ +/* > Z = [ kron(In, A) -kron(B**T, Im) ] (2) */ +/* > [ kron(In, D) -kron(E**T, Im) ], */ +/* > */ +/* > Ik is the identity matrix of size k and X**T is the transpose of X. */ +/* > kron(X, Y) is the Kronecker product between the matrices X and Y. */ +/* > In the process of solving (1), we solve a number of such systems */ +/* > where Dim(In), Dim(In) = 1 or 2. */ +/* > */ +/* > If TRANS = 'T', solve the transposed system Z**T*y = scale*b for y, */ +/* > which is equivalent to solve for R and L in */ +/* > */ +/* > A**T * R + D**T * L = scale * C (3) */ +/* > R * B**T + L * E**T = scale * -F */ +/* > */ +/* > This case is used to compute an estimate of Dif[(A, D), (B, E)] = */ +/* > sigma_min(Z) using reverse communication with DLACON. */ +/* > */ +/* > DTGSY2 also (IJOB >= 1) contributes to the computation in DTGSYL */ +/* > of an upper bound on the separation between to matrix pairs. Then */ +/* > the input (A, D), (B, E) are sub-pencils of the matrix pair in */ +/* > DTGSYL. See DTGSYL for details. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': solve the generalized Sylvester equation (1). */ +/* > = 'T': solve the 'transposed' system (3). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IJOB */ +/* > \verbatim */ +/* > IJOB is INTEGER */ +/* > Specifies what kind of functionality to be performed. */ +/* > = 0: solve (1) only. */ +/* > = 1: A contribution from this subsystem to a Frobenius */ +/* > norm-based estimate of the separation between two matrix */ +/* > pairs is computed. (look ahead strategy is used). */ +/* > = 2: A contribution from this subsystem to a Frobenius */ +/* > norm-based estimate of the separation between two matrix */ +/* > pairs is computed. (DGECON on sub-systems is used.) */ +/* > Not referenced if TRANS = 'T'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > On entry, M specifies the order of A and D, and the row */ +/* > dimension of C, F, R and L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > On entry, N specifies the order of B and E, and the column */ +/* > dimension of C, F, R and L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, M) */ +/* > On entry, A contains an upper quasi triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the matrix A. LDA >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB, N) */ +/* > On entry, B contains an upper quasi triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the matrix B. LDB >= f2cmax(1, N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (LDC, N) */ +/* > On entry, C contains the right-hand-side of the first matrix */ +/* > equation in (1). */ +/* > On exit, if IJOB = 0, C has been overwritten by the */ +/* > solution R. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the matrix C. LDC >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (LDD, M) */ +/* > On entry, D contains an upper triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDD */ +/* > \verbatim */ +/* > LDD is INTEGER */ +/* > The leading dimension of the matrix D. LDD >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (LDE, N) */ +/* > On entry, E contains an upper triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDE */ +/* > \verbatim */ +/* > LDE is INTEGER */ +/* > The leading dimension of the matrix E. LDE >= f2cmax(1, N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] F */ +/* > \verbatim */ +/* > F is DOUBLE PRECISION array, dimension (LDF, N) */ +/* > On entry, F contains the right-hand-side of the second matrix */ +/* > equation in (1). */ +/* > On exit, if IJOB = 0, F has been overwritten by the */ +/* > solution L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDF */ +/* > \verbatim */ +/* > LDF is INTEGER */ +/* > The leading dimension of the matrix F. LDF >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE */ +/* > \verbatim */ +/* > SCALE is DOUBLE PRECISION */ +/* > On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions */ +/* > R and L (C and F on entry) will hold the solutions to a */ +/* > slightly perturbed system but the input matrices A, B, D and */ +/* > E have not been changed. If SCALE = 0, R and L will hold the */ +/* > solutions to the homogeneous system with C = F = 0. Normally, */ +/* > SCALE = 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] RDSUM */ +/* > \verbatim */ +/* > RDSUM is DOUBLE PRECISION */ +/* > On entry, the sum of squares of computed contributions to */ +/* > the Dif-estimate under computation by DTGSYL, 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 DTGSY2 is called by DTGSYL. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] RDSCAL */ +/* > \verbatim */ +/* > RDSCAL is DOUBLE PRECISION */ +/* > On entry, scaling factor used to prevent overflow in RDSUM. */ +/* > On exit, RDSCAL is updated w.r.t. the current contributions */ +/* > in RDSUM. */ +/* > If TRANS = 'T', RDSCAL is not touched. */ +/* > NOTE: RDSCAL only makes sense when DTGSY2 is called by */ +/* > DTGSYL. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (M+N+2) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PQ */ +/* > \verbatim */ +/* > PQ is INTEGER */ +/* > On exit, the number of subsystems (of size 2-by-2, 4-by-4 and */ +/* > 8-by-8) solved by this routine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > On exit, if INFO is set to */ +/* > =0: Successful exit */ +/* > <0: If INFO = -i, the i-th argument had an illegal value. */ +/* > >0: The matrix pairs (A, D) and (B, E) have common or very */ +/* > close eigenvalues. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleSYauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* > Umea University, S-901 87 Umea, Sweden. */ + +/* ===================================================================== */ +/* Subroutine */ int dtgsy2_(char *trans, integer *ijob, integer *m, integer * + n, doublereal *a, integer *lda, doublereal *b, integer *ldb, + doublereal *c__, integer *ldc, doublereal *d__, integer *ldd, + doublereal *e, integer *lde, doublereal *f, integer *ldf, doublereal * + scale, doublereal *rdsum, doublereal *rdscal, integer *iwork, integer + *pq, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1, + d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3; + + /* Local variables */ + extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *); + integer ierr, zdim, ipiv[8], jpiv[8], i__, j, k, p, q; + doublereal alpha; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dgemm_(char *, char *, integer *, integer *, integer * + , doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *); + doublereal z__[64] /* was [8][8] */; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *), dcopy_(integer *, + doublereal *, integer *, doublereal *, integer *), daxpy_(integer + *, doublereal *, doublereal *, integer *, doublereal *, integer *) + , dgesc2_(integer *, doublereal *, integer *, doublereal *, + integer *, integer *, doublereal *), dgetc2_(integer *, + doublereal *, integer *, integer *, integer *, integer *); + integer ie, je, mb, nb, ii, jj, is, js; + extern /* Subroutine */ int dlatdf_(integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, integer *, + integer *); + doublereal scaloc; + extern /* Subroutine */ int dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen); + logical notran; + doublereal rhs[8]; + integer isp1, jsp1; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ +/* Replaced various illegal calls to DCOPY by calls to DLASET. */ +/* Sven Hammarling, 27/5/02. */ + + +/* Decode and test input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + d_dim1 = *ldd; + d_offset = 1 + d_dim1 * 1; + d__ -= d_offset; + e_dim1 = *lde; + e_offset = 1 + e_dim1 * 1; + e -= e_offset; + f_dim1 = *ldf; + f_offset = 1 + f_dim1 * 1; + f -= f_offset; + --iwork; + + /* Function Body */ + *info = 0; + ierr = 0; + notran = lsame_(trans, "N"); + if (! notran && ! lsame_(trans, "T")) { + *info = -1; + } else if (notran) { + if (*ijob < 0 || *ijob > 2) { + *info = -2; + } + } + if (*info == 0) { + if (*m <= 0) { + *info = -3; + } else if (*n <= 0) { + *info = -4; + } else if (*lda < f2cmax(1,*m)) { + *info = -6; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else if (*ldc < f2cmax(1,*m)) { + *info = -10; + } else if (*ldd < f2cmax(1,*m)) { + *info = -12; + } else if (*lde < f2cmax(1,*n)) { + *info = -14; + } else if (*ldf < f2cmax(1,*m)) { + *info = -16; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTGSY2", &i__1, (ftnlen)6); + return 0; + } + +/* Determine block structure of A */ + + *pq = 0; + p = 0; + i__ = 1; +L10: + if (i__ > *m) { + goto L20; + } + ++p; + iwork[p] = i__; + if (i__ == *m) { + goto L20; + } + if (a[i__ + 1 + i__ * a_dim1] != 0.) { + i__ += 2; + } else { + ++i__; + } + goto L10; +L20: + iwork[p + 1] = *m + 1; + +/* Determine block structure of B */ + + q = p + 1; + j = 1; +L30: + if (j > *n) { + goto L40; + } + ++q; + iwork[q] = j; + if (j == *n) { + goto L40; + } + if (b[j + 1 + j * b_dim1] != 0.) { + j += 2; + } else { + ++j; + } + goto L30; +L40: + iwork[q + 1] = *n + 1; + *pq = p * (q - p - 1); + + if (notran) { + +/* Solve (I, J) - subsystem */ +/* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */ +/* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */ +/* for I = P, P - 1, ..., 1; J = 1, 2, ..., Q */ + + *scale = 1.; + scaloc = 1.; + i__1 = q; + for (j = p + 2; j <= i__1; ++j) { + js = iwork[j]; + jsp1 = js + 1; + je = iwork[j + 1] - 1; + nb = je - js + 1; + for (i__ = p; i__ >= 1; --i__) { + + is = iwork[i__]; + isp1 = is + 1; + ie = iwork[i__ + 1] - 1; + mb = ie - is + 1; + zdim = mb * nb << 1; + + if (mb == 1 && nb == 1) { + +/* Build a 2-by-2 system Z * x = RHS */ + + z__[0] = a[is + is * a_dim1]; + z__[1] = d__[is + is * d_dim1]; + z__[8] = -b[js + js * b_dim1]; + z__[9] = -e[js + js * e_dim1]; + +/* Set up right hand side(s) */ + + rhs[0] = c__[is + js * c_dim1]; + rhs[1] = f[is + js * f_dim1]; + +/* Solve Z * x = RHS */ + + dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + + if (*ijob == 0) { + dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], & + c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L50: */ + } + *scale *= scaloc; + } + } else { + dlatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal, + ipiv, jpiv); + } + +/* Unpack solution vector(s) */ + + c__[is + js * c_dim1] = rhs[0]; + f[is + js * f_dim1] = rhs[1]; + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (i__ > 1) { + alpha = -rhs[0]; + i__2 = is - 1; + daxpy_(&i__2, &alpha, &a[is * a_dim1 + 1], &c__1, & + c__[js * c_dim1 + 1], &c__1); + i__2 = is - 1; + daxpy_(&i__2, &alpha, &d__[is * d_dim1 + 1], &c__1, & + f[js * f_dim1 + 1], &c__1); + } + if (j < q) { + i__2 = *n - je; + daxpy_(&i__2, &rhs[1], &b[js + (je + 1) * b_dim1], + ldb, &c__[is + (je + 1) * c_dim1], ldc); + i__2 = *n - je; + daxpy_(&i__2, &rhs[1], &e[js + (je + 1) * e_dim1], + lde, &f[is + (je + 1) * f_dim1], ldf); + } + + } else if (mb == 1 && nb == 2) { + +/* Build a 4-by-4 system Z * x = RHS */ + + z__[0] = a[is + is * a_dim1]; + z__[1] = 0.; + z__[2] = d__[is + is * d_dim1]; + z__[3] = 0.; + + z__[8] = 0.; + z__[9] = a[is + is * a_dim1]; + z__[10] = 0.; + z__[11] = d__[is + is * d_dim1]; + + z__[16] = -b[js + js * b_dim1]; + z__[17] = -b[js + jsp1 * b_dim1]; + z__[18] = -e[js + js * e_dim1]; + z__[19] = -e[js + jsp1 * e_dim1]; + + z__[24] = -b[jsp1 + js * b_dim1]; + z__[25] = -b[jsp1 + jsp1 * b_dim1]; + z__[26] = 0.; + z__[27] = -e[jsp1 + jsp1 * e_dim1]; + +/* Set up right hand side(s) */ + + rhs[0] = c__[is + js * c_dim1]; + rhs[1] = c__[is + jsp1 * c_dim1]; + rhs[2] = f[is + js * f_dim1]; + rhs[3] = f[is + jsp1 * f_dim1]; + +/* Solve Z * x = RHS */ + + dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + + if (*ijob == 0) { + dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], & + c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L60: */ + } + *scale *= scaloc; + } + } else { + dlatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal, + ipiv, jpiv); + } + +/* Unpack solution vector(s) */ + + c__[is + js * c_dim1] = rhs[0]; + c__[is + jsp1 * c_dim1] = rhs[1]; + f[is + js * f_dim1] = rhs[2]; + f[is + jsp1 * f_dim1] = rhs[3]; + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (i__ > 1) { + i__2 = is - 1; + dger_(&i__2, &nb, &c_b27, &a[is * a_dim1 + 1], &c__1, + rhs, &c__1, &c__[js * c_dim1 + 1], ldc); + i__2 = is - 1; + dger_(&i__2, &nb, &c_b27, &d__[is * d_dim1 + 1], & + c__1, rhs, &c__1, &f[js * f_dim1 + 1], ldf); + } + if (j < q) { + i__2 = *n - je; + daxpy_(&i__2, &rhs[2], &b[js + (je + 1) * b_dim1], + ldb, &c__[is + (je + 1) * c_dim1], ldc); + i__2 = *n - je; + daxpy_(&i__2, &rhs[2], &e[js + (je + 1) * e_dim1], + lde, &f[is + (je + 1) * f_dim1], ldf); + i__2 = *n - je; + daxpy_(&i__2, &rhs[3], &b[jsp1 + (je + 1) * b_dim1], + ldb, &c__[is + (je + 1) * c_dim1], ldc); + i__2 = *n - je; + daxpy_(&i__2, &rhs[3], &e[jsp1 + (je + 1) * e_dim1], + lde, &f[is + (je + 1) * f_dim1], ldf); + } + + } else if (mb == 2 && nb == 1) { + +/* Build a 4-by-4 system Z * x = RHS */ + + z__[0] = a[is + is * a_dim1]; + z__[1] = a[isp1 + is * a_dim1]; + z__[2] = d__[is + is * d_dim1]; + z__[3] = 0.; + + z__[8] = a[is + isp1 * a_dim1]; + z__[9] = a[isp1 + isp1 * a_dim1]; + z__[10] = d__[is + isp1 * d_dim1]; + z__[11] = d__[isp1 + isp1 * d_dim1]; + + z__[16] = -b[js + js * b_dim1]; + z__[17] = 0.; + z__[18] = -e[js + js * e_dim1]; + z__[19] = 0.; + + z__[24] = 0.; + z__[25] = -b[js + js * b_dim1]; + z__[26] = 0.; + z__[27] = -e[js + js * e_dim1]; + +/* Set up right hand side(s) */ + + rhs[0] = c__[is + js * c_dim1]; + rhs[1] = c__[isp1 + js * c_dim1]; + rhs[2] = f[is + js * f_dim1]; + rhs[3] = f[isp1 + js * f_dim1]; + +/* Solve Z * x = RHS */ + + dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + if (*ijob == 0) { + dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], & + c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L70: */ + } + *scale *= scaloc; + } + } else { + dlatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal, + ipiv, jpiv); + } + +/* Unpack solution vector(s) */ + + c__[is + js * c_dim1] = rhs[0]; + c__[isp1 + js * c_dim1] = rhs[1]; + f[is + js * f_dim1] = rhs[2]; + f[isp1 + js * f_dim1] = rhs[3]; + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (i__ > 1) { + i__2 = is - 1; + dgemv_("N", &i__2, &mb, &c_b27, &a[is * a_dim1 + 1], + lda, rhs, &c__1, &c_b42, &c__[js * c_dim1 + 1] + , &c__1); + i__2 = is - 1; + dgemv_("N", &i__2, &mb, &c_b27, &d__[is * d_dim1 + 1], + ldd, rhs, &c__1, &c_b42, &f[js * f_dim1 + 1], + &c__1); + } + if (j < q) { + i__2 = *n - je; + dger_(&mb, &i__2, &c_b42, &rhs[2], &c__1, &b[js + (je + + 1) * b_dim1], ldb, &c__[is + (je + 1) * + c_dim1], ldc); + i__2 = *n - je; + dger_(&mb, &i__2, &c_b42, &rhs[2], &c__1, &e[js + (je + + 1) * e_dim1], lde, &f[is + (je + 1) * + f_dim1], ldf); + } + + } else if (mb == 2 && nb == 2) { + +/* Build an 8-by-8 system Z * x = RHS */ + + dlaset_("F", &c__8, &c__8, &c_b56, &c_b56, z__, &c__8); + + z__[0] = a[is + is * a_dim1]; + z__[1] = a[isp1 + is * a_dim1]; + z__[4] = d__[is + is * d_dim1]; + + z__[8] = a[is + isp1 * a_dim1]; + z__[9] = a[isp1 + isp1 * a_dim1]; + z__[12] = d__[is + isp1 * d_dim1]; + z__[13] = d__[isp1 + isp1 * d_dim1]; + + z__[18] = a[is + is * a_dim1]; + z__[19] = a[isp1 + is * a_dim1]; + z__[22] = d__[is + is * d_dim1]; + + z__[26] = a[is + isp1 * a_dim1]; + z__[27] = a[isp1 + isp1 * a_dim1]; + z__[30] = d__[is + isp1 * d_dim1]; + z__[31] = d__[isp1 + isp1 * d_dim1]; + + z__[32] = -b[js + js * b_dim1]; + z__[34] = -b[js + jsp1 * b_dim1]; + z__[36] = -e[js + js * e_dim1]; + z__[38] = -e[js + jsp1 * e_dim1]; + + z__[41] = -b[js + js * b_dim1]; + z__[43] = -b[js + jsp1 * b_dim1]; + z__[45] = -e[js + js * e_dim1]; + z__[47] = -e[js + jsp1 * e_dim1]; + + z__[48] = -b[jsp1 + js * b_dim1]; + z__[50] = -b[jsp1 + jsp1 * b_dim1]; + z__[54] = -e[jsp1 + jsp1 * e_dim1]; + + z__[57] = -b[jsp1 + js * b_dim1]; + z__[59] = -b[jsp1 + jsp1 * b_dim1]; + z__[63] = -e[jsp1 + jsp1 * e_dim1]; + +/* Set up right hand side(s) */ + + k = 1; + ii = mb * nb + 1; + i__2 = nb - 1; + for (jj = 0; jj <= i__2; ++jj) { + dcopy_(&mb, &c__[is + (js + jj) * c_dim1], &c__1, & + rhs[k - 1], &c__1); + dcopy_(&mb, &f[is + (js + jj) * f_dim1], &c__1, &rhs[ + ii - 1], &c__1); + k += mb; + ii += mb; +/* L80: */ + } + +/* Solve Z * x = RHS */ + + dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + if (*ijob == 0) { + dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], & + c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L90: */ + } + *scale *= scaloc; + } + } else { + dlatdf_(ijob, &zdim, z__, &c__8, rhs, rdsum, rdscal, + ipiv, jpiv); + } + +/* Unpack solution vector(s) */ + + k = 1; + ii = mb * nb + 1; + i__2 = nb - 1; + for (jj = 0; jj <= i__2; ++jj) { + dcopy_(&mb, &rhs[k - 1], &c__1, &c__[is + (js + jj) * + c_dim1], &c__1); + dcopy_(&mb, &rhs[ii - 1], &c__1, &f[is + (js + jj) * + f_dim1], &c__1); + k += mb; + ii += mb; +/* L100: */ + } + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (i__ > 1) { + i__2 = is - 1; + dgemm_("N", "N", &i__2, &nb, &mb, &c_b27, &a[is * + a_dim1 + 1], lda, rhs, &mb, &c_b42, &c__[js * + c_dim1 + 1], ldc); + i__2 = is - 1; + dgemm_("N", "N", &i__2, &nb, &mb, &c_b27, &d__[is * + d_dim1 + 1], ldd, rhs, &mb, &c_b42, &f[js * + f_dim1 + 1], ldf); + } + if (j < q) { + k = mb * nb + 1; + i__2 = *n - je; + dgemm_("N", "N", &mb, &i__2, &nb, &c_b42, &rhs[k - 1], + &mb, &b[js + (je + 1) * b_dim1], ldb, &c_b42, + &c__[is + (je + 1) * c_dim1], ldc); + i__2 = *n - je; + dgemm_("N", "N", &mb, &i__2, &nb, &c_b42, &rhs[k - 1], + &mb, &e[js + (je + 1) * e_dim1], lde, &c_b42, + &f[is + (je + 1) * f_dim1], ldf); + } + + } + +/* L110: */ + } +/* L120: */ + } + } else { + +/* Solve (I, J) - subsystem */ +/* A(I, I)**T * R(I, J) + D(I, I)**T * L(J, J) = C(I, J) */ +/* R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J) */ +/* for I = 1, 2, ..., P, J = Q, Q - 1, ..., 1 */ + + *scale = 1.; + scaloc = 1.; + i__1 = p; + for (i__ = 1; i__ <= i__1; ++i__) { + + is = iwork[i__]; + isp1 = is + 1; + ie = iwork[i__ + 1] - 1; + mb = ie - is + 1; + i__2 = p + 2; + for (j = q; j >= i__2; --j) { + + js = iwork[j]; + jsp1 = js + 1; + je = iwork[j + 1] - 1; + nb = je - js + 1; + zdim = mb * nb << 1; + if (mb == 1 && nb == 1) { + +/* Build a 2-by-2 system Z**T * x = RHS */ + + z__[0] = a[is + is * a_dim1]; + z__[1] = -b[js + js * b_dim1]; + z__[8] = d__[is + is * d_dim1]; + z__[9] = -e[js + js * e_dim1]; + +/* Set up right hand side(s) */ + + rhs[0] = c__[is + js * c_dim1]; + rhs[1] = f[is + js * f_dim1]; + +/* Solve Z**T * x = RHS */ + + dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + + dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.) { + i__3 = *n; + for (k = 1; k <= i__3; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L130: */ + } + *scale *= scaloc; + } + +/* Unpack solution vector(s) */ + + c__[is + js * c_dim1] = rhs[0]; + f[is + js * f_dim1] = rhs[1]; + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (j > p + 2) { + alpha = rhs[0]; + i__3 = js - 1; + daxpy_(&i__3, &alpha, &b[js * b_dim1 + 1], &c__1, &f[ + is + f_dim1], ldf); + alpha = rhs[1]; + i__3 = js - 1; + daxpy_(&i__3, &alpha, &e[js * e_dim1 + 1], &c__1, &f[ + is + f_dim1], ldf); + } + if (i__ < p) { + alpha = -rhs[0]; + i__3 = *m - ie; + daxpy_(&i__3, &alpha, &a[is + (ie + 1) * a_dim1], lda, + &c__[ie + 1 + js * c_dim1], &c__1); + alpha = -rhs[1]; + i__3 = *m - ie; + daxpy_(&i__3, &alpha, &d__[is + (ie + 1) * d_dim1], + ldd, &c__[ie + 1 + js * c_dim1], &c__1); + } + + } else if (mb == 1 && nb == 2) { + +/* Build a 4-by-4 system Z**T * x = RHS */ + + z__[0] = a[is + is * a_dim1]; + z__[1] = 0.; + z__[2] = -b[js + js * b_dim1]; + z__[3] = -b[jsp1 + js * b_dim1]; + + z__[8] = 0.; + z__[9] = a[is + is * a_dim1]; + z__[10] = -b[js + jsp1 * b_dim1]; + z__[11] = -b[jsp1 + jsp1 * b_dim1]; + + z__[16] = d__[is + is * d_dim1]; + z__[17] = 0.; + z__[18] = -e[js + js * e_dim1]; + z__[19] = 0.; + + z__[24] = 0.; + z__[25] = d__[is + is * d_dim1]; + z__[26] = -e[js + jsp1 * e_dim1]; + z__[27] = -e[jsp1 + jsp1 * e_dim1]; + +/* Set up right hand side(s) */ + + rhs[0] = c__[is + js * c_dim1]; + rhs[1] = c__[is + jsp1 * c_dim1]; + rhs[2] = f[is + js * f_dim1]; + rhs[3] = f[is + jsp1 * f_dim1]; + +/* Solve Z**T * x = RHS */ + + dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.) { + i__3 = *n; + for (k = 1; k <= i__3; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L140: */ + } + *scale *= scaloc; + } + +/* Unpack solution vector(s) */ + + c__[is + js * c_dim1] = rhs[0]; + c__[is + jsp1 * c_dim1] = rhs[1]; + f[is + js * f_dim1] = rhs[2]; + f[is + jsp1 * f_dim1] = rhs[3]; + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (j > p + 2) { + i__3 = js - 1; + daxpy_(&i__3, rhs, &b[js * b_dim1 + 1], &c__1, &f[is + + f_dim1], ldf); + i__3 = js - 1; + daxpy_(&i__3, &rhs[1], &b[jsp1 * b_dim1 + 1], &c__1, & + f[is + f_dim1], ldf); + i__3 = js - 1; + daxpy_(&i__3, &rhs[2], &e[js * e_dim1 + 1], &c__1, &f[ + is + f_dim1], ldf); + i__3 = js - 1; + daxpy_(&i__3, &rhs[3], &e[jsp1 * e_dim1 + 1], &c__1, & + f[is + f_dim1], ldf); + } + if (i__ < p) { + i__3 = *m - ie; + dger_(&i__3, &nb, &c_b27, &a[is + (ie + 1) * a_dim1], + lda, rhs, &c__1, &c__[ie + 1 + js * c_dim1], + ldc); + i__3 = *m - ie; + dger_(&i__3, &nb, &c_b27, &d__[is + (ie + 1) * d_dim1] + , ldd, &rhs[2], &c__1, &c__[ie + 1 + js * + c_dim1], ldc); + } + + } else if (mb == 2 && nb == 1) { + +/* Build a 4-by-4 system Z**T * x = RHS */ + + z__[0] = a[is + is * a_dim1]; + z__[1] = a[is + isp1 * a_dim1]; + z__[2] = -b[js + js * b_dim1]; + z__[3] = 0.; + + z__[8] = a[isp1 + is * a_dim1]; + z__[9] = a[isp1 + isp1 * a_dim1]; + z__[10] = 0.; + z__[11] = -b[js + js * b_dim1]; + + z__[16] = d__[is + is * d_dim1]; + z__[17] = d__[is + isp1 * d_dim1]; + z__[18] = -e[js + js * e_dim1]; + z__[19] = 0.; + + z__[24] = 0.; + z__[25] = d__[isp1 + isp1 * d_dim1]; + z__[26] = 0.; + z__[27] = -e[js + js * e_dim1]; + +/* Set up right hand side(s) */ + + rhs[0] = c__[is + js * c_dim1]; + rhs[1] = c__[isp1 + js * c_dim1]; + rhs[2] = f[is + js * f_dim1]; + rhs[3] = f[isp1 + js * f_dim1]; + +/* Solve Z**T * x = RHS */ + + dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + + dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.) { + i__3 = *n; + for (k = 1; k <= i__3; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L150: */ + } + *scale *= scaloc; + } + +/* Unpack solution vector(s) */ + + c__[is + js * c_dim1] = rhs[0]; + c__[isp1 + js * c_dim1] = rhs[1]; + f[is + js * f_dim1] = rhs[2]; + f[isp1 + js * f_dim1] = rhs[3]; + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (j > p + 2) { + i__3 = js - 1; + dger_(&mb, &i__3, &c_b42, rhs, &c__1, &b[js * b_dim1 + + 1], &c__1, &f[is + f_dim1], ldf); + i__3 = js - 1; + dger_(&mb, &i__3, &c_b42, &rhs[2], &c__1, &e[js * + e_dim1 + 1], &c__1, &f[is + f_dim1], ldf); + } + if (i__ < p) { + i__3 = *m - ie; + dgemv_("T", &mb, &i__3, &c_b27, &a[is + (ie + 1) * + a_dim1], lda, rhs, &c__1, &c_b42, &c__[ie + 1 + + js * c_dim1], &c__1); + i__3 = *m - ie; + dgemv_("T", &mb, &i__3, &c_b27, &d__[is + (ie + 1) * + d_dim1], ldd, &rhs[2], &c__1, &c_b42, &c__[ie + + 1 + js * c_dim1], &c__1); + } + + } else if (mb == 2 && nb == 2) { + +/* Build an 8-by-8 system Z**T * x = RHS */ + + dlaset_("F", &c__8, &c__8, &c_b56, &c_b56, z__, &c__8); + + z__[0] = a[is + is * a_dim1]; + z__[1] = a[is + isp1 * a_dim1]; + z__[4] = -b[js + js * b_dim1]; + z__[6] = -b[jsp1 + js * b_dim1]; + + z__[8] = a[isp1 + is * a_dim1]; + z__[9] = a[isp1 + isp1 * a_dim1]; + z__[13] = -b[js + js * b_dim1]; + z__[15] = -b[jsp1 + js * b_dim1]; + + z__[18] = a[is + is * a_dim1]; + z__[19] = a[is + isp1 * a_dim1]; + z__[20] = -b[js + jsp1 * b_dim1]; + z__[22] = -b[jsp1 + jsp1 * b_dim1]; + + z__[26] = a[isp1 + is * a_dim1]; + z__[27] = a[isp1 + isp1 * a_dim1]; + z__[29] = -b[js + jsp1 * b_dim1]; + z__[31] = -b[jsp1 + jsp1 * b_dim1]; + + z__[32] = d__[is + is * d_dim1]; + z__[33] = d__[is + isp1 * d_dim1]; + z__[36] = -e[js + js * e_dim1]; + + z__[41] = d__[isp1 + isp1 * d_dim1]; + z__[45] = -e[js + js * e_dim1]; + + z__[50] = d__[is + is * d_dim1]; + z__[51] = d__[is + isp1 * d_dim1]; + z__[52] = -e[js + jsp1 * e_dim1]; + z__[54] = -e[jsp1 + jsp1 * e_dim1]; + + z__[59] = d__[isp1 + isp1 * d_dim1]; + z__[61] = -e[js + jsp1 * e_dim1]; + z__[63] = -e[jsp1 + jsp1 * e_dim1]; + +/* Set up right hand side(s) */ + + k = 1; + ii = mb * nb + 1; + i__3 = nb - 1; + for (jj = 0; jj <= i__3; ++jj) { + dcopy_(&mb, &c__[is + (js + jj) * c_dim1], &c__1, & + rhs[k - 1], &c__1); + dcopy_(&mb, &f[is + (js + jj) * f_dim1], &c__1, &rhs[ + ii - 1], &c__1); + k += mb; + ii += mb; +/* L160: */ + } + + +/* Solve Z**T * x = RHS */ + + dgetc2_(&zdim, z__, &c__8, ipiv, jpiv, &ierr); + if (ierr > 0) { + *info = ierr; + } + + dgesc2_(&zdim, z__, &c__8, rhs, ipiv, jpiv, &scaloc); + if (scaloc != 1.) { + i__3 = *n; + for (k = 1; k <= i__3; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L170: */ + } + *scale *= scaloc; + } + +/* Unpack solution vector(s) */ + + k = 1; + ii = mb * nb + 1; + i__3 = nb - 1; + for (jj = 0; jj <= i__3; ++jj) { + dcopy_(&mb, &rhs[k - 1], &c__1, &c__[is + (js + jj) * + c_dim1], &c__1); + dcopy_(&mb, &rhs[ii - 1], &c__1, &f[is + (js + jj) * + f_dim1], &c__1); + k += mb; + ii += mb; +/* L180: */ + } + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (j > p + 2) { + i__3 = js - 1; + dgemm_("N", "T", &mb, &i__3, &nb, &c_b42, &c__[is + + js * c_dim1], ldc, &b[js * b_dim1 + 1], ldb, & + c_b42, &f[is + f_dim1], ldf); + i__3 = js - 1; + dgemm_("N", "T", &mb, &i__3, &nb, &c_b42, &f[is + js * + f_dim1], ldf, &e[js * e_dim1 + 1], lde, & + c_b42, &f[is + f_dim1], ldf); + } + if (i__ < p) { + i__3 = *m - ie; + dgemm_("T", "N", &i__3, &nb, &mb, &c_b27, &a[is + (ie + + 1) * a_dim1], lda, &c__[is + js * c_dim1], + ldc, &c_b42, &c__[ie + 1 + js * c_dim1], ldc); + i__3 = *m - ie; + dgemm_("T", "N", &i__3, &nb, &mb, &c_b27, &d__[is + ( + ie + 1) * d_dim1], ldd, &f[is + js * f_dim1], + ldf, &c_b42, &c__[ie + 1 + js * c_dim1], ldc); + } + + } + +/* L190: */ + } +/* L200: */ + } + + } + return 0; + +/* End of DTGSY2 */ + +} /* dtgsy2_ */ + diff --git a/lapack-netlib/SRC/dtgsyl.c b/lapack-netlib/SRC/dtgsyl.c new file mode 100644 index 000000000..9a95ba40b --- /dev/null +++ b/lapack-netlib/SRC/dtgsyl.c @@ -0,0 +1,1177 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTGSYL */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTGSYL + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, */ +/* LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, */ +/* IWORK, INFO ) */ + +/* CHARACTER TRANS */ +/* INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, */ +/* $ LWORK, M, N */ +/* DOUBLE PRECISION DIF, SCALE */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), */ +/* $ D( LDD, * ), E( LDE, * ), F( LDF, * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTGSYL solves the generalized Sylvester equation: */ +/* > */ +/* > A * R - L * B = scale * C (1) */ +/* > D * R - L * E = scale * F */ +/* > */ +/* > where R and L are unknown m-by-n matrices, (A, D), (B, E) and */ +/* > (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n, */ +/* > respectively, with real entries. (A, D) and (B, E) must be in */ +/* > generalized (real) Schur canonical form, i.e. A, B are upper quasi */ +/* > triangular and D, E are upper triangular. */ +/* > */ +/* > The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output */ +/* > scaling factor chosen to avoid overflow. */ +/* > */ +/* > In matrix notation (1) is equivalent to solve Zx = scale b, where */ +/* > Z is defined as */ +/* > */ +/* > Z = [ kron(In, A) -kron(B**T, Im) ] (2) */ +/* > [ kron(In, D) -kron(E**T, Im) ]. */ +/* > */ +/* > Here Ik is the identity matrix of size k and X**T is the transpose of */ +/* > X. kron(X, Y) is the Kronecker product between the matrices X and Y. */ +/* > */ +/* > If TRANS = 'T', DTGSYL solves the transposed system Z**T*y = scale*b, */ +/* > which is equivalent to solve for R and L in */ +/* > */ +/* > A**T * R + D**T * L = scale * C (3) */ +/* > R * B**T + L * E**T = scale * -F */ +/* > */ +/* > This case (TRANS = 'T') is used to compute an one-norm-based estimate */ +/* > of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D) */ +/* > and (B,E), using DLACON. */ +/* > */ +/* > If IJOB >= 1, DTGSYL computes a Frobenius norm-based estimate */ +/* > of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the */ +/* > reciprocal of the smallest singular value of Z. See [1-2] for more */ +/* > information. */ +/* > */ +/* > This is a level 3 BLAS algorithm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': solve the generalized Sylvester equation (1). */ +/* > = 'T': solve the 'transposed' system (3). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IJOB */ +/* > \verbatim */ +/* > IJOB is INTEGER */ +/* > Specifies what kind of functionality to be performed. */ +/* > = 0: solve (1) only. */ +/* > = 1: The functionality of 0 and 3. */ +/* > = 2: The functionality of 0 and 4. */ +/* > = 3: Only an estimate of Dif[(A,D), (B,E)] is computed. */ +/* > (look ahead strategy IJOB = 1 is used). */ +/* > = 4: Only an estimate of Dif[(A,D), (B,E)] is computed. */ +/* > ( DGECON on sub-systems is used ). */ +/* > Not referenced if TRANS = 'T'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The order of the matrices A and D, and the row dimension of */ +/* > the matrices C, F, R and L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices B and E, and the column dimension */ +/* > of the matrices C, F, R and L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA, M) */ +/* > The upper quasi triangular matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB, N) */ +/* > The upper quasi triangular matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1, N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (LDC, N) */ +/* > On entry, C contains the right-hand-side of the first matrix */ +/* > equation in (1) or (3). */ +/* > On exit, if IJOB = 0, 1 or 2, C has been overwritten by */ +/* > the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R, */ +/* > the solution achieved during the computation of the */ +/* > Dif-estimate. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (LDD, M) */ +/* > The upper triangular matrix D. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDD */ +/* > \verbatim */ +/* > LDD is INTEGER */ +/* > The leading dimension of the array D. LDD >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (LDE, N) */ +/* > The upper triangular matrix E. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDE */ +/* > \verbatim */ +/* > LDE is INTEGER */ +/* > The leading dimension of the array E. LDE >= f2cmax(1, N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] F */ +/* > \verbatim */ +/* > F is DOUBLE PRECISION array, dimension (LDF, N) */ +/* > On entry, F contains the right-hand-side of the second matrix */ +/* > equation in (1) or (3). */ +/* > On exit, if IJOB = 0, 1 or 2, F has been overwritten by */ +/* > the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L, */ +/* > the solution achieved during the computation of the */ +/* > Dif-estimate. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDF */ +/* > \verbatim */ +/* > LDF is INTEGER */ +/* > The leading dimension of the array F. LDF >= f2cmax(1, M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] DIF */ +/* > \verbatim */ +/* > DIF is DOUBLE PRECISION */ +/* > On exit DIF is the reciprocal of a lower bound of the */ +/* > reciprocal of the Dif-function, i.e. DIF is an upper bound of */ +/* > Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2). */ +/* > IF IJOB = 0 or TRANS = 'T', DIF is not touched. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE */ +/* > \verbatim */ +/* > SCALE is DOUBLE PRECISION */ +/* > On exit SCALE is the scaling factor in (1) or (3). */ +/* > If 0 < SCALE < 1, C and F hold the solutions R and L, resp., */ +/* > to a slightly perturbed system but the input matrices A, B, D */ +/* > and E have not been changed. If SCALE = 0, C and F hold the */ +/* > solutions R and L, respectively, to the homogeneous system */ +/* > with C = F = 0. Normally, SCALE = 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK > = 1. */ +/* > If IJOB = 1 or 2 and TRANS = 'N', LWORK >= f2cmax(1,2*M*N). */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (M+N+6) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > =0: successful exit */ +/* > <0: If INFO = -i, the i-th argument had an illegal value. */ +/* > >0: (A, D) and (B, E) have common or close eigenvalues. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleSYcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Bo Kagstrom and Peter Poromaa, Department of Computing Science, */ +/* > Umea University, S-901 87 Umea, Sweden. */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > \verbatim */ +/* > */ +/* > [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software */ +/* > for Solving the Generalized Sylvester Equation and Estimating the */ +/* > Separation between Regular Matrix Pairs, Report UMINF - 93.23, */ +/* > Department of Computing Science, Umea University, S-901 87 Umea, */ +/* > Sweden, December 1993, Revised April 1994, Also as LAPACK Working */ +/* > Note 75. To appear in ACM Trans. on Math. Software, Vol 22, */ +/* > No 1, 1996. */ +/* > */ +/* > [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester */ +/* > Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal. */ +/* > Appl., 15(4):1045-1060, 1994 */ +/* > */ +/* > [3] B. Kagstrom and L. Westin, Generalized Schur Methods with */ +/* > Condition Estimators for Solving the Generalized Sylvester */ +/* > Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7, */ +/* > July 1989, pp 745-751. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtgsyl_(char *trans, integer *ijob, integer *m, integer * + n, doublereal *a, integer *lda, doublereal *b, integer *ldb, + doublereal *c__, integer *ldc, doublereal *d__, integer *ldd, + doublereal *e, integer *lde, doublereal *f, integer *ldf, doublereal * + scale, doublereal *dif, doublereal *work, integer *lwork, integer * + iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, d_dim1, + d_offset, e_dim1, e_offset, f_dim1, f_offset, i__1, i__2, i__3, + i__4; + + /* Local variables */ + doublereal dsum; + integer ppqq, i__, j, k, p, q; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *), dgemm_(char *, char *, integer *, integer *, integer * + , doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *); + extern logical lsame_(char *, char *); + integer ifunc, linfo, lwmin; + doublereal scale2; + extern /* Subroutine */ int dtgsy2_(char *, integer *, integer *, integer + *, doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + integer *, integer *, integer *); + integer ie, je, mb, nb; + doublereal dscale; + integer is, js, pq; + doublereal scaloc; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *), + dlaset_(char *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + integer iround; + logical notran; + integer isolve; + logical lquery; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ +/* Replaced various illegal calls to DCOPY by calls to DLASET. */ +/* Sven Hammarling, 1/5/02. */ + + +/* Decode and test input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + d_dim1 = *ldd; + d_offset = 1 + d_dim1 * 1; + d__ -= d_offset; + e_dim1 = *lde; + e_offset = 1 + e_dim1 * 1; + e -= e_offset; + f_dim1 = *ldf; + f_offset = 1 + f_dim1 * 1; + f -= f_offset; + --work; + --iwork; + + /* Function Body */ + *info = 0; + notran = lsame_(trans, "N"); + lquery = *lwork == -1; + + if (! notran && ! lsame_(trans, "T")) { + *info = -1; + } else if (notran) { + if (*ijob < 0 || *ijob > 4) { + *info = -2; + } + } + if (*info == 0) { + if (*m <= 0) { + *info = -3; + } else if (*n <= 0) { + *info = -4; + } else if (*lda < f2cmax(1,*m)) { + *info = -6; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else if (*ldc < f2cmax(1,*m)) { + *info = -10; + } else if (*ldd < f2cmax(1,*m)) { + *info = -12; + } else if (*lde < f2cmax(1,*n)) { + *info = -14; + } else if (*ldf < f2cmax(1,*m)) { + *info = -16; + } + } + + if (*info == 0) { + if (notran) { + if (*ijob == 1 || *ijob == 2) { +/* Computing MAX */ + i__1 = 1, i__2 = (*m << 1) * *n; + lwmin = f2cmax(i__1,i__2); + } else { + lwmin = 1; + } + } else { + lwmin = 1; + } + work[1] = (doublereal) lwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -20; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTGSYL", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + *scale = 1.; + if (notran) { + if (*ijob != 0) { + *dif = 0.; + } + } + return 0; + } + +/* Determine optimal block sizes MB and NB */ + + mb = ilaenv_(&c__2, "DTGSYL", trans, m, n, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + nb = ilaenv_(&c__5, "DTGSYL", trans, m, n, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)1); + + isolve = 1; + ifunc = 0; + if (notran) { + if (*ijob >= 3) { + ifunc = *ijob - 2; + dlaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc) + ; + dlaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf); + } else if (*ijob >= 1) { + isolve = 2; + } + } + + if (mb <= 1 && nb <= 1 || mb >= *m && nb >= *n) { + + i__1 = isolve; + for (iround = 1; iround <= i__1; ++iround) { + +/* Use unblocked Level 2 solver */ + + dscale = 0.; + dsum = 1.; + pq = 0; + dtgsy2_(trans, &ifunc, m, n, &a[a_offset], lda, &b[b_offset], ldb, + &c__[c_offset], ldc, &d__[d_offset], ldd, &e[e_offset], + lde, &f[f_offset], ldf, scale, &dsum, &dscale, &iwork[1], + &pq, info); + if (dscale != 0.) { + if (*ijob == 1 || *ijob == 3) { + *dif = sqrt((doublereal) ((*m << 1) * *n)) / (dscale * + sqrt(dsum)); + } else { + *dif = sqrt((doublereal) pq) / (dscale * sqrt(dsum)); + } + } + + if (isolve == 2 && iround == 1) { + if (notran) { + ifunc = *ijob; + } + scale2 = *scale; + dlacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m); + dlacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m); + dlaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc); + dlaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf); + } else if (isolve == 2 && iround == 2) { + dlacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc); + dlacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf); + *scale = scale2; + } +/* L30: */ + } + + return 0; + } + +/* Determine block structure of A */ + + p = 0; + i__ = 1; +L40: + if (i__ > *m) { + goto L50; + } + ++p; + iwork[p] = i__; + i__ += mb; + if (i__ >= *m) { + goto L50; + } + if (a[i__ + (i__ - 1) * a_dim1] != 0.) { + ++i__; + } + goto L40; +L50: + + iwork[p + 1] = *m + 1; + if (iwork[p] == iwork[p + 1]) { + --p; + } + +/* Determine block structure of B */ + + q = p + 1; + j = 1; +L60: + if (j > *n) { + goto L70; + } + ++q; + iwork[q] = j; + j += nb; + if (j >= *n) { + goto L70; + } + if (b[j + (j - 1) * b_dim1] != 0.) { + ++j; + } + goto L60; +L70: + + iwork[q + 1] = *n + 1; + if (iwork[q] == iwork[q + 1]) { + --q; + } + + if (notran) { + + i__1 = isolve; + for (iround = 1; iround <= i__1; ++iround) { + +/* Solve (I, J)-subsystem */ +/* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J) */ +/* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J) */ +/* for I = P, P - 1,..., 1; J = 1, 2,..., Q */ + + dscale = 0.; + dsum = 1.; + pq = 0; + *scale = 1.; + i__2 = q; + for (j = p + 2; j <= i__2; ++j) { + js = iwork[j]; + je = iwork[j + 1] - 1; + nb = je - js + 1; + for (i__ = p; i__ >= 1; --i__) { + is = iwork[i__]; + ie = iwork[i__ + 1] - 1; + mb = ie - is + 1; + ppqq = 0; + dtgsy2_(trans, &ifunc, &mb, &nb, &a[is + is * a_dim1], + lda, &b[js + js * b_dim1], ldb, &c__[is + js * + c_dim1], ldc, &d__[is + is * d_dim1], ldd, &e[js + + js * e_dim1], lde, &f[is + js * f_dim1], ldf, & + scaloc, &dsum, &dscale, &iwork[q + 2], &ppqq, & + linfo); + if (linfo > 0) { + *info = linfo; + } + + pq += ppqq; + if (scaloc != 1.) { + i__3 = js - 1; + for (k = 1; k <= i__3; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L80: */ + } + i__3 = je; + for (k = js; k <= i__3; ++k) { + i__4 = is - 1; + dscal_(&i__4, &scaloc, &c__[k * c_dim1 + 1], & + c__1); + i__4 = is - 1; + dscal_(&i__4, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L90: */ + } + i__3 = je; + for (k = js; k <= i__3; ++k) { + i__4 = *m - ie; + dscal_(&i__4, &scaloc, &c__[ie + 1 + k * c_dim1], + &c__1); + i__4 = *m - ie; + dscal_(&i__4, &scaloc, &f[ie + 1 + k * f_dim1], & + c__1); +/* L100: */ + } + i__3 = *n; + for (k = je + 1; k <= i__3; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L110: */ + } + *scale *= scaloc; + } + +/* Substitute R(I, J) and L(I, J) into remaining */ +/* equation. */ + + if (i__ > 1) { + i__3 = is - 1; + dgemm_("N", "N", &i__3, &nb, &mb, &c_b51, &a[is * + a_dim1 + 1], lda, &c__[is + js * c_dim1], ldc, + &c_b52, &c__[js * c_dim1 + 1], ldc); + i__3 = is - 1; + dgemm_("N", "N", &i__3, &nb, &mb, &c_b51, &d__[is * + d_dim1 + 1], ldd, &c__[is + js * c_dim1], ldc, + &c_b52, &f[js * f_dim1 + 1], ldf); + } + if (j < q) { + i__3 = *n - je; + dgemm_("N", "N", &mb, &i__3, &nb, &c_b52, &f[is + js * + f_dim1], ldf, &b[js + (je + 1) * b_dim1], + ldb, &c_b52, &c__[is + (je + 1) * c_dim1], + ldc); + i__3 = *n - je; + dgemm_("N", "N", &mb, &i__3, &nb, &c_b52, &f[is + js * + f_dim1], ldf, &e[js + (je + 1) * e_dim1], + lde, &c_b52, &f[is + (je + 1) * f_dim1], ldf); + } +/* L120: */ + } +/* L130: */ + } + if (dscale != 0.) { + if (*ijob == 1 || *ijob == 3) { + *dif = sqrt((doublereal) ((*m << 1) * *n)) / (dscale * + sqrt(dsum)); + } else { + *dif = sqrt((doublereal) pq) / (dscale * sqrt(dsum)); + } + } + if (isolve == 2 && iround == 1) { + if (notran) { + ifunc = *ijob; + } + scale2 = *scale; + dlacpy_("F", m, n, &c__[c_offset], ldc, &work[1], m); + dlacpy_("F", m, n, &f[f_offset], ldf, &work[*m * *n + 1], m); + dlaset_("F", m, n, &c_b14, &c_b14, &c__[c_offset], ldc); + dlaset_("F", m, n, &c_b14, &c_b14, &f[f_offset], ldf); + } else if (isolve == 2 && iround == 2) { + dlacpy_("F", m, n, &work[1], m, &c__[c_offset], ldc); + dlacpy_("F", m, n, &work[*m * *n + 1], m, &f[f_offset], ldf); + *scale = scale2; + } +/* L150: */ + } + + } else { + +/* Solve transposed (I, J)-subsystem */ +/* A(I, I)**T * R(I, J) + D(I, I)**T * L(I, J) = C(I, J) */ +/* R(I, J) * B(J, J)**T + L(I, J) * E(J, J)**T = -F(I, J) */ +/* for I = 1,2,..., P; J = Q, Q-1,..., 1 */ + + *scale = 1.; + i__1 = p; + for (i__ = 1; i__ <= i__1; ++i__) { + is = iwork[i__]; + ie = iwork[i__ + 1] - 1; + mb = ie - is + 1; + i__2 = p + 2; + for (j = q; j >= i__2; --j) { + js = iwork[j]; + je = iwork[j + 1] - 1; + nb = je - js + 1; + dtgsy2_(trans, &ifunc, &mb, &nb, &a[is + is * a_dim1], lda, & + b[js + js * b_dim1], ldb, &c__[is + js * c_dim1], ldc, + &d__[is + is * d_dim1], ldd, &e[js + js * e_dim1], + lde, &f[is + js * f_dim1], ldf, &scaloc, &dsum, & + dscale, &iwork[q + 2], &ppqq, &linfo); + if (linfo > 0) { + *info = linfo; + } + if (scaloc != 1.) { + i__3 = js - 1; + for (k = 1; k <= i__3; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L160: */ + } + i__3 = je; + for (k = js; k <= i__3; ++k) { + i__4 = is - 1; + dscal_(&i__4, &scaloc, &c__[k * c_dim1 + 1], &c__1); + i__4 = is - 1; + dscal_(&i__4, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L170: */ + } + i__3 = je; + for (k = js; k <= i__3; ++k) { + i__4 = *m - ie; + dscal_(&i__4, &scaloc, &c__[ie + 1 + k * c_dim1], & + c__1); + i__4 = *m - ie; + dscal_(&i__4, &scaloc, &f[ie + 1 + k * f_dim1], &c__1) + ; +/* L180: */ + } + i__3 = *n; + for (k = je + 1; k <= i__3; ++k) { + dscal_(m, &scaloc, &c__[k * c_dim1 + 1], &c__1); + dscal_(m, &scaloc, &f[k * f_dim1 + 1], &c__1); +/* L190: */ + } + *scale *= scaloc; + } + +/* Substitute R(I, J) and L(I, J) into remaining equation. */ + + if (j > p + 2) { + i__3 = js - 1; + dgemm_("N", "T", &mb, &i__3, &nb, &c_b52, &c__[is + js * + c_dim1], ldc, &b[js * b_dim1 + 1], ldb, &c_b52, & + f[is + f_dim1], ldf); + i__3 = js - 1; + dgemm_("N", "T", &mb, &i__3, &nb, &c_b52, &f[is + js * + f_dim1], ldf, &e[js * e_dim1 + 1], lde, &c_b52, & + f[is + f_dim1], ldf); + } + if (i__ < p) { + i__3 = *m - ie; + dgemm_("T", "N", &i__3, &nb, &mb, &c_b51, &a[is + (ie + 1) + * a_dim1], lda, &c__[is + js * c_dim1], ldc, & + c_b52, &c__[ie + 1 + js * c_dim1], ldc); + i__3 = *m - ie; + dgemm_("T", "N", &i__3, &nb, &mb, &c_b51, &d__[is + (ie + + 1) * d_dim1], ldd, &f[is + js * f_dim1], ldf, & + c_b52, &c__[ie + 1 + js * c_dim1], ldc); + } +/* L200: */ + } +/* L210: */ + } + + } + + work[1] = (doublereal) lwmin; + + return 0; + +/* End of DTGSYL */ + +} /* dtgsyl_ */ + diff --git a/lapack-netlib/SRC/dtpcon.c b/lapack-netlib/SRC/dtpcon.c new file mode 100644 index 000000000..1c9931a08 --- /dev/null +++ b/lapack-netlib/SRC/dtpcon.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 DTPCON */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTPCON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK, */ +/* INFO ) */ + +/* CHARACTER DIAG, NORM, UPLO */ +/* INTEGER INFO, N */ +/* DOUBLE PRECISION RCOND */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION AP( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTPCON estimates the reciprocal of the condition number of a packed */ +/* > triangular matrix A, in either the 1-norm or the infinity-norm. */ +/* > */ +/* > The norm of A is computed and an estimate is obtained for */ +/* > norm(inv(A)), then the reciprocal of the condition number is */ +/* > computed as */ +/* > RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies whether the 1-norm condition number or the */ +/* > infinity-norm condition number is required: */ +/* > = '1' or 'O': 1-norm; */ +/* > = 'I': Infinity-norm. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > The upper or lower triangular matrix A, packed columnwise in */ +/* > a linear array. The j-th column of A is stored in the array */ +/* > AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > If DIAG = 'U', the diagonal elements of A are not referenced */ +/* > and are assumed to be 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > The reciprocal of the condition number of the matrix A, */ +/* > computed as RCOND = 1/(norm(A) * norm(inv(A))). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dtpcon_(char *norm, char *uplo, char *diag, integer *n, + doublereal *ap, doublereal *rcond, doublereal *work, integer *iwork, + integer *info) +{ + /* System generated locals */ + integer i__1; + doublereal d__1; + + /* Local variables */ + integer kase, kase1; + doublereal scale; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *, + integer *); + doublereal anorm; + logical upper; + doublereal xnorm; + extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + extern doublereal dlamch_(char *); + integer ix; + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern doublereal dlantp_(char *, char *, char *, integer *, doublereal *, + doublereal *); + doublereal ainvnm; + extern /* Subroutine */ int dlatps_(char *, char *, char *, char *, + integer *, doublereal *, doublereal *, doublereal *, doublereal *, + integer *); + logical onenrm; + char normin[1]; + doublereal smlnum; + logical nounit; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --iwork; + --work; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); + nounit = lsame_(diag, "N"); + + if (! onenrm && ! lsame_(norm, "I")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTPCON", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *rcond = 1.; + return 0; + } + + *rcond = 0.; + smlnum = dlamch_("Safe minimum") * (doublereal) f2cmax(1,*n); + +/* Compute the norm of the triangular matrix A. */ + + anorm = dlantp_(norm, uplo, diag, n, &ap[1], &work[1]); + +/* Continue only if ANORM > 0. */ + + if (anorm > 0.) { + +/* Estimate the norm of the inverse of A. */ + + ainvnm = 0.; + *(unsigned char *)normin = 'N'; + if (onenrm) { + kase1 = 1; + } else { + kase1 = 2; + } + kase = 0; +L10: + dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == kase1) { + +/* Multiply by inv(A). */ + + dlatps_(uplo, "No transpose", diag, normin, n, &ap[1], &work[ + 1], &scale, &work[(*n << 1) + 1], info); + } else { + +/* Multiply by inv(A**T). */ + + dlatps_(uplo, "Transpose", diag, normin, n, &ap[1], &work[1], + &scale, &work[(*n << 1) + 1], info); + } + *(unsigned char *)normin = 'Y'; + +/* Multiply by 1/SCALE if doing so will not cause overflow. */ + + if (scale != 1.) { + ix = idamax_(n, &work[1], &c__1); + xnorm = (d__1 = work[ix], abs(d__1)); + if (scale < xnorm * smlnum || scale == 0.) { + goto L20; + } + drscl_(n, &scale, &work[1], &c__1); + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + *rcond = 1. / anorm / ainvnm; + } + } + +L20: + return 0; + +/* End of DTPCON */ + +} /* dtpcon_ */ + diff --git a/lapack-netlib/SRC/dtplqt.c b/lapack-netlib/SRC/dtplqt.c new file mode 100644 index 000000000..da7ef9bd9 --- /dev/null +++ b/lapack-netlib/SRC/dtplqt.c @@ -0,0 +1,683 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTPLQT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTPQRT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTPLQT( M, N, L, MB, A, LDA, B, LDB, T, LDT, WORK, */ +/* INFO ) */ + +/* INTEGER INFO, LDA, LDB, LDT, N, M, L, MB */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTPLQT computes a blocked LQ factorization of a real */ +/* > "triangular-pentagonal" matrix C, which is composed of a */ +/* > triangular block A and pentagonal block B, using the compact */ +/* > WY representation for Q. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix B, and the order of the */ +/* > triangular matrix A. */ +/* > M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix B. */ +/* > N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The number of rows of the lower trapezoidal part of B. */ +/* > MIN(M,N) >= L >= 0. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MB */ +/* > \verbatim */ +/* > MB is INTEGER */ +/* > The block size to be used in the blocked QR. M >= MB >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,M) */ +/* > On entry, the lower triangular M-by-M matrix A. */ +/* > On exit, the elements on and below the diagonal of the array */ +/* > contain the lower triangular matrix L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,N) */ +/* > On entry, the pentagonal M-by-N matrix B. The first N-L columns */ +/* > are rectangular, and the last L columns are lower trapezoidal. */ +/* > On exit, B contains the pentagonal matrix V. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is DOUBLE PRECISION array, dimension (LDT,N) */ +/* > The lower triangular block reflectors stored in compact form */ +/* > as a sequence of upper triangular blocks. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= MB. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MB*M) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The input matrix C is a M-by-(M+N) matrix */ +/* > */ +/* > C = [ A ] [ B ] */ +/* > */ +/* > */ +/* > where A is an lower triangular M-by-M matrix, and B is M-by-N pentagonal */ +/* > matrix consisting of a M-by-(N-L) rectangular matrix B1 on left of a M-by-L */ +/* > upper trapezoidal matrix B2: */ +/* > [ B ] = [ B1 ] [ B2 ] */ +/* > [ B1 ] <- M-by-(N-L) rectangular */ +/* > [ B2 ] <- M-by-L lower trapezoidal. */ +/* > */ +/* > The lower trapezoidal matrix B2 consists of the first L columns of a */ +/* > M-by-M lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0, */ +/* > B is rectangular M-by-N; if M=L=N, B is lower triangular. */ +/* > */ +/* > The matrix W stores the elementary reflectors H(i) in the i-th row */ +/* > above the diagonal (of A) in the M-by-(M+N) input matrix C */ +/* > [ C ] = [ A ] [ B ] */ +/* > [ A ] <- lower triangular M-by-M */ +/* > [ B ] <- M-by-N pentagonal */ +/* > */ +/* > so that W can be represented as */ +/* > [ W ] = [ I ] [ V ] */ +/* > [ I ] <- identity, M-by-M */ +/* > [ V ] <- M-by-N, same form as B. */ +/* > */ +/* > Thus, all of information needed for W is contained on exit in B, which */ +/* > we call V above. Note that V has the same form as B; that is, */ +/* > [ V ] = [ V1 ] [ V2 ] */ +/* > [ V1 ] <- M-by-(N-L) rectangular */ +/* > [ V2 ] <- M-by-L lower trapezoidal. */ +/* > */ +/* > The rows of V represent the vectors which define the H(i)'s. */ +/* > */ +/* > The number of blocks is B = ceiling(M/MB), where each */ +/* > block is of order MB except for the last block, which is of order */ +/* > IB = M - (M-1)*MB. For each of the B blocks, a upper triangular block */ +/* > reflector factor is computed: T1, T2, ..., TB. The MB-by-MB (and IB-by-IB */ +/* > for the last block) T's are stored in the MB-by-N matrix T as */ +/* > */ +/* > T = [T1 T2 ... TB]. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtplqt_(integer *m, integer *n, integer *l, integer *mb, + doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * + t, integer *ldt, doublereal *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, t_dim1, t_offset, i__1, i__2, + i__3, i__4; + + /* Local variables */ + integer i__, iinfo, ib, lb, nb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dtprfb_( + char *, char *, char *, char *, integer *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *), dtplqt2_(integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *); + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*l < 0 || *l > f2cmin(*m,*n) && f2cmin(*m,*n) >= 0) { + *info = -3; + } else if (*mb < 1 || *mb > *m && *m > 0) { + *info = -4; + } else if (*lda < f2cmax(1,*m)) { + *info = -6; + } else if (*ldb < f2cmax(1,*m)) { + *info = -8; + } else if (*ldt < *mb) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTPLQT", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + + i__1 = *m; + i__2 = *mb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + +/* Compute the QR factorization of the current block */ + +/* Computing MIN */ + i__3 = *m - i__ + 1; + ib = f2cmin(i__3,*mb); +/* Computing MIN */ + i__3 = *n - *l + i__ + ib - 1; + nb = f2cmin(i__3,*n); + if (i__ >= *l) { + lb = 0; + } else { + lb = nb - *n + *l - i__ + 1; + } + + dtplqt2_(&ib, &nb, &lb, &a[i__ + i__ * a_dim1], lda, &b[i__ + b_dim1], + ldb, &t[i__ * t_dim1 + 1], ldt, &iinfo); + +/* Update by applying H**T to B(I+IB:M,:) from the right */ + + if (i__ + ib <= *m) { + i__3 = *m - i__ - ib + 1; + i__4 = *m - i__ - ib + 1; + dtprfb_("R", "N", "F", "R", &i__3, &nb, &ib, &lb, &b[i__ + b_dim1] + , ldb, &t[i__ * t_dim1 + 1], ldt, &a[i__ + ib + i__ * + a_dim1], lda, &b[i__ + ib + b_dim1], ldb, &work[1], &i__4); + } + } + return 0; + +/* End of DTPLQT */ + +} /* dtplqt_ */ + diff --git a/lapack-netlib/SRC/dtplqt2.c b/lapack-netlib/SRC/dtplqt2.c new file mode 100644 index 000000000..395a4816f --- /dev/null +++ b/lapack-netlib/SRC/dtplqt2.c @@ -0,0 +1,744 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTPLQT2 computes a LQ factorization of a real or complex "triangular-pentagonal" matrix, which +is composed of a triangular block and a pentagonal block, using the compact WY representation for Q. +*/ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTPLQT2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTPLQT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) */ + +/* INTEGER INFO, LDA, LDB, LDT, N, M, L */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTPLQT2 computes a LQ a factorization of a real "triangular-pentagonal" */ +/* > matrix C, which is composed of a triangular block A and pentagonal block B, */ +/* > using the compact WY representation for Q. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The total number of rows of the matrix B. */ +/* > M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix B, and the order of */ +/* > the triangular matrix A. */ +/* > N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The number of rows of the lower trapezoidal part of B. */ +/* > MIN(M,N) >= L >= 0. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,M) */ +/* > On entry, the lower triangular M-by-M matrix A. */ +/* > On exit, the elements on and below the diagonal of the array */ +/* > contain the lower triangular matrix L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,N) */ +/* > On entry, the pentagonal M-by-N matrix B. The first N-L columns */ +/* > are rectangular, and the last L columns are lower trapezoidal. */ +/* > On exit, B contains the pentagonal matrix V. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is DOUBLE PRECISION array, dimension (LDT,M) */ +/* > The N-by-N upper triangular factor T of the block reflector. */ +/* > See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax(1,M) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The input matrix C is a M-by-(M+N) matrix */ +/* > */ +/* > C = [ A ][ B ] */ +/* > */ +/* > */ +/* > where A is an lower triangular M-by-M matrix, and B is M-by-N pentagonal */ +/* > matrix consisting of a M-by-(N-L) rectangular matrix B1 left of a M-by-L */ +/* > upper trapezoidal matrix B2: */ +/* > */ +/* > B = [ B1 ][ B2 ] */ +/* > [ B1 ] <- M-by-(N-L) rectangular */ +/* > [ B2 ] <- M-by-L lower trapezoidal. */ +/* > */ +/* > The lower trapezoidal matrix B2 consists of the first L columns of a */ +/* > N-by-N lower triangular matrix, where 0 <= L <= MIN(M,N). If L=0, */ +/* > B is rectangular M-by-N; if M=L=N, B is lower triangular. */ +/* > */ +/* > The matrix W stores the elementary reflectors H(i) in the i-th row */ +/* > above the diagonal (of A) in the M-by-(M+N) input matrix C */ +/* > */ +/* > C = [ A ][ B ] */ +/* > [ A ] <- lower triangular M-by-M */ +/* > [ B ] <- M-by-N pentagonal */ +/* > */ +/* > so that W can be represented as */ +/* > */ +/* > W = [ I ][ V ] */ +/* > [ I ] <- identity, M-by-M */ +/* > [ V ] <- M-by-N, same form as B. */ +/* > */ +/* > Thus, all of information needed for W is contained on exit in B, which */ +/* > we call V above. Note that V has the same form as B; that is, */ +/* > */ +/* > W = [ V1 ][ V2 ] */ +/* > [ V1 ] <- M-by-(N-L) rectangular */ +/* > [ V2 ] <- M-by-L lower trapezoidal. */ +/* > */ +/* > The rows of V represent the vectors which define the H(i)'s. */ +/* > The (M+N)-by-(M+N) block reflector H is then given by */ +/* > */ +/* > H = I - W**T * T * W */ +/* > */ +/* > where W^H is the conjugate transpose of W and T is the upper triangular */ +/* > factor of the block reflector. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtplqt2_(integer *m, integer *n, integer *l, doublereal * + a, integer *lda, doublereal *b, integer *ldb, doublereal *t, integer * + ldt, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, t_dim1, t_offset, i__1, i__2, + i__3; + + /* Local variables */ + extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *); + integer i__, j, p; + doublereal alpha; + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *), dtrmv_(char *, + char *, char *, integer *, doublereal *, integer *, doublereal *, + integer *); + integer mp, np; + extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *, + integer *, doublereal *), xerbla_(char *, integer *, ftnlen); + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*l < 0 || *l > f2cmin(*m,*n)) { + *info = -3; + } else if (*lda < f2cmax(1,*m)) { + *info = -5; + } else if (*ldb < f2cmax(1,*m)) { + *info = -7; + } else if (*ldt < f2cmax(1,*m)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTPLQT2", &i__1, (ftnlen)7); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *m == 0) { + return 0; + } + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Generate elementary reflector H(I) to annihilate B(I,:) */ + + p = *n - *l + f2cmin(*l,i__); + i__2 = p + 1; + dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &b[i__ + b_dim1], ldb, &t[i__ * + t_dim1 + 1]); + if (i__ < *m) { + +/* W(M-I:1) := C(I+1:M,I:N) * C(I,I:N) [use W = T(M,:)] */ + + i__2 = *m - i__; + for (j = 1; j <= i__2; ++j) { + t[*m + j * t_dim1] = a[i__ + j + i__ * a_dim1]; + } + i__2 = *m - i__; + dgemv_("N", &i__2, &p, &c_b4, &b[i__ + 1 + b_dim1], ldb, &b[i__ + + b_dim1], ldb, &c_b4, &t[*m + t_dim1], ldt); + +/* C(I+1:M,I:N) = C(I+1:M,I:N) + alpha * C(I,I:N)*W(M-1:1)^H */ + + alpha = -t[i__ * t_dim1 + 1]; + i__2 = *m - i__; + for (j = 1; j <= i__2; ++j) { + a[i__ + j + i__ * a_dim1] += alpha * t[*m + j * t_dim1]; + } + i__2 = *m - i__; + dger_(&i__2, &p, &alpha, &t[*m + t_dim1], ldt, &b[i__ + b_dim1], + ldb, &b[i__ + 1 + b_dim1], ldb); + } + } + + i__1 = *m; + for (i__ = 2; i__ <= i__1; ++i__) { + +/* T(I,1:I-1) := C(I:I-1,1:N) * (alpha * C(I,I:N)^H) */ + + alpha = -t[i__ * t_dim1 + 1]; + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[i__ + j * t_dim1] = 0.; + } +/* Computing MIN */ + i__2 = i__ - 1; + p = f2cmin(i__2,*l); +/* Computing MIN */ + i__2 = *n - *l + 1; + np = f2cmin(i__2,*n); +/* Computing MIN */ + i__2 = p + 1; + mp = f2cmin(i__2,*m); + +/* Triangular part of B2 */ + + i__2 = p; + for (j = 1; j <= i__2; ++j) { + t[i__ + j * t_dim1] = alpha * b[i__ + (*n - *l + j) * b_dim1]; + } + dtrmv_("L", "N", "N", &p, &b[np * b_dim1 + 1], ldb, &t[i__ + t_dim1], + ldt); + +/* Rectangular part of B2 */ + + i__2 = i__ - 1 - p; + dgemv_("N", &i__2, l, &alpha, &b[mp + np * b_dim1], ldb, &b[i__ + np * + b_dim1], ldb, &c_b10, &t[i__ + mp * t_dim1], ldt); + +/* B1 */ + + i__2 = i__ - 1; + i__3 = *n - *l; + dgemv_("N", &i__2, &i__3, &alpha, &b[b_offset], ldb, &b[i__ + b_dim1], + ldb, &c_b4, &t[i__ + t_dim1], ldt); + +/* T(1:I-1,I) := T(1:I-1,1:I-1) * T(I,1:I-1) */ + + i__2 = i__ - 1; + dtrmv_("L", "T", "N", &i__2, &t[t_offset], ldt, &t[i__ + t_dim1], ldt); + +/* T(I,I) = tau(I) */ + + t[i__ + i__ * t_dim1] = t[i__ * t_dim1 + 1]; + t[i__ * t_dim1 + 1] = 0.; + } + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *m; + for (j = i__ + 1; j <= i__2; ++j) { + t[i__ + j * t_dim1] = t[j + i__ * t_dim1]; + t[j + i__ * t_dim1] = 0.; + } + } + +/* End of DTPLQT2 */ + + return 0; +} /* dtplqt2_ */ + diff --git a/lapack-netlib/SRC/dtpmlqt.c b/lapack-netlib/SRC/dtpmlqt.c new file mode 100644 index 000000000..7d6e2d404 --- /dev/null +++ b/lapack-netlib/SRC/dtpmlqt.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 DTPMLQT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTPMQRT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTPMLQT( SIDE, TRANS, M, N, K, L, MB, V, LDV, T, LDT, */ +/* A, LDA, B, LDB, WORK, INFO ) */ + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, K, LDV, LDA, LDB, M, N, L, MB, LDT */ +/* DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ), */ +/* $ T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTPMQRT applies a real orthogonal matrix Q obtained from a */ +/* > "triangular-pentagonal" real block reflector H to a general */ +/* > real matrix C, which consists of two blocks A and B. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**T from the Left; */ +/* > = 'R': apply Q or Q**T from the Right. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': No transpose, apply Q; */ +/* > = 'T': Transpose, apply Q**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix B. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The order of the trapezoidal part of V. */ +/* > K >= L >= 0. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MB */ +/* > \verbatim */ +/* > MB is INTEGER */ +/* > The block size used for the storage of T. K >= MB >= 1. */ +/* > This must be the same value of MB used to generate T */ +/* > in DTPLQT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is DOUBLE PRECISION array, dimension (LDV,K) */ +/* > The i-th row must contain the vector which defines the */ +/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* > DTPLQT in B. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. */ +/* > If SIDE = 'L', LDV >= f2cmax(1,M); */ +/* > if SIDE = 'R', LDV >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is DOUBLE PRECISION array, dimension (LDT,K) */ +/* > The upper triangular factors of the block reflectors */ +/* > as returned by DTPLQT, stored as a MB-by-K matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= MB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension */ +/* > (LDA,N) if SIDE = 'L' or */ +/* > (LDA,K) if SIDE = 'R' */ +/* > On entry, the K-by-N or M-by-K matrix A. */ +/* > On exit, A is overwritten by the corresponding block of */ +/* > Q*C or Q**T*C or C*Q or C*Q**T. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > If SIDE = 'L', LDC >= f2cmax(1,K); */ +/* > If SIDE = 'R', LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,N) */ +/* > On entry, the M-by-N matrix B. */ +/* > On exit, B is overwritten by the corresponding block of */ +/* > Q*C or Q**T*C or C*Q or C*Q**T. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. */ +/* > LDB >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array. The dimension of WORK is */ +/* > N*MB if SIDE = 'L', or M*MB if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The columns of the pentagonal matrix V contain the elementary reflectors */ +/* > H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a */ +/* > trapezoidal block V2: */ +/* > */ +/* > V = [V1] [V2]. */ +/* > */ +/* > */ +/* > The size of the trapezoidal block V2 is determined by the parameter L, */ +/* > where 0 <= L <= K; V2 is lower trapezoidal, consisting of the first L */ +/* > rows of a K-by-K upper triangular matrix. If L=K, V2 is lower triangular; */ +/* > if L=0, there is no trapezoidal block, hence V = V1 is rectangular. */ +/* > */ +/* > If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is K-by-M. */ +/* > [B] */ +/* > */ +/* > If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is K-by-N. */ +/* > */ +/* > The real orthogonal matrix Q is formed from V and T. */ +/* > */ +/* > If TRANS='N' and SIDE='L', C is on exit replaced with Q * C. */ +/* > */ +/* > If TRANS='T' and SIDE='L', C is on exit replaced with Q**T * C. */ +/* > */ +/* > If TRANS='N' and SIDE='R', C is on exit replaced with C * Q. */ +/* > */ +/* > If TRANS='T' and SIDE='R', C is on exit replaced with C * Q**T. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtpmlqt_(char *side, char *trans, integer *m, integer *n, + integer *k, integer *l, integer *mb, doublereal *v, integer *ldv, + doublereal *t, integer *ldt, doublereal *a, integer *lda, doublereal * + b, integer *ldb, doublereal *work, integer *info) +{ + /* System generated locals */ + integer v_dim1, v_offset, a_dim1, a_offset, b_dim1, b_offset, t_dim1, + t_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer ldaq; + logical left, tran; + integer i__; + extern logical lsame_(char *, char *); + logical right; + integer ib, lb, nb, kf; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dtprfb_( + char *, char *, char *, char *, integer *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *); + logical notran; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + + + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + right = lsame_(side, "R"); + tran = lsame_(trans, "T"); + notran = lsame_(trans, "N"); + + if (left) { + ldaq = f2cmax(1,*k); + } else if (right) { + ldaq = f2cmax(1,*m); + } + if (! left && ! right) { + *info = -1; + } else if (! tran && ! notran) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0) { + *info = -5; + } else if (*l < 0 || *l > *k) { + *info = -6; + } else if (*mb < 1 || *mb > *k && *k > 0) { + *info = -7; + } else if (*ldv < *k) { + *info = -9; + } else if (*ldt < *mb) { + *info = -11; + } else if (*lda < ldaq) { + *info = -13; + } else if (*ldb < f2cmax(1,*m)) { + *info = -15; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTPMLQT", &i__1, (ftnlen)7); + return 0; + } + + + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + + if (left && notran) { + + i__1 = *k; + i__2 = *mb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = *mb, i__4 = *k - i__ + 1; + ib = f2cmin(i__3,i__4); +/* Computing MIN */ + i__3 = *m - *l + i__ + ib - 1; + nb = f2cmin(i__3,*m); + if (i__ >= *l) { + lb = 0; + } else { + lb = 0; + } + dtprfb_("L", "T", "F", "R", &nb, n, &ib, &lb, &v[i__ + v_dim1], + ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ + a_dim1], lda, &b[ + b_offset], ldb, &work[1], &ib); + } + + } else if (right && tran) { + + i__2 = *k; + i__1 = *mb; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { +/* Computing MIN */ + i__3 = *mb, i__4 = *k - i__ + 1; + ib = f2cmin(i__3,i__4); +/* Computing MIN */ + i__3 = *n - *l + i__ + ib - 1; + nb = f2cmin(i__3,*n); + if (i__ >= *l) { + lb = 0; + } else { + lb = nb - *n + *l - i__ + 1; + } + dtprfb_("R", "N", "F", "R", m, &nb, &ib, &lb, &v[i__ + v_dim1], + ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ * a_dim1 + 1], lda, + &b[b_offset], ldb, &work[1], m); + } + + } else if (left && tran) { + + kf = (*k - 1) / *mb * *mb + 1; + i__1 = -(*mb); + for (i__ = kf; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { +/* Computing MIN */ + i__2 = *mb, i__3 = *k - i__ + 1; + ib = f2cmin(i__2,i__3); +/* Computing MIN */ + i__2 = *m - *l + i__ + ib - 1; + nb = f2cmin(i__2,*m); + if (i__ >= *l) { + lb = 0; + } else { + lb = 0; + } + dtprfb_("L", "N", "F", "R", &nb, n, &ib, &lb, &v[i__ + v_dim1], + ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ + a_dim1], lda, &b[ + b_offset], ldb, &work[1], &ib); + } + + } else if (right && notran) { + + kf = (*k - 1) / *mb * *mb + 1; + i__1 = -(*mb); + for (i__ = kf; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { +/* Computing MIN */ + i__2 = *mb, i__3 = *k - i__ + 1; + ib = f2cmin(i__2,i__3); +/* Computing MIN */ + i__2 = *n - *l + i__ + ib - 1; + nb = f2cmin(i__2,*n); + if (i__ >= *l) { + lb = 0; + } else { + lb = nb - *n + *l - i__ + 1; + } + dtprfb_("R", "T", "F", "R", m, &nb, &ib, &lb, &v[i__ + v_dim1], + ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ * a_dim1 + 1], lda, + &b[b_offset], ldb, &work[1], m); + } + + } + + return 0; + +/* End of DTPMLQT */ + +} /* dtpmlqt_ */ + diff --git a/lapack-netlib/SRC/dtpmqrt.c b/lapack-netlib/SRC/dtpmqrt.c new file mode 100644 index 000000000..9fcd76f68 --- /dev/null +++ b/lapack-netlib/SRC/dtpmqrt.c @@ -0,0 +1,792 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTPMQRT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTPMQRT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT, */ +/* A, LDA, B, LDB, WORK, INFO ) */ + +/* CHARACTER SIDE, TRANS */ +/* INTEGER INFO, K, LDV, LDA, LDB, M, N, L, NB, LDT */ +/* DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ), */ +/* $ T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTPMQRT applies a real orthogonal matrix Q obtained from a */ +/* > "triangular-pentagonal" real block reflector H to a general */ +/* > real matrix C, which consists of two blocks A and B. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply Q or Q**T from the Left; */ +/* > = 'R': apply Q or Q**T from the Right. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > = 'N': No transpose, apply Q; */ +/* > = 'T': Transpose, apply Q**T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix B. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The number of elementary reflectors whose product defines */ +/* > the matrix Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The order of the trapezoidal part of V. */ +/* > K >= L >= 0. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The block size used for the storage of T. K >= NB >= 1. */ +/* > This must be the same value of NB used to generate T */ +/* > in CTPQRT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is DOUBLE PRECISION array, dimension (LDV,K) */ +/* > The i-th column must contain the vector which defines the */ +/* > elementary reflector H(i), for i = 1,2,...,k, as returned by */ +/* > CTPQRT in B. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. */ +/* > If SIDE = 'L', LDV >= f2cmax(1,M); */ +/* > if SIDE = 'R', LDV >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is DOUBLE PRECISION array, dimension (LDT,K) */ +/* > The upper triangular factors of the block reflectors */ +/* > as returned by CTPQRT, stored as a NB-by-K matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension */ +/* > (LDA,N) if SIDE = 'L' or */ +/* > (LDA,K) if SIDE = 'R' */ +/* > On entry, the K-by-N or M-by-K matrix A. */ +/* > On exit, A is overwritten by the corresponding block of */ +/* > Q*C or Q**T*C or C*Q or C*Q**T. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > If SIDE = 'L', LDC >= f2cmax(1,K); */ +/* > If SIDE = 'R', LDC >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,N) */ +/* > On entry, the M-by-N matrix B. */ +/* > On exit, B is overwritten by the corresponding block of */ +/* > Q*C or Q**T*C or C*Q or C*Q**T. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. */ +/* > LDB >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array. The dimension of WORK is */ +/* > N*NB if SIDE = 'L', or M*NB if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The columns of the pentagonal matrix V contain the elementary reflectors */ +/* > H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a */ +/* > trapezoidal block V2: */ +/* > */ +/* > V = [V1] */ +/* > [V2]. */ +/* > */ +/* > The size of the trapezoidal block V2 is determined by the parameter L, */ +/* > where 0 <= L <= K; V2 is upper trapezoidal, consisting of the first L */ +/* > rows of a K-by-K upper triangular matrix. If L=K, V2 is upper triangular; */ +/* > if L=0, there is no trapezoidal block, hence V = V1 is rectangular. */ +/* > */ +/* > If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is M-by-K. */ +/* > [B] */ +/* > */ +/* > If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is N-by-K. */ +/* > */ +/* > The real orthogonal matrix Q is formed from V and T. */ +/* > */ +/* > If TRANS='N' and SIDE='L', C is on exit replaced with Q * C. */ +/* > */ +/* > If TRANS='T' and SIDE='L', C is on exit replaced with Q**T * C. */ +/* > */ +/* > If TRANS='N' and SIDE='R', C is on exit replaced with C * Q. */ +/* > */ +/* > If TRANS='T' and SIDE='R', C is on exit replaced with C * Q**T. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtpmqrt_(char *side, char *trans, integer *m, integer *n, + integer *k, integer *l, integer *nb, doublereal *v, integer *ldv, + doublereal *t, integer *ldt, doublereal *a, integer *lda, doublereal * + b, integer *ldb, doublereal *work, integer *info) +{ + /* System generated locals */ + integer v_dim1, v_offset, a_dim1, a_offset, b_dim1, b_offset, t_dim1, + t_offset, i__1, i__2, i__3, i__4; + + /* Local variables */ + integer ldaq; + logical left, tran; + integer ldvq, i__; + extern logical lsame_(char *, char *); + logical right; + integer ib, lb, mb, kf; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dtprfb_( + char *, char *, char *, char *, integer *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *); + logical notran; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + + + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --work; + + /* Function Body */ + *info = 0; + left = lsame_(side, "L"); + right = lsame_(side, "R"); + tran = lsame_(trans, "T"); + notran = lsame_(trans, "N"); + + if (left) { + ldvq = f2cmax(1,*m); + ldaq = f2cmax(1,*k); + } else if (right) { + ldvq = f2cmax(1,*n); + ldaq = f2cmax(1,*m); + } + if (! left && ! right) { + *info = -1; + } else if (! tran && ! notran) { + *info = -2; + } else if (*m < 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*k < 0) { + *info = -5; + } else if (*l < 0 || *l > *k) { + *info = -6; + } else if (*nb < 1 || *nb > *k && *k > 0) { + *info = -7; + } else if (*ldv < ldvq) { + *info = -9; + } else if (*ldt < *nb) { + *info = -11; + } else if (*lda < ldaq) { + *info = -13; + } else if (*ldb < f2cmax(1,*m)) { + *info = -15; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTPMQRT", &i__1, (ftnlen)7); + return 0; + } + + + if (*m == 0 || *n == 0 || *k == 0) { + return 0; + } + + if (left && tran) { + + i__1 = *k; + i__2 = *nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { +/* Computing MIN */ + i__3 = *nb, i__4 = *k - i__ + 1; + ib = f2cmin(i__3,i__4); +/* Computing MIN */ + i__3 = *m - *l + i__ + ib - 1; + mb = f2cmin(i__3,*m); + if (i__ >= *l) { + lb = 0; + } else { + lb = mb - *m + *l - i__ + 1; + } + dtprfb_("L", "T", "F", "C", &mb, n, &ib, &lb, &v[i__ * v_dim1 + 1] + , ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ + a_dim1], lda, & + b[b_offset], ldb, &work[1], &ib); + } + + } else if (right && notran) { + + i__2 = *k; + i__1 = *nb; + for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) { +/* Computing MIN */ + i__3 = *nb, i__4 = *k - i__ + 1; + ib = f2cmin(i__3,i__4); +/* Computing MIN */ + i__3 = *n - *l + i__ + ib - 1; + mb = f2cmin(i__3,*n); + if (i__ >= *l) { + lb = 0; + } else { + lb = mb - *n + *l - i__ + 1; + } + dtprfb_("R", "N", "F", "C", m, &mb, &ib, &lb, &v[i__ * v_dim1 + 1] + , ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ * a_dim1 + 1], + lda, &b[b_offset], ldb, &work[1], m); + } + + } else if (left && notran) { + + kf = (*k - 1) / *nb * *nb + 1; + i__1 = -(*nb); + for (i__ = kf; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { +/* Computing MIN */ + i__2 = *nb, i__3 = *k - i__ + 1; + ib = f2cmin(i__2,i__3); +/* Computing MIN */ + i__2 = *m - *l + i__ + ib - 1; + mb = f2cmin(i__2,*m); + if (i__ >= *l) { + lb = 0; + } else { + lb = mb - *m + *l - i__ + 1; + } + dtprfb_("L", "N", "F", "C", &mb, n, &ib, &lb, &v[i__ * v_dim1 + 1] + , ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ + a_dim1], lda, & + b[b_offset], ldb, &work[1], &ib); + } + + } else if (right && tran) { + + kf = (*k - 1) / *nb * *nb + 1; + i__1 = -(*nb); + for (i__ = kf; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) { +/* Computing MIN */ + i__2 = *nb, i__3 = *k - i__ + 1; + ib = f2cmin(i__2,i__3); +/* Computing MIN */ + i__2 = *n - *l + i__ + ib - 1; + mb = f2cmin(i__2,*n); + if (i__ >= *l) { + lb = 0; + } else { + lb = mb - *n + *l - i__ + 1; + } + dtprfb_("R", "T", "F", "C", m, &mb, &ib, &lb, &v[i__ * v_dim1 + 1] + , ldv, &t[i__ * t_dim1 + 1], ldt, &a[i__ * a_dim1 + 1], + lda, &b[b_offset], ldb, &work[1], m); + } + + } + + return 0; + +/* End of DTPMQRT */ + +} /* dtpmqrt_ */ + diff --git a/lapack-netlib/SRC/dtpqrt.c b/lapack-netlib/SRC/dtpqrt.c new file mode 100644 index 000000000..34d3a9033 --- /dev/null +++ b/lapack-netlib/SRC/dtpqrt.c @@ -0,0 +1,683 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTPQRT */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTPQRT + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTPQRT( M, N, L, NB, A, LDA, B, LDB, T, LDT, WORK, */ +/* INFO ) */ + +/* INTEGER INFO, LDA, LDB, LDT, N, M, L, NB */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTPQRT computes a blocked QR factorization of a real */ +/* > "triangular-pentagonal" matrix C, which is composed of a */ +/* > triangular block A and pentagonal block B, using the compact */ +/* > WY representation for Q. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix B. */ +/* > M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix B, and the order of the */ +/* > triangular matrix A. */ +/* > N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The number of rows of the upper trapezoidal part of B. */ +/* > MIN(M,N) >= L >= 0. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The block size to be used in the blocked QR. N >= NB >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the upper triangular N-by-N matrix A. */ +/* > On exit, the elements on and above the diagonal of the array */ +/* > contain the upper triangular matrix R. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,N) */ +/* > On entry, the pentagonal M-by-N matrix B. The first M-L rows */ +/* > are rectangular, and the last L rows are upper trapezoidal. */ +/* > On exit, B contains the pentagonal matrix V. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is DOUBLE PRECISION array, dimension (LDT,N) */ +/* > The upper triangular block reflectors stored in compact form */ +/* > as a sequence of upper triangular blocks. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= NB. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (NB*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The input matrix C is a (N+M)-by-N matrix */ +/* > */ +/* > C = [ A ] */ +/* > [ B ] */ +/* > */ +/* > where A is an upper triangular N-by-N matrix, and B is M-by-N pentagonal */ +/* > matrix consisting of a (M-L)-by-N rectangular matrix B1 on top of a L-by-N */ +/* > upper trapezoidal matrix B2: */ +/* > */ +/* > B = [ B1 ] <- (M-L)-by-N rectangular */ +/* > [ B2 ] <- L-by-N upper trapezoidal. */ +/* > */ +/* > The upper trapezoidal matrix B2 consists of the first L rows of a */ +/* > N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, */ +/* > B is rectangular M-by-N; if M=L=N, B is upper triangular. */ +/* > */ +/* > The matrix W stores the elementary reflectors H(i) in the i-th column */ +/* > below the diagonal (of A) in the (N+M)-by-N input matrix C */ +/* > */ +/* > C = [ A ] <- upper triangular N-by-N */ +/* > [ B ] <- M-by-N pentagonal */ +/* > */ +/* > so that W can be represented as */ +/* > */ +/* > W = [ I ] <- identity, N-by-N */ +/* > [ V ] <- M-by-N, same form as B. */ +/* > */ +/* > Thus, all of information needed for W is contained on exit in B, which */ +/* > we call V above. Note that V has the same form as B; that is, */ +/* > */ +/* > V = [ V1 ] <- (M-L)-by-N rectangular */ +/* > [ V2 ] <- L-by-N upper trapezoidal. */ +/* > */ +/* > The columns of V represent the vectors which define the H(i)'s. */ +/* > */ +/* > The number of blocks is B = ceiling(N/NB), where each */ +/* > block is of order NB except for the last block, which is of order */ +/* > IB = N - (B-1)*NB. For each of the B blocks, a upper triangular block */ +/* > reflector factor is computed: T1, T2, ..., TB. The NB-by-NB (and IB-by-IB */ +/* > for the last block) T's are stored in the NB-by-N matrix T as */ +/* > */ +/* > T = [T1 T2 ... TB]. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtpqrt_(integer *m, integer *n, integer *l, integer *nb, + doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal * + t, integer *ldt, doublereal *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, t_dim1, t_offset, i__1, i__2, + i__3; + + /* Local variables */ + integer i__, iinfo, ib, lb, mb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dtprfb_( + char *, char *, char *, char *, integer *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *), dtpqrt2_(integer *, + integer *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + --work; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*l < 0 || *l > f2cmin(*m,*n) && f2cmin(*m,*n) >= 0) { + *info = -3; + } else if (*nb < 1 || *nb > *n && *n > 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } else if (*ldb < f2cmax(1,*m)) { + *info = -8; + } else if (*ldt < *nb) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTPQRT", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + + i__1 = *n; + i__2 = *nb; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + +/* Compute the QR factorization of the current block */ + +/* Computing MIN */ + i__3 = *n - i__ + 1; + ib = f2cmin(i__3,*nb); +/* Computing MIN */ + i__3 = *m - *l + i__ + ib - 1; + mb = f2cmin(i__3,*m); + if (i__ >= *l) { + lb = 0; + } else { + lb = mb - *m + *l - i__ + 1; + } + + dtpqrt2_(&mb, &ib, &lb, &a[i__ + i__ * a_dim1], lda, &b[i__ * b_dim1 + + 1], ldb, &t[i__ * t_dim1 + 1], ldt, &iinfo); + +/* Update by applying H**T to B(:,I+IB:N) from the left */ + + if (i__ + ib <= *n) { + i__3 = *n - i__ - ib + 1; + dtprfb_("L", "T", "F", "C", &mb, &i__3, &ib, &lb, &b[i__ * b_dim1 + + 1], ldb, &t[i__ * t_dim1 + 1], ldt, &a[i__ + (i__ + ib) + * a_dim1], lda, &b[(i__ + ib) * b_dim1 + 1], ldb, &work[1] + , &ib); + } + } + return 0; + +/* End of DTPQRT */ + +} /* dtpqrt_ */ + diff --git a/lapack-netlib/SRC/dtpqrt2.c b/lapack-netlib/SRC/dtpqrt2.c new file mode 100644 index 000000000..4b75585c5 --- /dev/null +++ b/lapack-netlib/SRC/dtpqrt2.c @@ -0,0 +1,735 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTPQRT2 computes a QR factorization of a real or complex "triangular-pentagonal" matrix, which +is composed of a triangular block and a pentagonal block, using the compact WY representation for Q. +*/ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTPQRT2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTPQRT2( M, N, L, A, LDA, B, LDB, T, LDT, INFO ) */ + +/* INTEGER INFO, LDA, LDB, LDT, N, M, L */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTPQRT2 computes a QR factorization of a real "triangular-pentagonal" */ +/* > matrix C, which is composed of a triangular block A and pentagonal block B, */ +/* > using the compact WY representation for Q. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The total number of rows of the matrix B. */ +/* > M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix B, and the order of */ +/* > the triangular matrix A. */ +/* > N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The number of rows of the upper trapezoidal part of B. */ +/* > MIN(M,N) >= L >= 0. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the upper triangular N-by-N matrix A. */ +/* > On exit, the elements on and above the diagonal of the array */ +/* > contain the upper triangular matrix R. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,N) */ +/* > On entry, the pentagonal M-by-N matrix B. The first M-L rows */ +/* > are rectangular, and the last L rows are upper trapezoidal. */ +/* > On exit, B contains the pentagonal matrix V. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] T */ +/* > \verbatim */ +/* > T is DOUBLE PRECISION array, dimension (LDT,N) */ +/* > The N-by-N upper triangular factor T of the block reflector. */ +/* > See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax(1,N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The input matrix C is a (N+M)-by-N matrix */ +/* > */ +/* > C = [ A ] */ +/* > [ B ] */ +/* > */ +/* > where A is an upper triangular N-by-N matrix, and B is M-by-N pentagonal */ +/* > matrix consisting of a (M-L)-by-N rectangular matrix B1 on top of a L-by-N */ +/* > upper trapezoidal matrix B2: */ +/* > */ +/* > B = [ B1 ] <- (M-L)-by-N rectangular */ +/* > [ B2 ] <- L-by-N upper trapezoidal. */ +/* > */ +/* > The upper trapezoidal matrix B2 consists of the first L rows of a */ +/* > N-by-N upper triangular matrix, where 0 <= L <= MIN(M,N). If L=0, */ +/* > B is rectangular M-by-N; if M=L=N, B is upper triangular. */ +/* > */ +/* > The matrix W stores the elementary reflectors H(i) in the i-th column */ +/* > below the diagonal (of A) in the (N+M)-by-N input matrix C */ +/* > */ +/* > C = [ A ] <- upper triangular N-by-N */ +/* > [ B ] <- M-by-N pentagonal */ +/* > */ +/* > so that W can be represented as */ +/* > */ +/* > W = [ I ] <- identity, N-by-N */ +/* > [ V ] <- M-by-N, same form as B. */ +/* > */ +/* > Thus, all of information needed for W is contained on exit in B, which */ +/* > we call V above. Note that V has the same form as B; that is, */ +/* > */ +/* > V = [ V1 ] <- (M-L)-by-N rectangular */ +/* > [ V2 ] <- L-by-N upper trapezoidal. */ +/* > */ +/* > The columns of V represent the vectors which define the H(i)'s. */ +/* > The (M+N)-by-(M+N) block reflector H is then given by */ +/* > */ +/* > H = I - W * T * W**T */ +/* > */ +/* > where W^H is the conjugate transpose of W and T is the upper triangular */ +/* > factor of the block reflector. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtpqrt2_(integer *m, integer *n, integer *l, doublereal * + a, integer *lda, doublereal *b, integer *ldb, doublereal *t, integer * + ldt, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, t_dim1, t_offset, i__1, i__2, + i__3; + + /* Local variables */ + extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *); + integer i__, j, p; + doublereal alpha; + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *), dtrmv_(char *, + char *, char *, integer *, doublereal *, integer *, doublereal *, + integer *); + integer mp, np; + extern /* Subroutine */ int dlarfg_(integer *, doublereal *, doublereal *, + integer *, doublereal *), 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 */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*l < 0 || *l > f2cmin(*m,*n)) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*m)) { + *info = -7; + } else if (*ldt < f2cmax(1,*n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTPQRT2", &i__1, (ftnlen)7); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *m == 0) { + return 0; + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Generate elementary reflector H(I) to annihilate B(:,I) */ + + p = *m - *l + f2cmin(*l,i__); + i__2 = p + 1; + dlarfg_(&i__2, &a[i__ + i__ * a_dim1], &b[i__ * b_dim1 + 1], &c__1, & + t[i__ + t_dim1]); + if (i__ < *n) { + +/* W(1:N-I) := C(I:M,I+1:N)^H * C(I:M,I) [use W = T(:,N)] */ + + i__2 = *n - i__; + for (j = 1; j <= i__2; ++j) { + t[j + *n * t_dim1] = a[i__ + (i__ + j) * a_dim1]; + } + i__2 = *n - i__; + dgemv_("T", &p, &i__2, &c_b5, &b[(i__ + 1) * b_dim1 + 1], ldb, &b[ + i__ * b_dim1 + 1], &c__1, &c_b5, &t[*n * t_dim1 + 1], & + c__1); + +/* C(I:M,I+1:N) = C(I:m,I+1:N) + alpha*C(I:M,I)*W(1:N-1)^H */ + + alpha = -t[i__ + t_dim1]; + i__2 = *n - i__; + for (j = 1; j <= i__2; ++j) { + a[i__ + (i__ + j) * a_dim1] += alpha * t[j + *n * t_dim1]; + } + i__2 = *n - i__; + dger_(&p, &i__2, &alpha, &b[i__ * b_dim1 + 1], &c__1, &t[*n * + t_dim1 + 1], &c__1, &b[(i__ + 1) * b_dim1 + 1], ldb); + } + } + + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + +/* T(1:I-1,I) := C(I:M,1:I-1)^H * (alpha * C(I:M,I)) */ + + alpha = -t[i__ + t_dim1]; + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + t[j + i__ * t_dim1] = 0.; + } +/* Computing MIN */ + i__2 = i__ - 1; + p = f2cmin(i__2,*l); +/* Computing MIN */ + i__2 = *m - *l + 1; + mp = f2cmin(i__2,*m); +/* Computing MIN */ + i__2 = p + 1; + np = f2cmin(i__2,*n); + +/* Triangular part of B2 */ + + i__2 = p; + for (j = 1; j <= i__2; ++j) { + t[j + i__ * t_dim1] = alpha * b[*m - *l + j + i__ * b_dim1]; + } + dtrmv_("U", "T", "N", &p, &b[mp + b_dim1], ldb, &t[i__ * t_dim1 + 1], + &c__1); + +/* Rectangular part of B2 */ + + i__2 = i__ - 1 - p; + dgemv_("T", l, &i__2, &alpha, &b[mp + np * b_dim1], ldb, &b[mp + i__ * + b_dim1], &c__1, &c_b17, &t[np + i__ * t_dim1], &c__1); + +/* B1 */ + + i__2 = *m - *l; + i__3 = i__ - 1; + dgemv_("T", &i__2, &i__3, &alpha, &b[b_offset], ldb, &b[i__ * b_dim1 + + 1], &c__1, &c_b5, &t[i__ * t_dim1 + 1], &c__1); + +/* T(1:I-1,I) := T(1:I-1,1:I-1) * T(1:I-1,I) */ + + i__2 = i__ - 1; + dtrmv_("U", "N", "N", &i__2, &t[t_offset], ldt, &t[i__ * t_dim1 + 1], + &c__1); + +/* T(I,I) = tau(I) */ + + t[i__ + i__ * t_dim1] = t[i__ + t_dim1]; + t[i__ + t_dim1] = 0.; + } + +/* End of DTPQRT2 */ + + return 0; +} /* dtpqrt2_ */ + diff --git a/lapack-netlib/SRC/dtprfb.c b/lapack-netlib/SRC/dtprfb.c new file mode 100644 index 000000000..31aad13ee --- /dev/null +++ b/lapack-netlib/SRC/dtprfb.c @@ -0,0 +1,1355 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTPRFB applies a real or complex "triangular-pentagonal" blocked reflector to a real or complex + matrix, which is composed of two blocks. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTPRFB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTPRFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, */ +/* V, LDV, T, LDT, A, LDA, B, LDB, WORK, LDWORK ) */ + +/* CHARACTER DIRECT, SIDE, STOREV, TRANS */ +/* INTEGER K, L, LDA, LDB, LDT, LDV, LDWORK, M, N */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), T( LDT, * ), */ +/* $ V( LDV, * ), WORK( LDWORK, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTPRFB applies a real "triangular-pentagonal" block reflector H or its */ +/* > transpose H**T to a real matrix C, which is composed of two */ +/* > blocks A and B, either from the left or right. */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'L': apply H or H**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': Columns */ +/* > = 'R': Rows */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix B. */ +/* > M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix B. */ +/* > N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > The order of the matrix T, i.e. the number of elementary */ +/* > reflectors whose product defines the block reflector. */ +/* > K >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] L */ +/* > \verbatim */ +/* > L is INTEGER */ +/* > The order of the trapezoidal part of V. */ +/* > K >= L >= 0. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V */ +/* > \verbatim */ +/* > V is DOUBLE PRECISION array, dimension */ +/* > (LDV,K) if STOREV = 'C' */ +/* > (LDV,M) if STOREV = 'R' and SIDE = 'L' */ +/* > (LDV,N) if STOREV = 'R' and SIDE = 'R' */ +/* > The pentagonal matrix V, which contains the elementary reflectors */ +/* > H(1), H(2), ..., H(K). See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV */ +/* > \verbatim */ +/* > LDV is INTEGER */ +/* > The leading dimension of the array V. */ +/* > If STOREV = 'C' and SIDE = 'L', LDV >= f2cmax(1,M); */ +/* > if STOREV = 'C' and SIDE = 'R', LDV >= f2cmax(1,N); */ +/* > if STOREV = 'R', LDV >= K. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is DOUBLE PRECISION array, dimension (LDT,K) */ +/* > The triangular K-by-K matrix T in the representation of the */ +/* > block reflector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. */ +/* > LDT >= K. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension */ +/* > (LDA,N) if SIDE = 'L' or (LDA,K) if SIDE = 'R' */ +/* > On entry, the K-by-N or M-by-K matrix A. */ +/* > On exit, A is overwritten by the corresponding block of */ +/* > H*C or H**T*C or C*H or C*H**T. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. */ +/* > If SIDE = 'L', LDA >= f2cmax(1,K); */ +/* > If SIDE = 'R', LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,N) */ +/* > On entry, the M-by-N matrix B. */ +/* > On exit, B is overwritten by the corresponding block of */ +/* > H*C or H**T*C or C*H or C*H**T. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. */ +/* > LDB >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension */ +/* > (LDWORK,N) if SIDE = 'L', */ +/* > (LDWORK,K) if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDWORK */ +/* > \verbatim */ +/* > LDWORK is INTEGER */ +/* > The leading dimension of the array WORK. */ +/* > If SIDE = 'L', LDWORK >= K; */ +/* > if SIDE = 'R', LDWORK >= M. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrix C is a composite matrix formed from blocks A and B. */ +/* > The block B is of size M-by-N; if SIDE = 'R', A is of size M-by-K, */ +/* > and if SIDE = 'L', A is of size K-by-N. */ +/* > */ +/* > If SIDE = 'R' and DIRECT = 'F', C = [A B]. */ +/* > */ +/* > If SIDE = 'L' and DIRECT = 'F', C = [A] */ +/* > [B]. */ +/* > */ +/* > If SIDE = 'R' and DIRECT = 'B', C = [B A]. */ +/* > */ +/* > If SIDE = 'L' and DIRECT = 'B', C = [B] */ +/* > [A]. */ +/* > */ +/* > The pentagonal matrix V is composed of a rectangular block V1 and a */ +/* > trapezoidal block V2. The size of the trapezoidal block is determined by */ +/* > the parameter L, where 0<=L<=K. If L=K, the V2 block of V is triangular; */ +/* > if L=0, there is no trapezoidal block, thus V = V1 is rectangular. */ +/* > */ +/* > If DIRECT = 'F' and STOREV = 'C': V = [V1] */ +/* > [V2] */ +/* > - V2 is upper trapezoidal (first L rows of K-by-K upper triangular) */ +/* > */ +/* > If DIRECT = 'F' and STOREV = 'R': V = [V1 V2] */ +/* > */ +/* > - V2 is lower trapezoidal (first L columns of K-by-K lower triangular) */ +/* > */ +/* > If DIRECT = 'B' and STOREV = 'C': V = [V2] */ +/* > [V1] */ +/* > - V2 is lower trapezoidal (last L rows of K-by-K lower triangular) */ +/* > */ +/* > If DIRECT = 'B' and STOREV = 'R': V = [V2 V1] */ +/* > */ +/* > - V2 is upper trapezoidal (last L columns of K-by-K upper triangular) */ +/* > */ +/* > If STOREV = 'C' and SIDE = 'L', V is M-by-K with V2 L-by-K. */ +/* > */ +/* > If STOREV = 'C' and SIDE = 'R', V is N-by-K with V2 L-by-K. */ +/* > */ +/* > If STOREV = 'R' and SIDE = 'L', V is K-by-M with V2 K-by-L. */ +/* > */ +/* > If STOREV = 'R' and SIDE = 'R', V is K-by-N with V2 K-by-L. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtprfb_(char *side, char *trans, char *direct, char * + storev, integer *m, integer *n, integer *k, integer *l, doublereal *v, + integer *ldv, doublereal *t, integer *ldt, doublereal *a, integer * + lda, doublereal *b, integer *ldb, doublereal *work, integer *ldwork) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, t_dim1, t_offset, v_dim1, + v_offset, work_dim1, work_offset, i__1, i__2; + + /* Local variables */ + logical left, backward; + integer i__, j; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + extern logical lsame_(char *, char *); + logical right; + extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + integer kp, mp, np; + logical column, row, forward; + + +/* -- LAPACK auxiliary routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ========================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + v_dim1 = *ldv; + v_offset = 1 + v_dim1 * 1; + v -= v_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + work_dim1 = *ldwork; + work_offset = 1 + work_dim1 * 1; + work -= work_offset; + + /* Function Body */ + if (*m <= 0 || *n <= 0 || *k <= 0 || *l < 0) { + return 0; + } + + if (lsame_(storev, "C")) { + column = TRUE_; + row = FALSE_; + } else if (lsame_(storev, "R")) { + column = FALSE_; + row = TRUE_; + } else { + column = FALSE_; + row = FALSE_; + } + + if (lsame_(side, "L")) { + left = TRUE_; + right = FALSE_; + } else if (lsame_(side, "R")) { + left = FALSE_; + right = TRUE_; + } else { + left = FALSE_; + right = FALSE_; + } + + if (lsame_(direct, "F")) { + forward = TRUE_; + backward = FALSE_; + } else if (lsame_(direct, "B")) { + forward = FALSE_; + backward = TRUE_; + } else { + forward = FALSE_; + backward = FALSE_; + } + +/* --------------------------------------------------------------------------- */ + + if (column && forward && left) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ I ] (K-by-K) */ +/* [ V ] (M-by-K) */ + +/* Form H C or H**T C where C = [ A ] (K-by-N) */ +/* [ B ] (M-by-N) */ + +/* H = I - W T W**T or H**T = I - W T**T W**T */ + +/* A = A - T (A + V**T B) or A = A - T**T (A + V**T B) */ +/* B = B - V T (A + V**T B) or B = B - V T**T (A + V**T B) */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *m - *l + 1; + mp = f2cmin(i__1,*m); +/* Computing MIN */ + i__1 = *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] = b[*m - *l + i__ + j * b_dim1]; + } + } + dtrmm_("L", "U", "T", "N", l, n, &c_b12, &v[mp + v_dim1], ldv, &work[ + work_offset], ldwork); + i__1 = *m - *l; + dgemm_("T", "N", l, n, &i__1, &c_b12, &v[v_offset], ldv, &b[b_offset], + ldb, &c_b12, &work[work_offset], ldwork); + i__1 = *k - *l; + dgemm_("T", "N", &i__1, n, m, &c_b12, &v[kp * v_dim1 + 1], ldv, &b[ + b_offset], ldb, &c_b20, &work[kp + work_dim1], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] += a[i__ + j * a_dim1]; + } + } + + dtrmm_("L", "U", trans, "N", k, n, &c_b12, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] -= work[i__ + j * work_dim1]; + } + } + + i__1 = *m - *l; + dgemm_("N", "N", &i__1, n, k, &c_b27, &v[v_offset], ldv, &work[ + work_offset], ldwork, &c_b12, &b[b_offset], ldb); + i__1 = *k - *l; + dgemm_("N", "N", l, n, &i__1, &c_b27, &v[mp + kp * v_dim1], ldv, & + work[kp + work_dim1], ldwork, &c_b12, &b[mp + b_dim1], ldb); + dtrmm_("L", "U", "N", "N", l, n, &c_b12, &v[mp + v_dim1], ldv, &work[ + work_offset], ldwork); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + b[*m - *l + i__ + j * b_dim1] -= work[i__ + j * work_dim1]; + } + } + +/* --------------------------------------------------------------------------- */ + + } else if (column && forward && right) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ I ] (K-by-K) */ +/* [ V ] (N-by-K) */ + +/* Form C H or C H**T where C = [ A B ] (A is M-by-K, B is M-by-N) */ + +/* H = I - W T W**T or H**T = I - W T**T W**T */ + +/* A = A - (A + B V) T or A = A - (A + B V) T**T */ +/* B = B - (A + B V) T V**T or B = B - (A + B V) T**T V**T */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *n - *l + 1; + np = f2cmin(i__1,*n); +/* Computing MIN */ + i__1 = *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] = b[i__ + (*n - *l + j) * b_dim1]; + } + } + dtrmm_("R", "U", "N", "N", m, l, &c_b12, &v[np + v_dim1], ldv, &work[ + work_offset], ldwork); + i__1 = *n - *l; + dgemm_("N", "N", m, l, &i__1, &c_b12, &b[b_offset], ldb, &v[v_offset], + ldv, &c_b12, &work[work_offset], ldwork); + i__1 = *k - *l; + dgemm_("N", "N", m, &i__1, n, &c_b12, &b[b_offset], ldb, &v[kp * + v_dim1 + 1], ldv, &c_b20, &work[kp * work_dim1 + 1], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] += a[i__ + j * a_dim1]; + } + } + + dtrmm_("R", "U", trans, "N", m, k, &c_b12, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] -= work[i__ + j * work_dim1]; + } + } + + i__1 = *n - *l; + dgemm_("N", "T", m, &i__1, k, &c_b27, &work[work_offset], ldwork, &v[ + v_offset], ldv, &c_b12, &b[b_offset], ldb); + i__1 = *k - *l; + dgemm_("N", "T", m, l, &i__1, &c_b27, &work[kp * work_dim1 + 1], + ldwork, &v[np + kp * v_dim1], ldv, &c_b12, &b[np * b_dim1 + 1] + , ldb); + dtrmm_("R", "U", "T", "N", m, l, &c_b12, &v[np + v_dim1], ldv, &work[ + work_offset], ldwork); + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + (*n - *l + j) * b_dim1] -= work[i__ + j * work_dim1]; + } + } + +/* --------------------------------------------------------------------------- */ + + } else if (column && backward && left) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ V ] (M-by-K) */ +/* [ I ] (K-by-K) */ + +/* Form H C or H**T C where C = [ B ] (M-by-N) */ +/* [ A ] (K-by-N) */ + +/* H = I - W T W**T or H**T = I - W T**T W**T */ + +/* A = A - T (A + V**T B) or A = A - T**T (A + V**T B) */ +/* B = B - V T (A + V**T B) or B = B - V T**T (A + V**T B) */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *l + 1; + mp = f2cmin(i__1,*m); +/* Computing MIN */ + i__1 = *k - *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*k - *l + i__ + j * work_dim1] = b[i__ + j * b_dim1]; + } + } + + dtrmm_("L", "L", "T", "N", l, n, &c_b12, &v[kp * v_dim1 + 1], ldv, & + work[kp + work_dim1], ldwork); + i__1 = *m - *l; + dgemm_("T", "N", l, n, &i__1, &c_b12, &v[mp + kp * v_dim1], ldv, &b[ + mp + b_dim1], ldb, &c_b12, &work[kp + work_dim1], ldwork); + i__1 = *k - *l; + dgemm_("T", "N", &i__1, n, m, &c_b12, &v[v_offset], ldv, &b[b_offset], + ldb, &c_b20, &work[work_offset], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] += a[i__ + j * a_dim1]; + } + } + + dtrmm_("L", "L", trans, "N", k, n, &c_b12, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] -= work[i__ + j * work_dim1]; + } + } + + i__1 = *m - *l; + dgemm_("N", "N", &i__1, n, k, &c_b27, &v[mp + v_dim1], ldv, &work[ + work_offset], ldwork, &c_b12, &b[mp + b_dim1], ldb); + i__1 = *k - *l; + dgemm_("N", "N", l, n, &i__1, &c_b27, &v[v_offset], ldv, &work[ + work_offset], ldwork, &c_b12, &b[b_offset], ldb); + dtrmm_("L", "L", "N", "N", l, n, &c_b12, &v[kp * v_dim1 + 1], ldv, & + work[kp + work_dim1], ldwork); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= work[*k - *l + i__ + j * work_dim1]; + } + } + +/* --------------------------------------------------------------------------- */ + + } else if (column && backward && right) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ V ] (N-by-K) */ +/* [ I ] (K-by-K) */ + +/* Form C H or C H**T where C = [ B A ] (B is M-by-N, A is M-by-K) */ + +/* H = I - W T W**T or H**T = I - W T**T W**T */ + +/* A = A - (A + B V) T or A = A - (A + B V) T**T */ +/* B = B - (A + B V) T V**T or B = B - (A + B V) T**T V**T */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *l + 1; + np = f2cmin(i__1,*n); +/* Computing MIN */ + i__1 = *k - *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + (*k - *l + j) * work_dim1] = b[i__ + j * b_dim1]; + } + } + dtrmm_("R", "L", "N", "N", m, l, &c_b12, &v[kp * v_dim1 + 1], ldv, & + work[kp * work_dim1 + 1], ldwork); + i__1 = *n - *l; + dgemm_("N", "N", m, l, &i__1, &c_b12, &b[np * b_dim1 + 1], ldb, &v[np + + kp * v_dim1], ldv, &c_b12, &work[kp * work_dim1 + 1], + ldwork); + i__1 = *k - *l; + dgemm_("N", "N", m, &i__1, n, &c_b12, &b[b_offset], ldb, &v[v_offset], + ldv, &c_b20, &work[work_offset], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] += a[i__ + j * a_dim1]; + } + } + + dtrmm_("R", "L", trans, "N", m, k, &c_b12, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] -= work[i__ + j * work_dim1]; + } + } + + i__1 = *n - *l; + dgemm_("N", "T", m, &i__1, k, &c_b27, &work[work_offset], ldwork, &v[ + np + v_dim1], ldv, &c_b12, &b[np * b_dim1 + 1], ldb); + i__1 = *k - *l; + dgemm_("N", "T", m, l, &i__1, &c_b27, &work[work_offset], ldwork, &v[ + v_offset], ldv, &c_b12, &b[b_offset], ldb); + dtrmm_("R", "L", "T", "N", m, l, &c_b12, &v[kp * v_dim1 + 1], ldv, & + work[kp * work_dim1 + 1], ldwork); + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= work[i__ + (*k - *l + j) * work_dim1]; + } + } + +/* --------------------------------------------------------------------------- */ + + } else if (row && forward && left) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ I V ] ( I is K-by-K, V is K-by-M ) */ + +/* Form H C or H**T C where C = [ A ] (K-by-N) */ +/* [ B ] (M-by-N) */ + +/* H = I - W**T T W or H**T = I - W**T T**T W */ + +/* A = A - T (A + V B) or A = A - T**T (A + V B) */ +/* B = B - V**T T (A + V B) or B = B - V**T T**T (A + V B) */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *m - *l + 1; + mp = f2cmin(i__1,*m); +/* Computing MIN */ + i__1 = *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] = b[*m - *l + i__ + j * b_dim1]; + } + } + dtrmm_("L", "L", "N", "N", l, n, &c_b12, &v[mp * v_dim1 + 1], ldv, & + work[work_offset], ldb); + i__1 = *m - *l; + dgemm_("N", "N", l, n, &i__1, &c_b12, &v[v_offset], ldv, &b[b_offset], + ldb, &c_b12, &work[work_offset], ldwork); + i__1 = *k - *l; + dgemm_("N", "N", &i__1, n, m, &c_b12, &v[kp + v_dim1], ldv, &b[ + b_offset], ldb, &c_b20, &work[kp + work_dim1], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] += a[i__ + j * a_dim1]; + } + } + + dtrmm_("L", "U", trans, "N", k, n, &c_b12, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] -= work[i__ + j * work_dim1]; + } + } + + i__1 = *m - *l; + dgemm_("T", "N", &i__1, n, k, &c_b27, &v[v_offset], ldv, &work[ + work_offset], ldwork, &c_b12, &b[b_offset], ldb); + i__1 = *k - *l; + dgemm_("T", "N", l, n, &i__1, &c_b27, &v[kp + mp * v_dim1], ldv, & + work[kp + work_dim1], ldwork, &c_b12, &b[mp + b_dim1], ldb); + dtrmm_("L", "L", "T", "N", l, n, &c_b12, &v[mp * v_dim1 + 1], ldv, & + work[work_offset], ldwork); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + b[*m - *l + i__ + j * b_dim1] -= work[i__ + j * work_dim1]; + } + } + +/* --------------------------------------------------------------------------- */ + + } else if (row && forward && right) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ I V ] ( I is K-by-K, V is K-by-N ) */ + +/* Form C H or C H**T where C = [ A B ] (A is M-by-K, B is M-by-N) */ + +/* H = I - W**T T W or H**T = I - W**T T**T W */ + +/* A = A - (A + B V**T) T or A = A - (A + B V**T) T**T */ +/* B = B - (A + B V**T) T V or B = B - (A + B V**T) T**T V */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *n - *l + 1; + np = f2cmin(i__1,*n); +/* Computing MIN */ + i__1 = *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] = b[i__ + (*n - *l + j) * b_dim1]; + } + } + dtrmm_("R", "L", "T", "N", m, l, &c_b12, &v[np * v_dim1 + 1], ldv, & + work[work_offset], ldwork); + i__1 = *n - *l; + dgemm_("N", "T", m, l, &i__1, &c_b12, &b[b_offset], ldb, &v[v_offset], + ldv, &c_b12, &work[work_offset], ldwork); + i__1 = *k - *l; + dgemm_("N", "T", m, &i__1, n, &c_b12, &b[b_offset], ldb, &v[kp + + v_dim1], ldv, &c_b20, &work[kp * work_dim1 + 1], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] += a[i__ + j * a_dim1]; + } + } + + dtrmm_("R", "U", trans, "N", m, k, &c_b12, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] -= work[i__ + j * work_dim1]; + } + } + + i__1 = *n - *l; + dgemm_("N", "N", m, &i__1, k, &c_b27, &work[work_offset], ldwork, &v[ + v_offset], ldv, &c_b12, &b[b_offset], ldb); + i__1 = *k - *l; + dgemm_("N", "N", m, l, &i__1, &c_b27, &work[kp * work_dim1 + 1], + ldwork, &v[kp + np * v_dim1], ldv, &c_b12, &b[np * b_dim1 + 1] + , ldb); + dtrmm_("R", "L", "N", "N", m, l, &c_b12, &v[np * v_dim1 + 1], ldv, & + work[work_offset], ldwork); + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + (*n - *l + j) * b_dim1] -= work[i__ + j * work_dim1]; + } + } + +/* --------------------------------------------------------------------------- */ + + } else if (row && backward && left) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ V I ] ( I is K-by-K, V is K-by-M ) */ + +/* Form H C or H**T C where C = [ B ] (M-by-N) */ +/* [ A ] (K-by-N) */ + +/* H = I - W**T T W or H**T = I - W**T T**T W */ + +/* A = A - T (A + V B) or A = A - T**T (A + V B) */ +/* B = B - V**T T (A + V B) or B = B - V**T T**T (A + V B) */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *l + 1; + mp = f2cmin(i__1,*m); +/* Computing MIN */ + i__1 = *k - *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*k - *l + i__ + j * work_dim1] = b[i__ + j * b_dim1]; + } + } + dtrmm_("L", "U", "N", "N", l, n, &c_b12, &v[kp + v_dim1], ldv, &work[ + kp + work_dim1], ldwork); + i__1 = *m - *l; + dgemm_("N", "N", l, n, &i__1, &c_b12, &v[kp + mp * v_dim1], ldv, &b[ + mp + b_dim1], ldb, &c_b12, &work[kp + work_dim1], ldwork); + i__1 = *k - *l; + dgemm_("N", "N", &i__1, n, m, &c_b12, &v[v_offset], ldv, &b[b_offset], + ldb, &c_b20, &work[work_offset], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] += a[i__ + j * a_dim1]; + } + } + + dtrmm_("L", "L ", trans, "N", k, n, &c_b12, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] -= work[i__ + j * work_dim1]; + } + } + + i__1 = *m - *l; + dgemm_("T", "N", &i__1, n, k, &c_b27, &v[mp * v_dim1 + 1], ldv, &work[ + work_offset], ldwork, &c_b12, &b[mp + b_dim1], ldb); + i__1 = *k - *l; + dgemm_("T", "N", l, n, &i__1, &c_b27, &v[v_offset], ldv, &work[ + work_offset], ldwork, &c_b12, &b[b_offset], ldb); + dtrmm_("L", "U", "T", "N", l, n, &c_b12, &v[kp + v_dim1], ldv, &work[ + kp + work_dim1], ldwork); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *l; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= work[*k - *l + i__ + j * work_dim1]; + } + } + +/* --------------------------------------------------------------------------- */ + + } else if (row && backward && right) { + +/* --------------------------------------------------------------------------- */ + +/* Let W = [ V I ] ( I is K-by-K, V is K-by-N ) */ + +/* Form C H or C H**T where C = [ B A ] (A is M-by-K, B is M-by-N) */ + +/* H = I - W**T T W or H**T = I - W**T T**T W */ + +/* A = A - (A + B V**T) T or A = A - (A + B V**T) T**T */ +/* B = B - (A + B V**T) T V or B = B - (A + B V**T) T**T V */ + +/* --------------------------------------------------------------------------- */ + +/* Computing MIN */ + i__1 = *l + 1; + np = f2cmin(i__1,*n); +/* Computing MIN */ + i__1 = *k - *l + 1; + kp = f2cmin(i__1,*k); + + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + (*k - *l + j) * work_dim1] = b[i__ + j * b_dim1]; + } + } + dtrmm_("R", "U", "T", "N", m, l, &c_b12, &v[kp + v_dim1], ldv, &work[ + kp * work_dim1 + 1], ldwork); + i__1 = *n - *l; + dgemm_("N", "T", m, l, &i__1, &c_b12, &b[np * b_dim1 + 1], ldb, &v[kp + + np * v_dim1], ldv, &c_b12, &work[kp * work_dim1 + 1], + ldwork); + i__1 = *k - *l; + dgemm_("N", "T", m, &i__1, n, &c_b12, &b[b_offset], ldb, &v[v_offset], + ldv, &c_b20, &work[work_offset], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__ + j * work_dim1] += a[i__ + j * a_dim1]; + } + } + + dtrmm_("R", "L", trans, "N", m, k, &c_b12, &t[t_offset], ldt, &work[ + work_offset], ldwork); + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + a[i__ + j * a_dim1] -= work[i__ + j * work_dim1]; + } + } + + i__1 = *n - *l; + dgemm_("N", "N", m, &i__1, k, &c_b27, &work[work_offset], ldwork, &v[ + np * v_dim1 + 1], ldv, &c_b12, &b[np * b_dim1 + 1], ldb); + i__1 = *k - *l; + dgemm_("N", "N", m, l, &i__1, &c_b27, &work[work_offset], ldwork, &v[ + v_offset], ldv, &c_b12, &b[b_offset], ldb); + dtrmm_("R", "U", "N", "N", m, l, &c_b12, &v[kp + v_dim1], ldv, &work[ + kp * work_dim1 + 1], ldwork); + i__1 = *l; + for (j = 1; j <= i__1; ++j) { + i__2 = *m; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] -= work[i__ + (*k - *l + j) * work_dim1]; + } + } + + } + + return 0; + +/* End of DTPRFB */ + +} /* dtprfb_ */ + diff --git a/lapack-netlib/SRC/dtprfs.c b/lapack-netlib/SRC/dtprfs.c new file mode 100644 index 000000000..3723933cf --- /dev/null +++ b/lapack-netlib/SRC/dtprfs.c @@ -0,0 +1,945 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTPRFS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTPRFS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX, */ +/* FERR, BERR, WORK, IWORK, INFO ) */ + +/* CHARACTER DIAG, TRANS, UPLO */ +/* INTEGER INFO, LDB, LDX, N, NRHS */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION AP( * ), B( LDB, * ), BERR( * ), FERR( * ), */ +/* $ WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTPRFS provides error bounds and backward error estimates for the */ +/* > solution to a system of linear equations with a triangular packed */ +/* > coefficient matrix. */ +/* > */ +/* > The solution matrix X must be computed by DTPTRS or some other */ +/* > means before entering this routine. DTPRFS does not do iterative */ +/* > refinement because doing so cannot improve the backward error. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > The upper or lower triangular matrix A, packed columnwise in */ +/* > a linear array. The j-th column of A is stored in the array */ +/* > AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* > If DIAG = 'U', the diagonal elements of A are not referenced */ +/* > and are assumed to be 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > The right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* > The solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dtprfs_(char *uplo, char *trans, char *diag, integer *n, + integer *nrhs, doublereal *ap, doublereal *b, integer *ldb, + doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, + doublereal *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, i__3; + doublereal d__1, d__2, d__3; + + /* Local variables */ + integer kase; + doublereal safe1, safe2; + integer i__, j, k; + doublereal s; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), daxpy_(integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *), dtpmv_(char *, + char *, char *, integer *, doublereal *, doublereal *, integer *); + logical upper; + extern /* Subroutine */ int dtpsv_(char *, char *, char *, integer *, + doublereal *, doublereal *, integer *), + dlacn2_(integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, integer *); + integer kc; + extern doublereal dlamch_(char *); + doublereal xk; + integer nz; + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical notran; + char transt[1]; + logical nounit; + doublereal lstres, eps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + notran = lsame_(trans, "N"); + nounit = lsame_(diag, "N"); + + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else if (*ldx < f2cmax(1,*n)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTPRFS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.; + berr[j] = 0.; +/* L10: */ + } + return 0; + } + + if (notran) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = *n + 1; + eps = dlamch_("Epsilon"); + safmin = dlamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Compute residual R = B - op(A) * X, */ +/* where op(A) = A or A**T, depending on TRANS. */ + + dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1); + dtpmv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1); + daxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* f2cmax(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); +/* L20: */ + } + + if (notran) { + +/* Compute abs(A)*abs(X) + abs(B). */ + + if (upper) { + kc = 1; + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = k; + for (i__ = 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = ap[kc + i__ - 1], abs(d__1)) + * xk; +/* L30: */ + } + kc += k; +/* L40: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = ap[kc + i__ - 1], abs(d__1)) + * xk; +/* L50: */ + } + work[k] += xk; + kc += k; +/* L60: */ + } + } + } else { + kc = 1; + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = *n; + for (i__ = k; i__ <= i__3; ++i__) { + work[i__] += (d__1 = ap[kc + i__ - k], abs(d__1)) + * xk; +/* L70: */ + } + kc = kc + *n - k + 1; +/* L80: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = ap[kc + i__ - k], abs(d__1)) + * xk; +/* L90: */ + } + work[k] += xk; + kc = kc + *n - k + 1; +/* L100: */ + } + } + } + } else { + +/* Compute abs(A**T)*abs(X) + abs(B). */ + + if (upper) { + kc = 1; + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + i__3 = k; + for (i__ = 1; i__ <= i__3; ++i__) { + s += (d__1 = ap[kc + i__ - 1], abs(d__1)) * (d__2 + = x[i__ + j * x_dim1], abs(d__2)); +/* L110: */ + } + work[k] += s; + kc += k; +/* L120: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + s += (d__1 = ap[kc + i__ - 1], abs(d__1)) * (d__2 + = x[i__ + j * x_dim1], abs(d__2)); +/* L130: */ + } + work[k] += s; + kc += k; +/* L140: */ + } + } + } else { + kc = 1; + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + i__3 = *n; + for (i__ = k; i__ <= i__3; ++i__) { + s += (d__1 = ap[kc + i__ - k], abs(d__1)) * (d__2 + = x[i__ + j * x_dim1], abs(d__2)); +/* L150: */ + } + work[k] += s; + kc = kc + *n - k + 1; +/* L160: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + s += (d__1 = ap[kc + i__ - k], abs(d__1)) * (d__2 + = x[i__ + j * x_dim1], abs(d__2)); +/* L170: */ + } + work[k] += s; + kc = kc + *n - k + 1; +/* L180: */ + } + } + } + } + s = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ + i__]; + s = f2cmax(d__2,d__3); + } else { +/* Computing MAX */ + d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) + / (work[i__] + safe1); + s = f2cmax(d__2,d__3); + } +/* L190: */ + } + berr[j] = s; + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(op(A)))* */ +/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(op(A)) is the inverse of op(A) */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ + +/* Use DLACN2 to estimate the infinity-norm of the matrix */ +/* inv(op(A)) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__] + safe1; + } +/* L200: */ + } + + kase = 0; +L210: + dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & + kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(op(A)**T). */ + + dtpsv_(uplo, transt, diag, n, &ap[1], &work[*n + 1], &c__1); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L220: */ + } + } else { + +/* Multiply by inv(op(A))*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L230: */ + } + dtpsv_(uplo, trans, diag, n, &ap[1], &work[*n + 1], &c__1); + } + goto L210; + } + +/* Normalize error. */ + + lstres = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); + lstres = f2cmax(d__2,d__3); +/* L240: */ + } + if (lstres != 0.) { + ferr[j] /= lstres; + } + +/* L250: */ + } + + return 0; + +/* End of DTPRFS */ + +} /* dtprfs_ */ + diff --git a/lapack-netlib/SRC/dtptri.c b/lapack-netlib/SRC/dtptri.c new file mode 100644 index 000000000..786f2ec42 --- /dev/null +++ b/lapack-netlib/SRC/dtptri.c @@ -0,0 +1,646 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTPTRI */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTPTRI + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO ) */ + +/* CHARACTER DIAG, UPLO */ +/* INTEGER INFO, N */ +/* DOUBLE PRECISION AP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTPTRI computes the inverse of a real upper or lower triangular */ +/* > matrix A stored in packed format. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangular matrix A, stored */ +/* > columnwise in a linear array. The j-th column of A is stored */ +/* > in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* > See below for further details. */ +/* > On exit, the (triangular) inverse of the original matrix, in */ +/* > the same packed storage format. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, A(i,i) is exactly zero. The triangular */ +/* > matrix is singular and its inverse can not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > A triangular matrix A can be transferred to packed storage using one */ +/* > of the following program segments: */ +/* > */ +/* > UPLO = 'U': UPLO = 'L': */ +/* > */ +/* > JC = 1 JC = 1 */ +/* > DO 2 J = 1, N DO 2 J = 1, N */ +/* > DO 1 I = 1, J DO 1 I = J, N */ +/* > AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J) */ +/* > 1 CONTINUE 1 CONTINUE */ +/* > JC = JC + J JC = JC + N - J + 1 */ +/* > 2 CONTINUE 2 CONTINUE */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtptri_(char *uplo, char *diag, integer *n, doublereal * + ap, integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer j; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dtpmv_(char *, char *, char *, integer *, + doublereal *, doublereal *, integer *); + logical upper; + integer jc, jj; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + integer jclast; + logical nounit; + doublereal ajj; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + nounit = lsame_(diag, "N"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTPTRI", &i__1, (ftnlen)6); + return 0; + } + +/* Check for singularity if non-unit. */ + + if (nounit) { + if (upper) { + jj = 0; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + jj += *info; + if (ap[jj] == 0.) { + return 0; + } +/* L10: */ + } + } else { + jj = 1; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (ap[jj] == 0.) { + return 0; + } + jj = jj + *n - *info + 1; +/* L20: */ + } + } + *info = 0; + } + + if (upper) { + +/* Compute inverse of upper triangular matrix. */ + + jc = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (nounit) { + ap[jc + j - 1] = 1. / ap[jc + j - 1]; + ajj = -ap[jc + j - 1]; + } else { + ajj = -1.; + } + +/* Compute elements 1:j-1 of j-th column. */ + + i__2 = j - 1; + dtpmv_("Upper", "No transpose", diag, &i__2, &ap[1], &ap[jc], & + c__1); + i__2 = j - 1; + dscal_(&i__2, &ajj, &ap[jc], &c__1); + jc += j; +/* L30: */ + } + + } else { + +/* Compute inverse of lower triangular matrix. */ + + jc = *n * (*n + 1) / 2; + for (j = *n; j >= 1; --j) { + if (nounit) { + ap[jc] = 1. / ap[jc]; + ajj = -ap[jc]; + } else { + ajj = -1.; + } + if (j < *n) { + +/* Compute elements j+1:n of j-th column. */ + + i__1 = *n - j; + dtpmv_("Lower", "No transpose", diag, &i__1, &ap[jclast], &ap[ + jc + 1], &c__1); + i__1 = *n - j; + dscal_(&i__1, &ajj, &ap[jc + 1], &c__1); + } + jclast = jc; + jc = jc - *n + j - 2; +/* L40: */ + } + } + + return 0; + +/* End of DTPTRI */ + +} /* dtptri_ */ + diff --git a/lapack-netlib/SRC/dtptrs.c b/lapack-netlib/SRC/dtptrs.c new file mode 100644 index 000000000..45a20e0d3 --- /dev/null +++ b/lapack-netlib/SRC/dtptrs.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 DTPTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTPTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO ) */ + +/* CHARACTER DIAG, TRANS, UPLO */ +/* INTEGER INFO, LDB, N, NRHS */ +/* DOUBLE PRECISION AP( * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTPTRS solves a triangular system of the form */ +/* > */ +/* > A * X = B or A**T * X = B, */ +/* > */ +/* > where A is a triangular matrix of order N stored in packed format, */ +/* > and B is an N-by-NRHS matrix. A check is made to verify that A is */ +/* > nonsingular. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > The upper or lower triangular matrix A, packed columnwise in */ +/* > a linear array. The j-th column of A is stored in the array */ +/* > AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, if INFO = 0, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the i-th diagonal element of A is zero, */ +/* > indicating that the matrix is singular and the */ +/* > solutions X have not been computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dtptrs_(char *uplo, char *trans, char *diag, integer *n, + integer *nrhs, doublereal *ap, doublereal *b, integer *ldb, integer * + info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1; + + /* Local variables */ + integer j; + extern logical lsame_(char *, char *); + logical upper; + extern /* Subroutine */ int dtpsv_(char *, char *, char *, integer *, + doublereal *, doublereal *, integer *); + integer jc; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical nounit; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + nounit = lsame_(diag, "N"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTPTRS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check for singularity. */ + + if (nounit) { + if (upper) { + jc = 1; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (ap[jc + *info - 1] == 0.) { + return 0; + } + jc += *info; +/* L10: */ + } + } else { + jc = 1; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (ap[jc] == 0.) { + return 0; + } + jc = jc + *n - *info + 1; +/* L20: */ + } + } + } + *info = 0; + +/* Solve A * x = b or A**T * x = b. */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + dtpsv_(uplo, trans, diag, n, &ap[1], &b[j * b_dim1 + 1], &c__1); +/* L30: */ + } + + return 0; + +/* End of DTPTRS */ + +} /* dtptrs_ */ + diff --git a/lapack-netlib/SRC/dtpttf.c b/lapack-netlib/SRC/dtpttf.c new file mode 100644 index 000000000..3340079d8 --- /dev/null +++ b/lapack-netlib/SRC/dtpttf.c @@ -0,0 +1,925 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTPTTF copies a triangular matrix from the standard packed format (TP) to the rectangular full +packed format (TF). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTPTTF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTPTTF( TRANSR, UPLO, N, AP, ARF, INFO ) */ + +/* CHARACTER TRANSR, UPLO */ +/* INTEGER INFO, N */ +/* DOUBLE PRECISION AP( 0: * ), ARF( 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTPTTF copies a triangular matrix A from standard packed format (TP) */ +/* > to rectangular full packed format (TF). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER*1 */ +/* > = 'N': ARF in Normal format is wanted; */ +/* > = 'T': ARF in Conjugate-transpose format is wanted. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */ +/* > On entry, the upper or lower triangular matrix A, packed */ +/* > columnwise in a linear array. The j-th column of A is stored */ +/* > in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ARF */ +/* > \verbatim */ +/* > ARF is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */ +/* > On exit, the upper or lower triangular matrix A stored in */ +/* > RFP format. For a further discussion see Notes below. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > We first consider Rectangular Full Packed (RFP) Format when N is */ +/* > even. We give an example where N = 6. */ +/* > */ +/* > AP is Upper AP is Lower */ +/* > */ +/* > 00 01 02 03 04 05 00 */ +/* > 11 12 13 14 15 10 11 */ +/* > 22 23 24 25 20 21 22 */ +/* > 33 34 35 30 31 32 33 */ +/* > 44 45 40 41 42 43 44 */ +/* > 55 50 51 52 53 54 55 */ +/* > */ +/* > */ +/* > Let TRANSR = 'N'. RFP holds AP as follows: */ +/* > For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ +/* > three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ +/* > the transpose of the first three columns of AP upper. */ +/* > For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ +/* > three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ +/* > the transpose of the last three columns of AP lower. */ +/* > This covers the case N even and TRANSR = 'N'. */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 03 04 05 33 43 53 */ +/* > 13 14 15 00 44 54 */ +/* > 23 24 25 10 11 55 */ +/* > 33 34 35 20 21 22 */ +/* > 00 44 45 30 31 32 */ +/* > 01 11 55 40 41 42 */ +/* > 02 12 22 50 51 52 */ +/* > */ +/* > Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* > transpose of RFP A above. One therefore gets: */ +/* > */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ +/* > 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ +/* > 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ +/* > */ +/* > */ +/* > We then consider Rectangular Full Packed (RFP) Format when N is */ +/* > odd. We give an example where N = 5. */ +/* > */ +/* > AP is Upper AP is Lower */ +/* > */ +/* > 00 01 02 03 04 00 */ +/* > 11 12 13 14 10 11 */ +/* > 22 23 24 20 21 22 */ +/* > 33 34 30 31 32 33 */ +/* > 44 40 41 42 43 44 */ +/* > */ +/* > */ +/* > Let TRANSR = 'N'. RFP holds AP as follows: */ +/* > For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ +/* > three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ +/* > the transpose of the first two columns of AP upper. */ +/* > For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ +/* > three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ +/* > the transpose of the last two columns of AP lower. */ +/* > This covers the case N odd and TRANSR = 'N'. */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 02 03 04 00 33 43 */ +/* > 12 13 14 10 11 44 */ +/* > 22 23 24 20 21 22 */ +/* > 00 33 34 30 31 32 */ +/* > 01 11 44 40 41 42 */ +/* > */ +/* > Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* > transpose of RFP A above. One therefore gets: */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 02 12 22 00 01 00 10 20 30 40 50 */ +/* > 03 13 23 33 11 33 11 21 31 41 51 */ +/* > 04 14 24 34 44 43 44 22 32 42 52 */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtpttf_(char *transr, char *uplo, integer *n, doublereal + *ap, doublereal *arf, integer *info) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + + /* Local variables */ + integer i__, j, k; + logical normaltransr; + extern logical lsame_(char *, char *); + logical lower; + integer n1, n2, ij, jp, js, nt; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical nisodd; + integer lda, ijp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + *info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + if (! normaltransr && ! lsame_(transr, "T")) { + *info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTPTTF", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (normaltransr) { + arf[0] = ap[0]; + } else { + arf[0] = ap[0]; + } + return 0; + } + +/* Size of array ARF(0:NT-1) */ + + nt = *n * (*n + 1) / 2; + +/* Set N1 and N2 depending on LOWER */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + +/* If N is odd, set NISODD = .TRUE. */ +/* If N is even, set K = N/2 and NISODD = .FALSE. */ + +/* set lda of ARF^C; ARF^C is (0:(N+1)/2-1,0:N-noe) */ +/* where noe = 0 if n is even, noe = 1 if n is odd */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = FALSE_; + lda = *n + 1; + } else { + nisodd = TRUE_; + lda = *n; + } + +/* ARF^C has lda rows and n+1-noe cols */ + + if (! normaltransr) { + lda = (*n + 1) / 2; + } + +/* start execution: there are eight cases */ + + if (nisodd) { + +/* N is odd */ + + if (normaltransr) { + +/* N is odd and TRANSR = 'N' */ + + if (lower) { + +/* N is odd, TRANSR = 'N', and UPLO = 'L' */ + + ijp = 0; + jp = 0; + i__1 = n2; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + ij = i__ + jp; + arf[ij] = ap[ijp]; + ++ijp; + } + jp += lda; + } + i__1 = n2 - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = n2; + for (j = i__ + 1; j <= i__2; ++j) { + ij = i__ + j * lda; + arf[ij] = ap[ijp]; + ++ijp; + } + } + + } else { + +/* N is odd, TRANSR = 'N', and UPLO = 'U' */ + + ijp = 0; + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + ij = n2 + j; + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = ap[ijp]; + ++ijp; + ij += lda; + } + } + js = 0; + i__1 = *n - 1; + for (j = n1; j <= i__1; ++j) { + ij = js; + i__2 = js + j; + for (ij = js; ij <= i__2; ++ij) { + arf[ij] = ap[ijp]; + ++ijp; + } + js += lda; + } + + } + + } else { + +/* N is odd and TRANSR = 'T' */ + + if (lower) { + +/* N is odd, TRANSR = 'T', and UPLO = 'L' */ + + ijp = 0; + i__1 = n2; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = *n * lda - 1; + i__3 = lda; + for (ij = i__ * (lda + 1); i__3 < 0 ? ij >= i__2 : ij <= + i__2; ij += i__3) { + arf[ij] = ap[ijp]; + ++ijp; + } + } + js = 1; + i__1 = n2 - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + n2 - j - 1; + for (ij = js; ij <= i__3; ++ij) { + arf[ij] = ap[ijp]; + ++ijp; + } + js = js + lda + 1; + } + + } else { + +/* N is odd, TRANSR = 'T', and UPLO = 'U' */ + + ijp = 0; + js = n2 * lda; + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + j; + for (ij = js; ij <= i__3; ++ij) { + arf[ij] = ap[ijp]; + ++ijp; + } + js += lda; + } + i__1 = n1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__3 = i__ + (n1 + i__) * lda; + i__2 = lda; + for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij += + i__2) { + arf[ij] = ap[ijp]; + ++ijp; + } + } + + } + + } + + } else { + +/* N is even */ + + if (normaltransr) { + +/* N is even and TRANSR = 'N' */ + + if (lower) { + +/* N is even, TRANSR = 'N', and UPLO = 'L' */ + + ijp = 0; + jp = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + ij = i__ + 1 + jp; + arf[ij] = ap[ijp]; + ++ijp; + } + jp += lda; + } + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = k - 1; + for (j = i__; j <= i__2; ++j) { + ij = i__ + j * lda; + arf[ij] = ap[ijp]; + ++ijp; + } + } + + } else { + +/* N is even, TRANSR = 'N', and UPLO = 'U' */ + + ijp = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + ij = k + 1 + j; + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = ap[ijp]; + ++ijp; + ij += lda; + } + } + js = 0; + i__1 = *n - 1; + for (j = k; j <= i__1; ++j) { + ij = js; + i__2 = js + j; + for (ij = js; ij <= i__2; ++ij) { + arf[ij] = ap[ijp]; + ++ijp; + } + js += lda; + } + + } + + } else { + +/* N is even and TRANSR = 'T' */ + + if (lower) { + +/* N is even, TRANSR = 'T', and UPLO = 'L' */ + + ijp = 0; + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__2 = (*n + 1) * lda - 1; + i__3 = lda; + for (ij = i__ + (i__ + 1) * lda; i__3 < 0 ? ij >= i__2 : + ij <= i__2; ij += i__3) { + arf[ij] = ap[ijp]; + ++ijp; + } + } + js = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + k - j - 1; + for (ij = js; ij <= i__3; ++ij) { + arf[ij] = ap[ijp]; + ++ijp; + } + js = js + lda + 1; + } + + } else { + +/* N is even, TRANSR = 'T', and UPLO = 'U' */ + + ijp = 0; + js = (k + 1) * lda; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__3 = js + j; + for (ij = js; ij <= i__3; ++ij) { + arf[ij] = ap[ijp]; + ++ijp; + } + js += lda; + } + i__1 = k - 1; + for (i__ = 0; i__ <= i__1; ++i__) { + i__3 = i__ + (k + i__) * lda; + i__2 = lda; + for (ij = i__; i__2 < 0 ? ij >= i__3 : ij <= i__3; ij += + i__2) { + arf[ij] = ap[ijp]; + ++ijp; + } + } + + } + + } + + } + + return 0; + +/* End of DTPTTF */ + +} /* dtpttf_ */ + diff --git a/lapack-netlib/SRC/dtpttr.c b/lapack-netlib/SRC/dtpttr.c new file mode 100644 index 000000000..9f0d2cd71 --- /dev/null +++ b/lapack-netlib/SRC/dtpttr.c @@ -0,0 +1,567 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTPTTR copies a triangular matrix from the standard packed format (TP) to the standard full for +mat (TR). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTPTTR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTPTTR( UPLO, N, AP, A, LDA, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N, LDA */ +/* DOUBLE PRECISION A( LDA, * ), AP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTPTTR copies a triangular matrix A from standard packed format (TP) */ +/* > to standard full format (TR). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular. */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is DOUBLE PRECISION array, dimension ( N*(N+1)/2 ), */ +/* > On entry, the upper or lower triangular matrix A, packed */ +/* > columnwise in a linear array. The j-th column of A is stored */ +/* > in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension ( LDA, N ) */ +/* > On exit, the triangular matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dtpttr_(char *uplo, integer *n, doublereal *ap, + doublereal *a, integer *lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, k; + extern logical lsame_(char *, char *); + logical lower; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + *info = 0; + lower = lsame_(uplo, "L"); + if (! lower && ! lsame_(uplo, "U")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTPTTR", &i__1, (ftnlen)6); + return 0; + } + + if (lower) { + k = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + ++k; + a[i__ + j * a_dim1] = ap[k]; + } + } + } else { + k = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ++k; + a[i__ + j * a_dim1] = ap[k]; + } + } + } + + + return 0; + +/* End of DTPTTR */ + +} /* dtpttr_ */ + diff --git a/lapack-netlib/SRC/dtrcon.c b/lapack-netlib/SRC/dtrcon.c new file mode 100644 index 000000000..daa6d3a73 --- /dev/null +++ b/lapack-netlib/SRC/dtrcon.c @@ -0,0 +1,677 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTRCON */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTRCON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK, */ +/* IWORK, INFO ) */ + +/* CHARACTER DIAG, NORM, UPLO */ +/* INTEGER INFO, LDA, N */ +/* DOUBLE PRECISION RCOND */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTRCON estimates the reciprocal of the condition number of a */ +/* > triangular matrix A, in either the 1-norm or the infinity-norm. */ +/* > */ +/* > The norm of A is computed and an estimate is obtained for */ +/* > norm(inv(A)), then the reciprocal of the condition number is */ +/* > computed as */ +/* > RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies whether the 1-norm condition number or the */ +/* > infinity-norm condition number is required: */ +/* > = '1' or 'O': 1-norm; */ +/* > = 'I': Infinity-norm. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > The triangular matrix A. If UPLO = 'U', the leading N-by-N */ +/* > upper triangular part of the array A contains the upper */ +/* > triangular matrix, and the strictly lower triangular part of */ +/* > A is not referenced. If UPLO = 'L', the leading N-by-N lower */ +/* > triangular part of the array A contains the lower triangular */ +/* > matrix, and the strictly upper triangular part of A is not */ +/* > referenced. If DIAG = 'U', the diagonal elements of A are */ +/* > also not referenced and are assumed to be 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > The reciprocal of the condition number of the matrix A, */ +/* > computed as RCOND = 1/(norm(A) * norm(inv(A))). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dtrcon_(char *norm, char *uplo, char *diag, integer *n, + doublereal *a, integer *lda, doublereal *rcond, doublereal *work, + integer *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + doublereal d__1; + + /* Local variables */ + integer kase, kase1; + doublereal scale; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int drscl_(integer *, doublereal *, doublereal *, + integer *); + doublereal anorm; + logical upper; + doublereal xnorm; + extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + extern doublereal dlamch_(char *); + integer ix; + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern doublereal dlantr_(char *, char *, char *, integer *, integer *, + doublereal *, integer *, doublereal *); + doublereal ainvnm; + extern /* Subroutine */ int dlatrs_(char *, char *, char *, char *, + integer *, doublereal *, integer *, doublereal *, doublereal *, + doublereal *, integer *); + logical onenrm; + char normin[1]; + doublereal smlnum; + logical nounit; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); + nounit = lsame_(diag, "N"); + + if (! onenrm && ! lsame_(norm, "I")) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTRCON", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + *rcond = 1.; + return 0; + } + + *rcond = 0.; + smlnum = dlamch_("Safe minimum") * (doublereal) f2cmax(1,*n); + +/* Compute the norm of the triangular matrix A. */ + + anorm = dlantr_(norm, uplo, diag, n, n, &a[a_offset], lda, &work[1]); + +/* Continue only if ANORM > 0. */ + + if (anorm > 0.) { + +/* Estimate the norm of the inverse of A. */ + + ainvnm = 0.; + *(unsigned char *)normin = 'N'; + if (onenrm) { + kase1 = 1; + } else { + kase1 = 2; + } + kase = 0; +L10: + dlacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == kase1) { + +/* Multiply by inv(A). */ + + dlatrs_(uplo, "No transpose", diag, normin, n, &a[a_offset], + lda, &work[1], &scale, &work[(*n << 1) + 1], info); + } else { + +/* Multiply by inv(A**T). */ + + dlatrs_(uplo, "Transpose", diag, normin, n, &a[a_offset], lda, + &work[1], &scale, &work[(*n << 1) + 1], info); + } + *(unsigned char *)normin = 'Y'; + +/* Multiply by 1/SCALE if doing so will not cause overflow. */ + + if (scale != 1.) { + ix = idamax_(n, &work[1], &c__1); + xnorm = (d__1 = work[ix], abs(d__1)); + if (scale < xnorm * smlnum || scale == 0.) { + goto L20; + } + drscl_(n, &scale, &work[1], &c__1); + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + *rcond = 1. / anorm / ainvnm; + } + } + +L20: + return 0; + +/* End of DTRCON */ + +} /* dtrcon_ */ + diff --git a/lapack-netlib/SRC/dtrevc.c b/lapack-netlib/SRC/dtrevc.c new file mode 100644 index 000000000..6329ab8a1 --- /dev/null +++ b/lapack-netlib/SRC/dtrevc.c @@ -0,0 +1,1679 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTREVC */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTREVC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, */ +/* LDVR, MM, M, WORK, INFO ) */ + +/* CHARACTER HOWMNY, SIDE */ +/* INTEGER INFO, LDT, LDVL, LDVR, M, MM, N */ +/* LOGICAL SELECT( * ) */ +/* DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTREVC computes some or all of the right and/or left eigenvectors of */ +/* > a real upper quasi-triangular matrix T. */ +/* > Matrices of this type are produced by the Schur factorization of */ +/* > a real general matrix: A = Q*T*Q**T, as computed by DHSEQR. */ +/* > */ +/* > The right eigenvector x and the left eigenvector y of T corresponding */ +/* > to an eigenvalue w are defined by: */ +/* > */ +/* > T*x = w*x, (y**H)*T = w*(y**H) */ +/* > */ +/* > where y**H denotes the conjugate transpose of y. */ +/* > The eigenvalues are not input to this routine, but are read directly */ +/* > from the diagonal blocks of T. */ +/* > */ +/* > This routine returns the matrices X and/or Y of right and left */ +/* > eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an */ +/* > input matrix. If Q is the orthogonal factor that reduces a matrix */ +/* > A to Schur form T, then Q*X and Q*Y are the matrices of right and */ +/* > left eigenvectors of A. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'R': compute right eigenvectors only; */ +/* > = 'L': compute left eigenvectors only; */ +/* > = 'B': compute both right and left eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] HOWMNY */ +/* > \verbatim */ +/* > HOWMNY is CHARACTER*1 */ +/* > = 'A': compute all right and/or left eigenvectors; */ +/* > = 'B': compute all right and/or left eigenvectors, */ +/* > backtransformed by the matrices in VR and/or VL; */ +/* > = 'S': compute selected right and/or left eigenvectors, */ +/* > as indicated by the logical array SELECT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > If HOWMNY = 'S', SELECT specifies the eigenvectors to be */ +/* > computed. */ +/* > If w(j) is a real eigenvalue, the corresponding real */ +/* > eigenvector is computed if SELECT(j) is .TRUE.. */ +/* > If w(j) and w(j+1) are the real and imaginary parts of a */ +/* > complex eigenvalue, the corresponding complex eigenvector is */ +/* > computed if either SELECT(j) or SELECT(j+1) is .TRUE., and */ +/* > on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to */ +/* > .FALSE.. */ +/* > Not referenced if HOWMNY = 'A' or 'B'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix T. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is DOUBLE PRECISION array, dimension (LDT,N) */ +/* > The upper quasi-triangular matrix T in Schur canonical form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VL */ +/* > \verbatim */ +/* > VL is DOUBLE PRECISION array, dimension (LDVL,MM) */ +/* > On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */ +/* > contain an N-by-N matrix Q (usually the orthogonal matrix Q */ +/* > of Schur vectors returned by DHSEQR). */ +/* > On exit, if SIDE = 'L' or 'B', VL contains: */ +/* > if HOWMNY = 'A', the matrix Y of left eigenvectors of T; */ +/* > if HOWMNY = 'B', the matrix Q*Y; */ +/* > if HOWMNY = 'S', the left eigenvectors of T specified by */ +/* > SELECT, stored consecutively in the columns */ +/* > of VL, in the same order as their */ +/* > eigenvalues. */ +/* > A complex eigenvector corresponding to a complex eigenvalue */ +/* > is stored in two consecutive columns, the first holding the */ +/* > real part, and the second the imaginary part. */ +/* > Not referenced if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the array VL. LDVL >= 1, and if */ +/* > SIDE = 'L' or 'B', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VR */ +/* > \verbatim */ +/* > VR is DOUBLE PRECISION array, dimension (LDVR,MM) */ +/* > On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */ +/* > contain an N-by-N matrix Q (usually the orthogonal matrix Q */ +/* > of Schur vectors returned by DHSEQR). */ +/* > On exit, if SIDE = 'R' or 'B', VR contains: */ +/* > if HOWMNY = 'A', the matrix X of right eigenvectors of T; */ +/* > if HOWMNY = 'B', the matrix Q*X; */ +/* > if HOWMNY = 'S', the right eigenvectors of T specified by */ +/* > SELECT, stored consecutively in the columns */ +/* > of VR, in the same order as their */ +/* > eigenvalues. */ +/* > A complex eigenvector corresponding to a complex eigenvalue */ +/* > is stored in two consecutive columns, the first holding the */ +/* > real part and the second the imaginary part. */ +/* > Not referenced if SIDE = 'L'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the array VR. LDVR >= 1, and if */ +/* > SIDE = 'R' or 'B', LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MM */ +/* > \verbatim */ +/* > MM is INTEGER */ +/* > The number of columns in the arrays VL and/or VR. MM >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of columns in the arrays VL and/or VR actually */ +/* > used to store the eigenvectors. */ +/* > If HOWMNY = 'A' or 'B', M is set to N. */ +/* > Each selected real eigenvector occupies one column and each */ +/* > selected complex eigenvector occupies two columns. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The algorithm used in this program is basically backward (forward) */ +/* > substitution, with scaling to make the the code robust against */ +/* > possible overflow. */ +/* > */ +/* > Each eigenvector is normalized so that the element of largest */ +/* > magnitude has magnitude 1; here the magnitude of a complex number */ +/* > (x,y) is taken to be |x| + |y|. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtrevc_(char *side, char *howmny, logical *select, + integer *n, doublereal *t, integer *ldt, doublereal *vl, integer * + ldvl, doublereal *vr, integer *ldvr, integer *mm, integer *m, + doublereal *work, integer *info) +{ + /* System generated locals */ + integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, + i__2, i__3; + doublereal d__1, d__2, d__3, d__4; + + /* Local variables */ + doublereal beta, emax; + logical pair; + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + logical allv; + integer ierr; + doublereal unfl, ovfl, smin; + logical over; + doublereal vmax; + integer jnxt, i__, j, k; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + doublereal scale, x[4] /* was [2][2] */; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *); + doublereal remax; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + logical leftv, bothv; + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *); + doublereal vcrit; + logical somev; + integer j1, j2, n2; + doublereal xnorm; + extern /* Subroutine */ int dlaln2_(logical *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, doublereal * + , doublereal *, integer *, doublereal *, doublereal *, integer *), + dlabad_(doublereal *, doublereal *); + integer ii, ki; + extern doublereal dlamch_(char *); + integer ip, is; + doublereal wi; + extern integer idamax_(integer *, doublereal *, integer *); + doublereal wr; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + logical rightv; + doublereal smlnum, rec, ulp; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + --select; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --work; + + /* Function Body */ + bothv = lsame_(side, "B"); + rightv = lsame_(side, "R") || bothv; + leftv = lsame_(side, "L") || bothv; + + allv = lsame_(howmny, "A"); + over = lsame_(howmny, "B"); + somev = lsame_(howmny, "S"); + + *info = 0; + if (! rightv && ! leftv) { + *info = -1; + } else if (! allv && ! over && ! somev) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*ldt < f2cmax(1,*n)) { + *info = -6; + } else if (*ldvl < 1 || leftv && *ldvl < *n) { + *info = -8; + } else if (*ldvr < 1 || rightv && *ldvr < *n) { + *info = -10; + } else { + +/* Set M to the number of columns required to store the selected */ +/* eigenvectors, standardize the array SELECT if necessary, and */ +/* test MM. */ + + if (somev) { + *m = 0; + pair = FALSE_; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (pair) { + pair = FALSE_; + select[j] = FALSE_; + } else { + if (j < *n) { + if (t[j + 1 + j * t_dim1] == 0.) { + if (select[j]) { + ++(*m); + } + } else { + pair = TRUE_; + if (select[j] || select[j + 1]) { + select[j] = TRUE_; + *m += 2; + } + } + } else { + if (select[*n]) { + ++(*m); + } + } + } +/* L10: */ + } + } else { + *m = *n; + } + + if (*mm < *m) { + *info = -11; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTREVC", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + +/* Set the constants to control overflow. */ + + unfl = dlamch_("Safe minimum"); + ovfl = 1. / unfl; + dlabad_(&unfl, &ovfl); + ulp = dlamch_("Precision"); + smlnum = unfl * (*n / ulp); + bignum = (1. - ulp) / smlnum; + +/* Compute 1-norm of each column of strictly upper triangular */ +/* part of T to control overflow in triangular solver. */ + + work[1] = 0.; + i__1 = *n; + for (j = 2; j <= i__1; ++j) { + work[j] = 0.; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work[j] += (d__1 = t[i__ + j * t_dim1], abs(d__1)); +/* L20: */ + } +/* L30: */ + } + +/* Index IP is used to specify the real or complex eigenvalue: */ +/* IP = 0, real eigenvalue, */ +/* 1, first of conjugate complex pair: (wr,wi) */ +/* -1, second of conjugate complex pair: (wr,wi) */ + + n2 = *n << 1; + + if (rightv) { + +/* Compute right eigenvectors. */ + + ip = 0; + is = *m; + for (ki = *n; ki >= 1; --ki) { + + if (ip == 1) { + goto L130; + } + if (ki == 1) { + goto L40; + } + if (t[ki + (ki - 1) * t_dim1] == 0.) { + goto L40; + } + ip = -1; + +L40: + if (somev) { + if (ip == 0) { + if (! select[ki]) { + goto L130; + } + } else { + if (! select[ki - 1]) { + goto L130; + } + } + } + +/* Compute the KI-th eigenvalue (WR,WI). */ + + wr = t[ki + ki * t_dim1]; + wi = 0.; + if (ip != 0) { + wi = sqrt((d__1 = t[ki + (ki - 1) * t_dim1], abs(d__1))) * + sqrt((d__2 = t[ki - 1 + ki * t_dim1], abs(d__2))); + } +/* Computing MAX */ + d__1 = ulp * (abs(wr) + abs(wi)); + smin = f2cmax(d__1,smlnum); + + if (ip == 0) { + +/* Real right eigenvector */ + + work[ki + *n] = 1.; + +/* Form right-hand side */ + + i__1 = ki - 1; + for (k = 1; k <= i__1; ++k) { + work[k + *n] = -t[k + ki * t_dim1]; +/* L50: */ + } + +/* Solve the upper quasi-triangular system: */ +/* (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK. */ + + jnxt = ki - 1; + for (j = ki - 1; j >= 1; --j) { + if (j > jnxt) { + goto L60; + } + j1 = j; + j2 = j; + jnxt = j - 1; + if (j > 1) { + if (t[j + (j - 1) * t_dim1] != 0.) { + j1 = j - 1; + jnxt = j - 2; + } + } + + if (j1 == j2) { + +/* 1-by-1 diagonal block */ + + dlaln2_(&c_false, &c__1, &c__1, &smin, &c_b22, &t[j + + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * + n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm, + &ierr); + +/* Scale X(1,1) to avoid overflow when updating */ +/* the right-hand side. */ + + if (xnorm > 1.) { + if (work[j] > bignum / xnorm) { + x[0] /= xnorm; + scale /= xnorm; + } + } + +/* Scale if necessary */ + + if (scale != 1.) { + dscal_(&ki, &scale, &work[*n + 1], &c__1); + } + work[j + *n] = x[0]; + +/* Update right-hand side */ + + i__1 = j - 1; + d__1 = -x[0]; + daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + *n + 1], &c__1); + + } else { + +/* 2-by-2 diagonal block */ + + dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b22, &t[j - + 1 + (j - 1) * t_dim1], ldt, &c_b22, &c_b22, & + work[j - 1 + *n], n, &wr, &c_b25, x, &c__2, & + scale, &xnorm, &ierr); + +/* Scale X(1,1) and X(2,1) to avoid overflow when */ +/* updating the right-hand side. */ + + if (xnorm > 1.) { +/* Computing MAX */ + d__1 = work[j - 1], d__2 = work[j]; + beta = f2cmax(d__1,d__2); + if (beta > bignum / xnorm) { + x[0] /= xnorm; + x[1] /= xnorm; + scale /= xnorm; + } + } + +/* Scale if necessary */ + + if (scale != 1.) { + dscal_(&ki, &scale, &work[*n + 1], &c__1); + } + work[j - 1 + *n] = x[0]; + work[j + *n] = x[1]; + +/* Update right-hand side */ + + i__1 = j - 2; + d__1 = -x[0]; + daxpy_(&i__1, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1, + &work[*n + 1], &c__1); + i__1 = j - 2; + d__1 = -x[1]; + daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + *n + 1], &c__1); + } +L60: + ; + } + +/* Copy the vector x or Q*x to VR and normalize. */ + + if (! over) { + dcopy_(&ki, &work[*n + 1], &c__1, &vr[is * vr_dim1 + 1], & + c__1); + + ii = idamax_(&ki, &vr[is * vr_dim1 + 1], &c__1); + remax = 1. / (d__1 = vr[ii + is * vr_dim1], abs(d__1)); + dscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1); + + i__1 = *n; + for (k = ki + 1; k <= i__1; ++k) { + vr[k + is * vr_dim1] = 0.; +/* L70: */ + } + } else { + if (ki > 1) { + i__1 = ki - 1; + dgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, & + work[*n + 1], &c__1, &work[ki + *n], &vr[ki * + vr_dim1 + 1], &c__1); + } + + ii = idamax_(n, &vr[ki * vr_dim1 + 1], &c__1); + remax = 1. / (d__1 = vr[ii + ki * vr_dim1], abs(d__1)); + dscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1); + } + + } else { + +/* Complex right eigenvector. */ + +/* Initial solve */ +/* [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0. */ +/* [ (T(KI,KI-1) T(KI,KI) ) ] */ + + if ((d__1 = t[ki - 1 + ki * t_dim1], abs(d__1)) >= (d__2 = t[ + ki + (ki - 1) * t_dim1], abs(d__2))) { + work[ki - 1 + *n] = 1.; + work[ki + n2] = wi / t[ki - 1 + ki * t_dim1]; + } else { + work[ki - 1 + *n] = -wi / t[ki + (ki - 1) * t_dim1]; + work[ki + n2] = 1.; + } + work[ki + *n] = 0.; + work[ki - 1 + n2] = 0.; + +/* Form right-hand side */ + + i__1 = ki - 2; + for (k = 1; k <= i__1; ++k) { + work[k + *n] = -work[ki - 1 + *n] * t[k + (ki - 1) * + t_dim1]; + work[k + n2] = -work[ki + n2] * t[k + ki * t_dim1]; +/* L80: */ + } + +/* Solve upper quasi-triangular system: */ +/* (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2) */ + + jnxt = ki - 2; + for (j = ki - 2; j >= 1; --j) { + if (j > jnxt) { + goto L90; + } + j1 = j; + j2 = j; + jnxt = j - 1; + if (j > 1) { + if (t[j + (j - 1) * t_dim1] != 0.) { + j1 = j - 1; + jnxt = j - 2; + } + } + + if (j1 == j2) { + +/* 1-by-1 diagonal block */ + + dlaln2_(&c_false, &c__1, &c__2, &smin, &c_b22, &t[j + + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * + n], n, &wr, &wi, x, &c__2, &scale, &xnorm, & + ierr); + +/* Scale X(1,1) and X(1,2) to avoid overflow when */ +/* updating the right-hand side. */ + + if (xnorm > 1.) { + if (work[j] > bignum / xnorm) { + x[0] /= xnorm; + x[2] /= xnorm; + scale /= xnorm; + } + } + +/* Scale if necessary */ + + if (scale != 1.) { + dscal_(&ki, &scale, &work[*n + 1], &c__1); + dscal_(&ki, &scale, &work[n2 + 1], &c__1); + } + work[j + *n] = x[0]; + work[j + n2] = x[2]; + +/* Update the right-hand side */ + + i__1 = j - 1; + d__1 = -x[0]; + daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + *n + 1], &c__1); + i__1 = j - 1; + d__1 = -x[2]; + daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + n2 + 1], &c__1); + + } else { + +/* 2-by-2 diagonal block */ + + dlaln2_(&c_false, &c__2, &c__2, &smin, &c_b22, &t[j - + 1 + (j - 1) * t_dim1], ldt, &c_b22, &c_b22, & + work[j - 1 + *n], n, &wr, &wi, x, &c__2, & + scale, &xnorm, &ierr); + +/* Scale X to avoid overflow when updating */ +/* the right-hand side. */ + + if (xnorm > 1.) { +/* Computing MAX */ + d__1 = work[j - 1], d__2 = work[j]; + beta = f2cmax(d__1,d__2); + if (beta > bignum / xnorm) { + rec = 1. / xnorm; + x[0] *= rec; + x[2] *= rec; + x[1] *= rec; + x[3] *= rec; + scale *= rec; + } + } + +/* Scale if necessary */ + + if (scale != 1.) { + dscal_(&ki, &scale, &work[*n + 1], &c__1); + dscal_(&ki, &scale, &work[n2 + 1], &c__1); + } + work[j - 1 + *n] = x[0]; + work[j + *n] = x[1]; + work[j - 1 + n2] = x[2]; + work[j + n2] = x[3]; + +/* Update the right-hand side */ + + i__1 = j - 2; + d__1 = -x[0]; + daxpy_(&i__1, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1, + &work[*n + 1], &c__1); + i__1 = j - 2; + d__1 = -x[1]; + daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + *n + 1], &c__1); + i__1 = j - 2; + d__1 = -x[2]; + daxpy_(&i__1, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1, + &work[n2 + 1], &c__1); + i__1 = j - 2; + d__1 = -x[3]; + daxpy_(&i__1, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + n2 + 1], &c__1); + } +L90: + ; + } + +/* Copy the vector x or Q*x to VR and normalize. */ + + if (! over) { + dcopy_(&ki, &work[*n + 1], &c__1, &vr[(is - 1) * vr_dim1 + + 1], &c__1); + dcopy_(&ki, &work[n2 + 1], &c__1, &vr[is * vr_dim1 + 1], & + c__1); + + emax = 0.; + i__1 = ki; + for (k = 1; k <= i__1; ++k) { +/* Computing MAX */ + d__3 = emax, d__4 = (d__1 = vr[k + (is - 1) * vr_dim1] + , abs(d__1)) + (d__2 = vr[k + is * vr_dim1], + abs(d__2)); + emax = f2cmax(d__3,d__4); +/* L100: */ + } + + remax = 1. / emax; + dscal_(&ki, &remax, &vr[(is - 1) * vr_dim1 + 1], &c__1); + dscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1); + + i__1 = *n; + for (k = ki + 1; k <= i__1; ++k) { + vr[k + (is - 1) * vr_dim1] = 0.; + vr[k + is * vr_dim1] = 0.; +/* L110: */ + } + + } else { + + if (ki > 2) { + i__1 = ki - 2; + dgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, & + work[*n + 1], &c__1, &work[ki - 1 + *n], &vr[( + ki - 1) * vr_dim1 + 1], &c__1); + i__1 = ki - 2; + dgemv_("N", n, &i__1, &c_b22, &vr[vr_offset], ldvr, & + work[n2 + 1], &c__1, &work[ki + n2], &vr[ki * + vr_dim1 + 1], &c__1); + } else { + dscal_(n, &work[ki - 1 + *n], &vr[(ki - 1) * vr_dim1 + + 1], &c__1); + dscal_(n, &work[ki + n2], &vr[ki * vr_dim1 + 1], & + c__1); + } + + emax = 0.; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { +/* Computing MAX */ + d__3 = emax, d__4 = (d__1 = vr[k + (ki - 1) * vr_dim1] + , abs(d__1)) + (d__2 = vr[k + ki * vr_dim1], + abs(d__2)); + emax = f2cmax(d__3,d__4); +/* L120: */ + } + remax = 1. / emax; + dscal_(n, &remax, &vr[(ki - 1) * vr_dim1 + 1], &c__1); + dscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1); + } + } + + --is; + if (ip != 0) { + --is; + } +L130: + if (ip == 1) { + ip = 0; + } + if (ip == -1) { + ip = 1; + } +/* L140: */ + } + } + + if (leftv) { + +/* Compute left eigenvectors. */ + + ip = 0; + is = 1; + i__1 = *n; + for (ki = 1; ki <= i__1; ++ki) { + + if (ip == -1) { + goto L250; + } + if (ki == *n) { + goto L150; + } + if (t[ki + 1 + ki * t_dim1] == 0.) { + goto L150; + } + ip = 1; + +L150: + if (somev) { + if (! select[ki]) { + goto L250; + } + } + +/* Compute the KI-th eigenvalue (WR,WI). */ + + wr = t[ki + ki * t_dim1]; + wi = 0.; + if (ip != 0) { + wi = sqrt((d__1 = t[ki + (ki + 1) * t_dim1], abs(d__1))) * + sqrt((d__2 = t[ki + 1 + ki * t_dim1], abs(d__2))); + } +/* Computing MAX */ + d__1 = ulp * (abs(wr) + abs(wi)); + smin = f2cmax(d__1,smlnum); + + if (ip == 0) { + +/* Real left eigenvector. */ + + work[ki + *n] = 1.; + +/* Form right-hand side */ + + i__2 = *n; + for (k = ki + 1; k <= i__2; ++k) { + work[k + *n] = -t[ki + k * t_dim1]; +/* L160: */ + } + +/* Solve the quasi-triangular system: */ +/* (T(KI+1:N,KI+1:N) - WR)**T*X = SCALE*WORK */ + + vmax = 1.; + vcrit = bignum; + + jnxt = ki + 1; + i__2 = *n; + for (j = ki + 1; j <= i__2; ++j) { + if (j < jnxt) { + goto L170; + } + j1 = j; + j2 = j; + jnxt = j + 1; + if (j < *n) { + if (t[j + 1 + j * t_dim1] != 0.) { + j2 = j + 1; + jnxt = j + 2; + } + } + + if (j1 == j2) { + +/* 1-by-1 diagonal block */ + +/* Scale if necessary to avoid overflow when forming */ +/* the right-hand side. */ + + if (work[j] > vcrit) { + rec = 1. / vmax; + i__3 = *n - ki + 1; + dscal_(&i__3, &rec, &work[ki + *n], &c__1); + vmax = 1.; + vcrit = bignum; + } + + i__3 = j - ki - 1; + work[j + *n] -= ddot_(&i__3, &t[ki + 1 + j * t_dim1], + &c__1, &work[ki + 1 + *n], &c__1); + +/* Solve (T(J,J)-WR)**T*X = WORK */ + + dlaln2_(&c_false, &c__1, &c__1, &smin, &c_b22, &t[j + + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * + n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm, + &ierr); + +/* Scale if necessary */ + + if (scale != 1.) { + i__3 = *n - ki + 1; + dscal_(&i__3, &scale, &work[ki + *n], &c__1); + } + work[j + *n] = x[0]; +/* Computing MAX */ + d__2 = (d__1 = work[j + *n], abs(d__1)); + vmax = f2cmax(d__2,vmax); + vcrit = bignum / vmax; + + } else { + +/* 2-by-2 diagonal block */ + +/* Scale if necessary to avoid overflow when forming */ +/* the right-hand side. */ + +/* Computing MAX */ + d__1 = work[j], d__2 = work[j + 1]; + beta = f2cmax(d__1,d__2); + if (beta > vcrit) { + rec = 1. / vmax; + i__3 = *n - ki + 1; + dscal_(&i__3, &rec, &work[ki + *n], &c__1); + vmax = 1.; + vcrit = bignum; + } + + i__3 = j - ki - 1; + work[j + *n] -= ddot_(&i__3, &t[ki + 1 + j * t_dim1], + &c__1, &work[ki + 1 + *n], &c__1); + + i__3 = j - ki - 1; + work[j + 1 + *n] -= ddot_(&i__3, &t[ki + 1 + (j + 1) * + t_dim1], &c__1, &work[ki + 1 + *n], &c__1); + +/* Solve */ +/* [T(J,J)-WR T(J,J+1) ]**T * X = SCALE*( WORK1 ) */ +/* [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 ) */ + + dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b22, &t[j + + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * + n], n, &wr, &c_b25, x, &c__2, &scale, &xnorm, + &ierr); + +/* Scale if necessary */ + + if (scale != 1.) { + i__3 = *n - ki + 1; + dscal_(&i__3, &scale, &work[ki + *n], &c__1); + } + work[j + *n] = x[0]; + work[j + 1 + *n] = x[1]; + +/* Computing MAX */ + d__3 = (d__1 = work[j + *n], abs(d__1)), d__4 = (d__2 + = work[j + 1 + *n], abs(d__2)), d__3 = f2cmax( + d__3,d__4); + vmax = f2cmax(d__3,vmax); + vcrit = bignum / vmax; + + } +L170: + ; + } + +/* Copy the vector x or Q*x to VL and normalize. */ + + if (! over) { + i__2 = *n - ki + 1; + dcopy_(&i__2, &work[ki + *n], &c__1, &vl[ki + is * + vl_dim1], &c__1); + + i__2 = *n - ki + 1; + ii = idamax_(&i__2, &vl[ki + is * vl_dim1], &c__1) + ki - + 1; + remax = 1. / (d__1 = vl[ii + is * vl_dim1], abs(d__1)); + i__2 = *n - ki + 1; + dscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1); + + i__2 = ki - 1; + for (k = 1; k <= i__2; ++k) { + vl[k + is * vl_dim1] = 0.; +/* L180: */ + } + + } else { + + if (ki < *n) { + i__2 = *n - ki; + dgemv_("N", n, &i__2, &c_b22, &vl[(ki + 1) * vl_dim1 + + 1], ldvl, &work[ki + 1 + *n], &c__1, &work[ + ki + *n], &vl[ki * vl_dim1 + 1], &c__1); + } + + ii = idamax_(n, &vl[ki * vl_dim1 + 1], &c__1); + remax = 1. / (d__1 = vl[ii + ki * vl_dim1], abs(d__1)); + dscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1); + + } + + } else { + +/* Complex left eigenvector. */ + +/* Initial solve: */ +/* ((T(KI,KI) T(KI,KI+1) )**T - (WR - I* WI))*X = 0. */ +/* ((T(KI+1,KI) T(KI+1,KI+1)) ) */ + + if ((d__1 = t[ki + (ki + 1) * t_dim1], abs(d__1)) >= (d__2 = + t[ki + 1 + ki * t_dim1], abs(d__2))) { + work[ki + *n] = wi / t[ki + (ki + 1) * t_dim1]; + work[ki + 1 + n2] = 1.; + } else { + work[ki + *n] = 1.; + work[ki + 1 + n2] = -wi / t[ki + 1 + ki * t_dim1]; + } + work[ki + 1 + *n] = 0.; + work[ki + n2] = 0.; + +/* Form right-hand side */ + + i__2 = *n; + for (k = ki + 2; k <= i__2; ++k) { + work[k + *n] = -work[ki + *n] * t[ki + k * t_dim1]; + work[k + n2] = -work[ki + 1 + n2] * t[ki + 1 + k * t_dim1] + ; +/* L190: */ + } + +/* Solve complex quasi-triangular system: */ +/* ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2 */ + + vmax = 1.; + vcrit = bignum; + + jnxt = ki + 2; + i__2 = *n; + for (j = ki + 2; j <= i__2; ++j) { + if (j < jnxt) { + goto L200; + } + j1 = j; + j2 = j; + jnxt = j + 1; + if (j < *n) { + if (t[j + 1 + j * t_dim1] != 0.) { + j2 = j + 1; + jnxt = j + 2; + } + } + + if (j1 == j2) { + +/* 1-by-1 diagonal block */ + +/* Scale if necessary to avoid overflow when */ +/* forming the right-hand side elements. */ + + if (work[j] > vcrit) { + rec = 1. / vmax; + i__3 = *n - ki + 1; + dscal_(&i__3, &rec, &work[ki + *n], &c__1); + i__3 = *n - ki + 1; + dscal_(&i__3, &rec, &work[ki + n2], &c__1); + vmax = 1.; + vcrit = bignum; + } + + i__3 = j - ki - 2; + work[j + *n] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1], + &c__1, &work[ki + 2 + *n], &c__1); + i__3 = j - ki - 2; + work[j + n2] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1], + &c__1, &work[ki + 2 + n2], &c__1); + +/* Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2 */ + + d__1 = -wi; + dlaln2_(&c_false, &c__1, &c__2, &smin, &c_b22, &t[j + + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * + n], n, &wr, &d__1, x, &c__2, &scale, &xnorm, & + ierr); + +/* Scale if necessary */ + + if (scale != 1.) { + i__3 = *n - ki + 1; + dscal_(&i__3, &scale, &work[ki + *n], &c__1); + i__3 = *n - ki + 1; + dscal_(&i__3, &scale, &work[ki + n2], &c__1); + } + work[j + *n] = x[0]; + work[j + n2] = x[2]; +/* Computing MAX */ + d__3 = (d__1 = work[j + *n], abs(d__1)), d__4 = (d__2 + = work[j + n2], abs(d__2)), d__3 = f2cmax(d__3, + d__4); + vmax = f2cmax(d__3,vmax); + vcrit = bignum / vmax; + + } else { + +/* 2-by-2 diagonal block */ + +/* Scale if necessary to avoid overflow when forming */ +/* the right-hand side elements. */ + +/* Computing MAX */ + d__1 = work[j], d__2 = work[j + 1]; + beta = f2cmax(d__1,d__2); + if (beta > vcrit) { + rec = 1. / vmax; + i__3 = *n - ki + 1; + dscal_(&i__3, &rec, &work[ki + *n], &c__1); + i__3 = *n - ki + 1; + dscal_(&i__3, &rec, &work[ki + n2], &c__1); + vmax = 1.; + vcrit = bignum; + } + + i__3 = j - ki - 2; + work[j + *n] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1], + &c__1, &work[ki + 2 + *n], &c__1); + + i__3 = j - ki - 2; + work[j + n2] -= ddot_(&i__3, &t[ki + 2 + j * t_dim1], + &c__1, &work[ki + 2 + n2], &c__1); + + i__3 = j - ki - 2; + work[j + 1 + *n] -= ddot_(&i__3, &t[ki + 2 + (j + 1) * + t_dim1], &c__1, &work[ki + 2 + *n], &c__1); + + i__3 = j - ki - 2; + work[j + 1 + n2] -= ddot_(&i__3, &t[ki + 2 + (j + 1) * + t_dim1], &c__1, &work[ki + 2 + n2], &c__1); + +/* Solve 2-by-2 complex linear equation */ +/* ([T(j,j) T(j,j+1) ]**T-(wr-i*wi)*I)*X = SCALE*B */ +/* ([T(j+1,j) T(j+1,j+1)] ) */ + + d__1 = -wi; + dlaln2_(&c_true, &c__2, &c__2, &smin, &c_b22, &t[j + + j * t_dim1], ldt, &c_b22, &c_b22, &work[j + * + n], n, &wr, &d__1, x, &c__2, &scale, &xnorm, & + ierr); + +/* Scale if necessary */ + + if (scale != 1.) { + i__3 = *n - ki + 1; + dscal_(&i__3, &scale, &work[ki + *n], &c__1); + i__3 = *n - ki + 1; + dscal_(&i__3, &scale, &work[ki + n2], &c__1); + } + work[j + *n] = x[0]; + work[j + n2] = x[2]; + work[j + 1 + *n] = x[1]; + work[j + 1 + n2] = x[3]; +/* Computing MAX */ + d__1 = abs(x[0]), d__2 = abs(x[2]), d__1 = f2cmax(d__1, + d__2), d__2 = abs(x[1]), d__1 = f2cmax(d__1,d__2) + , d__2 = abs(x[3]), d__1 = f2cmax(d__1,d__2); + vmax = f2cmax(d__1,vmax); + vcrit = bignum / vmax; + + } +L200: + ; + } + +/* Copy the vector x or Q*x to VL and normalize. */ + + if (! over) { + i__2 = *n - ki + 1; + dcopy_(&i__2, &work[ki + *n], &c__1, &vl[ki + is * + vl_dim1], &c__1); + i__2 = *n - ki + 1; + dcopy_(&i__2, &work[ki + n2], &c__1, &vl[ki + (is + 1) * + vl_dim1], &c__1); + + emax = 0.; + i__2 = *n; + for (k = ki; k <= i__2; ++k) { +/* Computing MAX */ + d__3 = emax, d__4 = (d__1 = vl[k + is * vl_dim1], abs( + d__1)) + (d__2 = vl[k + (is + 1) * vl_dim1], + abs(d__2)); + emax = f2cmax(d__3,d__4); +/* L220: */ + } + remax = 1. / emax; + i__2 = *n - ki + 1; + dscal_(&i__2, &remax, &vl[ki + is * vl_dim1], &c__1); + i__2 = *n - ki + 1; + dscal_(&i__2, &remax, &vl[ki + (is + 1) * vl_dim1], &c__1) + ; + + i__2 = ki - 1; + for (k = 1; k <= i__2; ++k) { + vl[k + is * vl_dim1] = 0.; + vl[k + (is + 1) * vl_dim1] = 0.; +/* L230: */ + } + } else { + if (ki < *n - 1) { + i__2 = *n - ki - 1; + dgemv_("N", n, &i__2, &c_b22, &vl[(ki + 2) * vl_dim1 + + 1], ldvl, &work[ki + 2 + *n], &c__1, &work[ + ki + *n], &vl[ki * vl_dim1 + 1], &c__1); + i__2 = *n - ki - 1; + dgemv_("N", n, &i__2, &c_b22, &vl[(ki + 2) * vl_dim1 + + 1], ldvl, &work[ki + 2 + n2], &c__1, &work[ + ki + 1 + n2], &vl[(ki + 1) * vl_dim1 + 1], & + c__1); + } else { + dscal_(n, &work[ki + *n], &vl[ki * vl_dim1 + 1], & + c__1); + dscal_(n, &work[ki + 1 + n2], &vl[(ki + 1) * vl_dim1 + + 1], &c__1); + } + + emax = 0.; + i__2 = *n; + for (k = 1; k <= i__2; ++k) { +/* Computing MAX */ + d__3 = emax, d__4 = (d__1 = vl[k + ki * vl_dim1], abs( + d__1)) + (d__2 = vl[k + (ki + 1) * vl_dim1], + abs(d__2)); + emax = f2cmax(d__3,d__4); +/* L240: */ + } + remax = 1. / emax; + dscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1); + dscal_(n, &remax, &vl[(ki + 1) * vl_dim1 + 1], &c__1); + + } + + } + + ++is; + if (ip != 0) { + ++is; + } +L250: + if (ip == -1) { + ip = 0; + } + if (ip == 1) { + ip = -1; + } + +/* L260: */ + } + + } + + return 0; + +/* End of DTREVC */ + +} /* dtrevc_ */ + diff --git a/lapack-netlib/SRC/dtrevc3.c b/lapack-netlib/SRC/dtrevc3.c new file mode 100644 index 000000000..78111fb2c --- /dev/null +++ b/lapack-netlib/SRC/dtrevc3.c @@ -0,0 +1,1939 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTREVC3 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTREVC3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTREVC3( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, */ +/* VR, LDVR, MM, M, WORK, LWORK, INFO ) */ + +/* CHARACTER HOWMNY, SIDE */ +/* INTEGER INFO, LDT, LDVL, LDVR, LWORK, M, MM, N */ +/* LOGICAL SELECT( * ) */ +/* DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ), */ +/* $ WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTREVC3 computes some or all of the right and/or left eigenvectors of */ +/* > a real upper quasi-triangular matrix T. */ +/* > Matrices of this type are produced by the Schur factorization of */ +/* > a real general matrix: A = Q*T*Q**T, as computed by DHSEQR. */ +/* > */ +/* > The right eigenvector x and the left eigenvector y of T corresponding */ +/* > to an eigenvalue w are defined by: */ +/* > */ +/* > T*x = w*x, (y**T)*T = w*(y**T) */ +/* > */ +/* > where y**T denotes the transpose of the vector y. */ +/* > The eigenvalues are not input to this routine, but are read directly */ +/* > from the diagonal blocks of T. */ +/* > */ +/* > This routine returns the matrices X and/or Y of right and left */ +/* > eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an */ +/* > input matrix. If Q is the orthogonal factor that reduces a matrix */ +/* > A to Schur form T, then Q*X and Q*Y are the matrices of right and */ +/* > left eigenvectors of A. */ +/* > */ +/* > This uses a Level 3 BLAS version of the back transformation. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] SIDE */ +/* > \verbatim */ +/* > SIDE is CHARACTER*1 */ +/* > = 'R': compute right eigenvectors only; */ +/* > = 'L': compute left eigenvectors only; */ +/* > = 'B': compute both right and left eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] HOWMNY */ +/* > \verbatim */ +/* > HOWMNY is CHARACTER*1 */ +/* > = 'A': compute all right and/or left eigenvectors; */ +/* > = 'B': compute all right and/or left eigenvectors, */ +/* > backtransformed by the matrices in VR and/or VL; */ +/* > = 'S': compute selected right and/or left eigenvectors, */ +/* > as indicated by the logical array SELECT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > If HOWMNY = 'S', SELECT specifies the eigenvectors to be */ +/* > computed. */ +/* > If w(j) is a real eigenvalue, the corresponding real */ +/* > eigenvector is computed if SELECT(j) is .TRUE.. */ +/* > If w(j) and w(j+1) are the real and imaginary parts of a */ +/* > complex eigenvalue, the corresponding complex eigenvector is */ +/* > computed if either SELECT(j) or SELECT(j+1) is .TRUE., and */ +/* > on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to */ +/* > .FALSE.. */ +/* > Not referenced if HOWMNY = 'A' or 'B'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix T. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is DOUBLE PRECISION array, dimension (LDT,N) */ +/* > The upper quasi-triangular matrix T in Schur canonical form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VL */ +/* > \verbatim */ +/* > VL is DOUBLE PRECISION array, dimension (LDVL,MM) */ +/* > On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must */ +/* > contain an N-by-N matrix Q (usually the orthogonal matrix Q */ +/* > of Schur vectors returned by DHSEQR). */ +/* > On exit, if SIDE = 'L' or 'B', VL contains: */ +/* > if HOWMNY = 'A', the matrix Y of left eigenvectors of T; */ +/* > if HOWMNY = 'B', the matrix Q*Y; */ +/* > if HOWMNY = 'S', the left eigenvectors of T specified by */ +/* > SELECT, stored consecutively in the columns */ +/* > of VL, in the same order as their */ +/* > eigenvalues. */ +/* > A complex eigenvector corresponding to a complex eigenvalue */ +/* > is stored in two consecutive columns, the first holding the */ +/* > real part, and the second the imaginary part. */ +/* > Not referenced if SIDE = 'R'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the array VL. */ +/* > LDVL >= 1, and if SIDE = 'L' or 'B', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VR */ +/* > \verbatim */ +/* > VR is DOUBLE PRECISION array, dimension (LDVR,MM) */ +/* > On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must */ +/* > contain an N-by-N matrix Q (usually the orthogonal matrix Q */ +/* > of Schur vectors returned by DHSEQR). */ +/* > On exit, if SIDE = 'R' or 'B', VR contains: */ +/* > if HOWMNY = 'A', the matrix X of right eigenvectors of T; */ +/* > if HOWMNY = 'B', the matrix Q*X; */ +/* > if HOWMNY = 'S', the right eigenvectors of T specified by */ +/* > SELECT, stored consecutively in the columns */ +/* > of VR, in the same order as their */ +/* > eigenvalues. */ +/* > A complex eigenvector corresponding to a complex eigenvalue */ +/* > is stored in two consecutive columns, the first holding the */ +/* > real part and the second the imaginary part. */ +/* > Not referenced if SIDE = 'L'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the array VR. */ +/* > LDVR >= 1, and if SIDE = 'R' or 'B', LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MM */ +/* > \verbatim */ +/* > MM is INTEGER */ +/* > The number of columns in the arrays VL and/or VR. MM >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of columns in the arrays VL and/or VR actually */ +/* > used to store the eigenvectors. */ +/* > If HOWMNY = 'A' or 'B', M is set to N. */ +/* > Each selected real eigenvector occupies one column and each */ +/* > selected complex eigenvector occupies two columns. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of array WORK. LWORK >= f2cmax(1,3*N). */ +/* > For optimum performance, LWORK >= N + 2*N*NB, where NB is */ +/* > the optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* @precisions fortran d -> s */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The algorithm used in this program is basically backward (forward) */ +/* > substitution, with scaling to make the the code robust against */ +/* > possible overflow. */ +/* > */ +/* > Each eigenvector is normalized so that the element of largest */ +/* > magnitude has magnitude 1; here the magnitude of a complex number */ +/* > (x,y) is taken to be |x| + |y|. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtrevc3_(char *side, char *howmny, logical *select, + integer *n, doublereal *t, integer *ldt, doublereal *vl, integer * + ldvl, doublereal *vr, integer *ldvr, integer *mm, integer *m, + doublereal *work, integer *lwork, integer *info) +{ + /* System generated locals */ + address a__1[2]; + integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1[2], + i__2, i__3, i__4; + doublereal d__1, d__2, d__3, d__4; + char ch__1[2]; + + /* Local variables */ + doublereal beta, emax; + logical pair; + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + logical allv; + integer ierr; + doublereal unfl, ovfl, smin; + logical over; + doublereal vmax; + integer jnxt, i__, j, k; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + doublereal scale, x[4] /* was [2][2] */; + extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dgemv_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, integer *); + doublereal remax; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + logical leftv, bothv; + extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *); + doublereal vcrit; + logical somev; + integer j1, j2; + doublereal xnorm; + extern /* Subroutine */ int dlaln2_(logical *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, doublereal * + , doublereal *, integer *, doublereal *, doublereal *, integer *); + integer iscomplex[128]; + extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); + integer nb, ii, ki; + extern doublereal dlamch_(char *); + integer ip, is, iv; + doublereal wi; + extern integer idamax_(integer *, doublereal *, integer *); + doublereal wr; + extern /* Subroutine */ int dlaset_(char *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *); + doublereal bignum; + logical rightv; + integer ki2, maxwrk; + doublereal smlnum; + logical lquery; + doublereal rec, ulp; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + --select; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --work; + + /* Function Body */ + bothv = lsame_(side, "B"); + rightv = lsame_(side, "R") || bothv; + leftv = lsame_(side, "L") || bothv; + + allv = lsame_(howmny, "A"); + over = lsame_(howmny, "B"); + somev = lsame_(howmny, "S"); + + *info = 0; +/* Writing concatenation */ + i__1[0] = 1, a__1[0] = side; + i__1[1] = 1, a__1[1] = howmny; + s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); + nb = ilaenv_(&c__1, "DTREVC", ch__1, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)2); + maxwrk = *n + (*n << 1) * nb; + work[1] = (doublereal) maxwrk; + lquery = *lwork == -1; + if (! rightv && ! leftv) { + *info = -1; + } else if (! allv && ! over && ! somev) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*ldt < f2cmax(1,*n)) { + *info = -6; + } else if (*ldvl < 1 || leftv && *ldvl < *n) { + *info = -8; + } else if (*ldvr < 1 || rightv && *ldvr < *n) { + *info = -10; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__2 = 1, i__3 = *n * 3; + if (*lwork < f2cmax(i__2,i__3) && ! lquery) { + *info = -14; + } else { + +/* Set M to the number of columns required to store the selected */ +/* eigenvectors, standardize the array SELECT if necessary, and */ +/* test MM. */ + + if (somev) { + *m = 0; + pair = FALSE_; + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + if (pair) { + pair = FALSE_; + select[j] = FALSE_; + } else { + if (j < *n) { + if (t[j + 1 + j * t_dim1] == 0.) { + if (select[j]) { + ++(*m); + } + } else { + pair = TRUE_; + if (select[j] || select[j + 1]) { + select[j] = TRUE_; + *m += 2; + } + } + } else { + if (select[*n]) { + ++(*m); + } + } + } +/* L10: */ + } + } else { + *m = *n; + } + + if (*mm < *m) { + *info = -11; + } + } + } + if (*info != 0) { + i__2 = -(*info); + xerbla_("DTREVC3", &i__2, (ftnlen)7); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + +/* Use blocked version of back-transformation if sufficient workspace. */ +/* Zero-out the workspace to avoid potential NaN propagation. */ + + if (over && *lwork >= *n + (*n << 4)) { + nb = (*lwork - *n) / (*n << 1); + nb = f2cmin(nb,128); + i__2 = (nb << 1) + 1; + dlaset_("F", n, &i__2, &c_b17, &c_b17, &work[1], n); + } else { + nb = 1; + } + +/* Set the constants to control overflow. */ + + unfl = dlamch_("Safe minimum"); + ovfl = 1. / unfl; + dlabad_(&unfl, &ovfl); + ulp = dlamch_("Precision"); + smlnum = unfl * (*n / ulp); + bignum = (1. - ulp) / smlnum; + +/* Compute 1-norm of each column of strictly upper triangular */ +/* part of T to control overflow in triangular solver. */ + + work[1] = 0.; + i__2 = *n; + for (j = 2; j <= i__2; ++j) { + work[j] = 0.; + i__3 = j - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + work[j] += (d__1 = t[i__ + j * t_dim1], abs(d__1)); +/* L20: */ + } +/* L30: */ + } + +/* Index IP is used to specify the real or complex eigenvalue: */ +/* IP = 0, real eigenvalue, */ +/* 1, first of conjugate complex pair: (wr,wi) */ +/* -1, second of conjugate complex pair: (wr,wi) */ +/* ISCOMPLEX array stores IP for each column in current block. */ + + if (rightv) { + +/* ============================================================ */ +/* Compute right eigenvectors. */ + +/* IV is index of column in current block. */ +/* For complex right vector, uses IV-1 for real part and IV for complex part. */ +/* Non-blocked version always uses IV=2; */ +/* blocked version starts with IV=NB, goes down to 1 or 2. */ +/* (Note the "0-th" column is used for 1-norms computed above.) */ + iv = 2; + if (nb > 2) { + iv = nb; + } + ip = 0; + is = *m; + for (ki = *n; ki >= 1; --ki) { + if (ip == -1) { +/* previous iteration (ki+1) was second of conjugate pair, */ +/* so this ki is first of conjugate pair; skip to end of loop */ + ip = 1; + goto L140; + } else if (ki == 1) { +/* last column, so this ki must be real eigenvalue */ + ip = 0; + } else if (t[ki + (ki - 1) * t_dim1] == 0.) { +/* zero on sub-diagonal, so this ki is real eigenvalue */ + ip = 0; + } else { +/* non-zero on sub-diagonal, so this ki is second of conjugate pair */ + ip = -1; + } + if (somev) { + if (ip == 0) { + if (! select[ki]) { + goto L140; + } + } else { + if (! select[ki - 1]) { + goto L140; + } + } + } + +/* Compute the KI-th eigenvalue (WR,WI). */ + + wr = t[ki + ki * t_dim1]; + wi = 0.; + if (ip != 0) { + wi = sqrt((d__1 = t[ki + (ki - 1) * t_dim1], abs(d__1))) * + sqrt((d__2 = t[ki - 1 + ki * t_dim1], abs(d__2))); + } +/* Computing MAX */ + d__1 = ulp * (abs(wr) + abs(wi)); + smin = f2cmax(d__1,smlnum); + + if (ip == 0) { + +/* -------------------------------------------------------- */ +/* Real right eigenvector */ + + work[ki + iv * *n] = 1.; + +/* Form right-hand side. */ + + i__2 = ki - 1; + for (k = 1; k <= i__2; ++k) { + work[k + iv * *n] = -t[k + ki * t_dim1]; +/* L50: */ + } + +/* Solve upper quasi-triangular system: */ +/* [ T(1:KI-1,1:KI-1) - WR ]*X = SCALE*WORK. */ + + jnxt = ki - 1; + for (j = ki - 1; j >= 1; --j) { + if (j > jnxt) { + goto L60; + } + j1 = j; + j2 = j; + jnxt = j - 1; + if (j > 1) { + if (t[j + (j - 1) * t_dim1] != 0.) { + j1 = j - 1; + jnxt = j - 2; + } + } + + if (j1 == j2) { + +/* 1-by-1 diagonal block */ + + dlaln2_(&c_false, &c__1, &c__1, &smin, &c_b29, &t[j + + j * t_dim1], ldt, &c_b29, &c_b29, &work[j + + iv * *n], n, &wr, &c_b17, x, &c__2, &scale, & + xnorm, &ierr); + +/* Scale X(1,1) to avoid overflow when updating */ +/* the right-hand side. */ + + if (xnorm > 1.) { + if (work[j] > bignum / xnorm) { + x[0] /= xnorm; + scale /= xnorm; + } + } + +/* Scale if necessary */ + + if (scale != 1.) { + dscal_(&ki, &scale, &work[iv * *n + 1], &c__1); + } + work[j + iv * *n] = x[0]; + +/* Update right-hand side */ + + i__2 = j - 1; + d__1 = -x[0]; + daxpy_(&i__2, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + iv * *n + 1], &c__1); + + } else { + +/* 2-by-2 diagonal block */ + + dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b29, &t[j - + 1 + (j - 1) * t_dim1], ldt, &c_b29, &c_b29, & + work[j - 1 + iv * *n], n, &wr, &c_b17, x, & + c__2, &scale, &xnorm, &ierr); + +/* Scale X(1,1) and X(2,1) to avoid overflow when */ +/* updating the right-hand side. */ + + if (xnorm > 1.) { +/* Computing MAX */ + d__1 = work[j - 1], d__2 = work[j]; + beta = f2cmax(d__1,d__2); + if (beta > bignum / xnorm) { + x[0] /= xnorm; + x[1] /= xnorm; + scale /= xnorm; + } + } + +/* Scale if necessary */ + + if (scale != 1.) { + dscal_(&ki, &scale, &work[iv * *n + 1], &c__1); + } + work[j - 1 + iv * *n] = x[0]; + work[j + iv * *n] = x[1]; + +/* Update right-hand side */ + + i__2 = j - 2; + d__1 = -x[0]; + daxpy_(&i__2, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1, + &work[iv * *n + 1], &c__1); + i__2 = j - 2; + d__1 = -x[1]; + daxpy_(&i__2, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + iv * *n + 1], &c__1); + } +L60: + ; + } + +/* Copy the vector x or Q*x to VR and normalize. */ + + if (! over) { +/* ------------------------------ */ +/* no back-transform: copy x to VR and normalize. */ + dcopy_(&ki, &work[iv * *n + 1], &c__1, &vr[is * vr_dim1 + + 1], &c__1); + + ii = idamax_(&ki, &vr[is * vr_dim1 + 1], &c__1); + remax = 1. / (d__1 = vr[ii + is * vr_dim1], abs(d__1)); + dscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1); + + i__2 = *n; + for (k = ki + 1; k <= i__2; ++k) { + vr[k + is * vr_dim1] = 0.; +/* L70: */ + } + + } else if (nb == 1) { +/* ------------------------------ */ +/* version 1: back-transform each vector with GEMV, Q*x. */ + if (ki > 1) { + i__2 = ki - 1; + dgemv_("N", n, &i__2, &c_b29, &vr[vr_offset], ldvr, & + work[iv * *n + 1], &c__1, &work[ki + iv * *n], + &vr[ki * vr_dim1 + 1], &c__1); + } + + ii = idamax_(n, &vr[ki * vr_dim1 + 1], &c__1); + remax = 1. / (d__1 = vr[ii + ki * vr_dim1], abs(d__1)); + dscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1); + + } else { +/* ------------------------------ */ +/* version 2: back-transform block of vectors with GEMM */ +/* zero out below vector */ + i__2 = *n; + for (k = ki + 1; k <= i__2; ++k) { + work[k + iv * *n] = 0.; + } + iscomplex[iv - 1] = ip; +/* back-transform and normalization is done below */ + } + } else { + +/* -------------------------------------------------------- */ +/* Complex right eigenvector. */ + +/* Initial solve */ +/* [ ( T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I*WI) ]*X = 0. */ +/* [ ( T(KI, KI-1) T(KI, KI) ) ] */ + + if ((d__1 = t[ki - 1 + ki * t_dim1], abs(d__1)) >= (d__2 = t[ + ki + (ki - 1) * t_dim1], abs(d__2))) { + work[ki - 1 + (iv - 1) * *n] = 1.; + work[ki + iv * *n] = wi / t[ki - 1 + ki * t_dim1]; + } else { + work[ki - 1 + (iv - 1) * *n] = -wi / t[ki + (ki - 1) * + t_dim1]; + work[ki + iv * *n] = 1.; + } + work[ki + (iv - 1) * *n] = 0.; + work[ki - 1 + iv * *n] = 0.; + +/* Form right-hand side. */ + + i__2 = ki - 2; + for (k = 1; k <= i__2; ++k) { + work[k + (iv - 1) * *n] = -work[ki - 1 + (iv - 1) * *n] * + t[k + (ki - 1) * t_dim1]; + work[k + iv * *n] = -work[ki + iv * *n] * t[k + ki * + t_dim1]; +/* L80: */ + } + +/* Solve upper quasi-triangular system: */ +/* [ T(1:KI-2,1:KI-2) - (WR+i*WI) ]*X = SCALE*(WORK+i*WORK2) */ + + jnxt = ki - 2; + for (j = ki - 2; j >= 1; --j) { + if (j > jnxt) { + goto L90; + } + j1 = j; + j2 = j; + jnxt = j - 1; + if (j > 1) { + if (t[j + (j - 1) * t_dim1] != 0.) { + j1 = j - 1; + jnxt = j - 2; + } + } + + if (j1 == j2) { + +/* 1-by-1 diagonal block */ + + dlaln2_(&c_false, &c__1, &c__2, &smin, &c_b29, &t[j + + j * t_dim1], ldt, &c_b29, &c_b29, &work[j + ( + iv - 1) * *n], n, &wr, &wi, x, &c__2, &scale, + &xnorm, &ierr); + +/* Scale X(1,1) and X(1,2) to avoid overflow when */ +/* updating the right-hand side. */ + + if (xnorm > 1.) { + if (work[j] > bignum / xnorm) { + x[0] /= xnorm; + x[2] /= xnorm; + scale /= xnorm; + } + } + +/* Scale if necessary */ + + if (scale != 1.) { + dscal_(&ki, &scale, &work[(iv - 1) * *n + 1], & + c__1); + dscal_(&ki, &scale, &work[iv * *n + 1], &c__1); + } + work[j + (iv - 1) * *n] = x[0]; + work[j + iv * *n] = x[2]; + +/* Update the right-hand side */ + + i__2 = j - 1; + d__1 = -x[0]; + daxpy_(&i__2, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + (iv - 1) * *n + 1], &c__1); + i__2 = j - 1; + d__1 = -x[2]; + daxpy_(&i__2, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + iv * *n + 1], &c__1); + + } else { + +/* 2-by-2 diagonal block */ + + dlaln2_(&c_false, &c__2, &c__2, &smin, &c_b29, &t[j - + 1 + (j - 1) * t_dim1], ldt, &c_b29, &c_b29, & + work[j - 1 + (iv - 1) * *n], n, &wr, &wi, x, & + c__2, &scale, &xnorm, &ierr); + +/* Scale X to avoid overflow when updating */ +/* the right-hand side. */ + + if (xnorm > 1.) { +/* Computing MAX */ + d__1 = work[j - 1], d__2 = work[j]; + beta = f2cmax(d__1,d__2); + if (beta > bignum / xnorm) { + rec = 1. / xnorm; + x[0] *= rec; + x[2] *= rec; + x[1] *= rec; + x[3] *= rec; + scale *= rec; + } + } + +/* Scale if necessary */ + + if (scale != 1.) { + dscal_(&ki, &scale, &work[(iv - 1) * *n + 1], & + c__1); + dscal_(&ki, &scale, &work[iv * *n + 1], &c__1); + } + work[j - 1 + (iv - 1) * *n] = x[0]; + work[j + (iv - 1) * *n] = x[1]; + work[j - 1 + iv * *n] = x[2]; + work[j + iv * *n] = x[3]; + +/* Update the right-hand side */ + + i__2 = j - 2; + d__1 = -x[0]; + daxpy_(&i__2, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1, + &work[(iv - 1) * *n + 1], &c__1); + i__2 = j - 2; + d__1 = -x[1]; + daxpy_(&i__2, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + (iv - 1) * *n + 1], &c__1); + i__2 = j - 2; + d__1 = -x[2]; + daxpy_(&i__2, &d__1, &t[(j - 1) * t_dim1 + 1], &c__1, + &work[iv * *n + 1], &c__1); + i__2 = j - 2; + d__1 = -x[3]; + daxpy_(&i__2, &d__1, &t[j * t_dim1 + 1], &c__1, &work[ + iv * *n + 1], &c__1); + } +L90: + ; + } + +/* Copy the vector x or Q*x to VR and normalize. */ + + if (! over) { +/* ------------------------------ */ +/* no back-transform: copy x to VR and normalize. */ + dcopy_(&ki, &work[(iv - 1) * *n + 1], &c__1, &vr[(is - 1) + * vr_dim1 + 1], &c__1); + dcopy_(&ki, &work[iv * *n + 1], &c__1, &vr[is * vr_dim1 + + 1], &c__1); + + emax = 0.; + i__2 = ki; + for (k = 1; k <= i__2; ++k) { +/* Computing MAX */ + d__3 = emax, d__4 = (d__1 = vr[k + (is - 1) * vr_dim1] + , abs(d__1)) + (d__2 = vr[k + is * vr_dim1], + abs(d__2)); + emax = f2cmax(d__3,d__4); +/* L100: */ + } + remax = 1. / emax; + dscal_(&ki, &remax, &vr[(is - 1) * vr_dim1 + 1], &c__1); + dscal_(&ki, &remax, &vr[is * vr_dim1 + 1], &c__1); + + i__2 = *n; + for (k = ki + 1; k <= i__2; ++k) { + vr[k + (is - 1) * vr_dim1] = 0.; + vr[k + is * vr_dim1] = 0.; +/* L110: */ + } + + } else if (nb == 1) { +/* ------------------------------ */ +/* version 1: back-transform each vector with GEMV, Q*x. */ + if (ki > 2) { + i__2 = ki - 2; + dgemv_("N", n, &i__2, &c_b29, &vr[vr_offset], ldvr, & + work[(iv - 1) * *n + 1], &c__1, &work[ki - 1 + + (iv - 1) * *n], &vr[(ki - 1) * vr_dim1 + 1], + &c__1); + i__2 = ki - 2; + dgemv_("N", n, &i__2, &c_b29, &vr[vr_offset], ldvr, & + work[iv * *n + 1], &c__1, &work[ki + iv * *n], + &vr[ki * vr_dim1 + 1], &c__1); + } else { + dscal_(n, &work[ki - 1 + (iv - 1) * *n], &vr[(ki - 1) + * vr_dim1 + 1], &c__1); + dscal_(n, &work[ki + iv * *n], &vr[ki * vr_dim1 + 1], + &c__1); + } + + emax = 0.; + i__2 = *n; + for (k = 1; k <= i__2; ++k) { +/* Computing MAX */ + d__3 = emax, d__4 = (d__1 = vr[k + (ki - 1) * vr_dim1] + , abs(d__1)) + (d__2 = vr[k + ki * vr_dim1], + abs(d__2)); + emax = f2cmax(d__3,d__4); +/* L120: */ + } + remax = 1. / emax; + dscal_(n, &remax, &vr[(ki - 1) * vr_dim1 + 1], &c__1); + dscal_(n, &remax, &vr[ki * vr_dim1 + 1], &c__1); + + } else { +/* ------------------------------ */ +/* version 2: back-transform block of vectors with GEMM */ +/* zero out below vector */ + i__2 = *n; + for (k = ki + 1; k <= i__2; ++k) { + work[k + (iv - 1) * *n] = 0.; + work[k + iv * *n] = 0.; + } + iscomplex[iv - 2] = -ip; + iscomplex[iv - 1] = ip; + --iv; +/* back-transform and normalization is done below */ + } + } + if (nb > 1) { +/* -------------------------------------------------------- */ +/* Blocked version of back-transform */ +/* For complex case, KI2 includes both vectors (KI-1 and KI) */ + if (ip == 0) { + ki2 = ki; + } else { + ki2 = ki - 1; + } +/* Columns IV:NB of work are valid vectors. */ +/* When the number of vectors stored reaches NB-1 or NB, */ +/* or if this was last vector, do the GEMM */ + if (iv <= 2 || ki2 == 1) { + i__2 = nb - iv + 1; + i__3 = ki2 + nb - iv; + dgemm_("N", "N", n, &i__2, &i__3, &c_b29, &vr[vr_offset], + ldvr, &work[iv * *n + 1], n, &c_b17, &work[(nb + + iv) * *n + 1], n); +/* normalize vectors */ + i__2 = nb; + for (k = iv; k <= i__2; ++k) { + if (iscomplex[k - 1] == 0) { +/* real eigenvector */ + ii = idamax_(n, &work[(nb + k) * *n + 1], &c__1); + remax = 1. / (d__1 = work[ii + (nb + k) * *n], + abs(d__1)); + } else if (iscomplex[k - 1] == 1) { +/* first eigenvector of conjugate pair */ + emax = 0.; + i__3 = *n; + for (ii = 1; ii <= i__3; ++ii) { +/* Computing MAX */ + d__3 = emax, d__4 = (d__1 = work[ii + (nb + k) + * *n], abs(d__1)) + (d__2 = work[ii + + (nb + k + 1) * *n], abs(d__2)); + emax = f2cmax(d__3,d__4); + } + remax = 1. / emax; +/* else if ISCOMPLEX(K).EQ.-1 */ +/* second eigenvector of conjugate pair */ +/* reuse same REMAX as previous K */ + } + dscal_(n, &remax, &work[(nb + k) * *n + 1], &c__1); + } + i__2 = nb - iv + 1; + dlacpy_("F", n, &i__2, &work[(nb + iv) * *n + 1], n, &vr[ + ki2 * vr_dim1 + 1], ldvr); + iv = nb; + } else { + --iv; + } + } + +/* blocked back-transform */ + --is; + if (ip != 0) { + --is; + } +L140: + ; + } + } + if (leftv) { + +/* ============================================================ */ +/* Compute left eigenvectors. */ + +/* IV is index of column in current block. */ +/* For complex left vector, uses IV for real part and IV+1 for complex part. */ +/* Non-blocked version always uses IV=1; */ +/* blocked version starts with IV=1, goes up to NB-1 or NB. */ +/* (Note the "0-th" column is used for 1-norms computed above.) */ + iv = 1; + ip = 0; + is = 1; + i__2 = *n; + for (ki = 1; ki <= i__2; ++ki) { + if (ip == 1) { +/* previous iteration (ki-1) was first of conjugate pair, */ +/* so this ki is second of conjugate pair; skip to end of loop */ + ip = -1; + goto L260; + } else if (ki == *n) { +/* last column, so this ki must be real eigenvalue */ + ip = 0; + } else if (t[ki + 1 + ki * t_dim1] == 0.) { +/* zero on sub-diagonal, so this ki is real eigenvalue */ + ip = 0; + } else { +/* non-zero on sub-diagonal, so this ki is first of conjugate pair */ + ip = 1; + } + + if (somev) { + if (! select[ki]) { + goto L260; + } + } + +/* Compute the KI-th eigenvalue (WR,WI). */ + + wr = t[ki + ki * t_dim1]; + wi = 0.; + if (ip != 0) { + wi = sqrt((d__1 = t[ki + (ki + 1) * t_dim1], abs(d__1))) * + sqrt((d__2 = t[ki + 1 + ki * t_dim1], abs(d__2))); + } +/* Computing MAX */ + d__1 = ulp * (abs(wr) + abs(wi)); + smin = f2cmax(d__1,smlnum); + + if (ip == 0) { + +/* -------------------------------------------------------- */ +/* Real left eigenvector */ + + work[ki + iv * *n] = 1.; + +/* Form right-hand side. */ + + i__3 = *n; + for (k = ki + 1; k <= i__3; ++k) { + work[k + iv * *n] = -t[ki + k * t_dim1]; +/* L160: */ + } + +/* Solve transposed quasi-triangular system: */ +/* [ T(KI+1:N,KI+1:N) - WR ]**T * X = SCALE*WORK */ + + vmax = 1.; + vcrit = bignum; + + jnxt = ki + 1; + i__3 = *n; + for (j = ki + 1; j <= i__3; ++j) { + if (j < jnxt) { + goto L170; + } + j1 = j; + j2 = j; + jnxt = j + 1; + if (j < *n) { + if (t[j + 1 + j * t_dim1] != 0.) { + j2 = j + 1; + jnxt = j + 2; + } + } + + if (j1 == j2) { + +/* 1-by-1 diagonal block */ + +/* Scale if necessary to avoid overflow when forming */ +/* the right-hand side. */ + + if (work[j] > vcrit) { + rec = 1. / vmax; + i__4 = *n - ki + 1; + dscal_(&i__4, &rec, &work[ki + iv * *n], &c__1); + vmax = 1.; + vcrit = bignum; + } + + i__4 = j - ki - 1; + work[j + iv * *n] -= ddot_(&i__4, &t[ki + 1 + j * + t_dim1], &c__1, &work[ki + 1 + iv * *n], & + c__1); + +/* Solve [ T(J,J) - WR ]**T * X = WORK */ + + dlaln2_(&c_false, &c__1, &c__1, &smin, &c_b29, &t[j + + j * t_dim1], ldt, &c_b29, &c_b29, &work[j + + iv * *n], n, &wr, &c_b17, x, &c__2, &scale, & + xnorm, &ierr); + +/* Scale if necessary */ + + if (scale != 1.) { + i__4 = *n - ki + 1; + dscal_(&i__4, &scale, &work[ki + iv * *n], &c__1); + } + work[j + iv * *n] = x[0]; +/* Computing MAX */ + d__2 = (d__1 = work[j + iv * *n], abs(d__1)); + vmax = f2cmax(d__2,vmax); + vcrit = bignum / vmax; + + } else { + +/* 2-by-2 diagonal block */ + +/* Scale if necessary to avoid overflow when forming */ +/* the right-hand side. */ + +/* Computing MAX */ + d__1 = work[j], d__2 = work[j + 1]; + beta = f2cmax(d__1,d__2); + if (beta > vcrit) { + rec = 1. / vmax; + i__4 = *n - ki + 1; + dscal_(&i__4, &rec, &work[ki + iv * *n], &c__1); + vmax = 1.; + vcrit = bignum; + } + + i__4 = j - ki - 1; + work[j + iv * *n] -= ddot_(&i__4, &t[ki + 1 + j * + t_dim1], &c__1, &work[ki + 1 + iv * *n], & + c__1); + + i__4 = j - ki - 1; + work[j + 1 + iv * *n] -= ddot_(&i__4, &t[ki + 1 + (j + + 1) * t_dim1], &c__1, &work[ki + 1 + iv * *n] + , &c__1); + +/* Solve */ +/* [ T(J,J)-WR T(J,J+1) ]**T * X = SCALE*( WORK1 ) */ +/* [ T(J+1,J) T(J+1,J+1)-WR ] ( WORK2 ) */ + + dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b29, &t[j + + j * t_dim1], ldt, &c_b29, &c_b29, &work[j + + iv * *n], n, &wr, &c_b17, x, &c__2, &scale, & + xnorm, &ierr); + +/* Scale if necessary */ + + if (scale != 1.) { + i__4 = *n - ki + 1; + dscal_(&i__4, &scale, &work[ki + iv * *n], &c__1); + } + work[j + iv * *n] = x[0]; + work[j + 1 + iv * *n] = x[1]; + +/* Computing MAX */ + d__3 = (d__1 = work[j + iv * *n], abs(d__1)), d__4 = ( + d__2 = work[j + 1 + iv * *n], abs(d__2)), + d__3 = f2cmax(d__3,d__4); + vmax = f2cmax(d__3,vmax); + vcrit = bignum / vmax; + + } +L170: + ; + } + +/* Copy the vector x or Q*x to VL and normalize. */ + + if (! over) { +/* ------------------------------ */ +/* no back-transform: copy x to VL and normalize. */ + i__3 = *n - ki + 1; + dcopy_(&i__3, &work[ki + iv * *n], &c__1, &vl[ki + is * + vl_dim1], &c__1); + + i__3 = *n - ki + 1; + ii = idamax_(&i__3, &vl[ki + is * vl_dim1], &c__1) + ki - + 1; + remax = 1. / (d__1 = vl[ii + is * vl_dim1], abs(d__1)); + i__3 = *n - ki + 1; + dscal_(&i__3, &remax, &vl[ki + is * vl_dim1], &c__1); + + i__3 = ki - 1; + for (k = 1; k <= i__3; ++k) { + vl[k + is * vl_dim1] = 0.; +/* L180: */ + } + + } else if (nb == 1) { +/* ------------------------------ */ +/* version 1: back-transform each vector with GEMV, Q*x. */ + if (ki < *n) { + i__3 = *n - ki; + dgemv_("N", n, &i__3, &c_b29, &vl[(ki + 1) * vl_dim1 + + 1], ldvl, &work[ki + 1 + iv * *n], &c__1, & + work[ki + iv * *n], &vl[ki * vl_dim1 + 1], & + c__1); + } + + ii = idamax_(n, &vl[ki * vl_dim1 + 1], &c__1); + remax = 1. / (d__1 = vl[ii + ki * vl_dim1], abs(d__1)); + dscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1); + + } else { +/* ------------------------------ */ +/* version 2: back-transform block of vectors with GEMM */ +/* zero out above vector */ +/* could go from KI-NV+1 to KI-1 */ + i__3 = ki - 1; + for (k = 1; k <= i__3; ++k) { + work[k + iv * *n] = 0.; + } + iscomplex[iv - 1] = ip; +/* back-transform and normalization is done below */ + } + } else { + +/* -------------------------------------------------------- */ +/* Complex left eigenvector. */ + +/* Initial solve: */ +/* [ ( T(KI,KI) T(KI,KI+1) )**T - (WR - I* WI) ]*X = 0. */ +/* [ ( T(KI+1,KI) T(KI+1,KI+1) ) ] */ + + if ((d__1 = t[ki + (ki + 1) * t_dim1], abs(d__1)) >= (d__2 = + t[ki + 1 + ki * t_dim1], abs(d__2))) { + work[ki + iv * *n] = wi / t[ki + (ki + 1) * t_dim1]; + work[ki + 1 + (iv + 1) * *n] = 1.; + } else { + work[ki + iv * *n] = 1.; + work[ki + 1 + (iv + 1) * *n] = -wi / t[ki + 1 + ki * + t_dim1]; + } + work[ki + 1 + iv * *n] = 0.; + work[ki + (iv + 1) * *n] = 0.; + +/* Form right-hand side. */ + + i__3 = *n; + for (k = ki + 2; k <= i__3; ++k) { + work[k + iv * *n] = -work[ki + iv * *n] * t[ki + k * + t_dim1]; + work[k + (iv + 1) * *n] = -work[ki + 1 + (iv + 1) * *n] * + t[ki + 1 + k * t_dim1]; +/* L190: */ + } + +/* Solve transposed quasi-triangular system: */ +/* [ T(KI+2:N,KI+2:N)**T - (WR-i*WI) ]*X = WORK1+i*WORK2 */ + + vmax = 1.; + vcrit = bignum; + + jnxt = ki + 2; + i__3 = *n; + for (j = ki + 2; j <= i__3; ++j) { + if (j < jnxt) { + goto L200; + } + j1 = j; + j2 = j; + jnxt = j + 1; + if (j < *n) { + if (t[j + 1 + j * t_dim1] != 0.) { + j2 = j + 1; + jnxt = j + 2; + } + } + + if (j1 == j2) { + +/* 1-by-1 diagonal block */ + +/* Scale if necessary to avoid overflow when */ +/* forming the right-hand side elements. */ + + if (work[j] > vcrit) { + rec = 1. / vmax; + i__4 = *n - ki + 1; + dscal_(&i__4, &rec, &work[ki + iv * *n], &c__1); + i__4 = *n - ki + 1; + dscal_(&i__4, &rec, &work[ki + (iv + 1) * *n], & + c__1); + vmax = 1.; + vcrit = bignum; + } + + i__4 = j - ki - 2; + work[j + iv * *n] -= ddot_(&i__4, &t[ki + 2 + j * + t_dim1], &c__1, &work[ki + 2 + iv * *n], & + c__1); + i__4 = j - ki - 2; + work[j + (iv + 1) * *n] -= ddot_(&i__4, &t[ki + 2 + j + * t_dim1], &c__1, &work[ki + 2 + (iv + 1) * * + n], &c__1); + +/* Solve [ T(J,J)-(WR-i*WI) ]*(X11+i*X12)= WK+I*WK2 */ + + d__1 = -wi; + dlaln2_(&c_false, &c__1, &c__2, &smin, &c_b29, &t[j + + j * t_dim1], ldt, &c_b29, &c_b29, &work[j + + iv * *n], n, &wr, &d__1, x, &c__2, &scale, & + xnorm, &ierr); + +/* Scale if necessary */ + + if (scale != 1.) { + i__4 = *n - ki + 1; + dscal_(&i__4, &scale, &work[ki + iv * *n], &c__1); + i__4 = *n - ki + 1; + dscal_(&i__4, &scale, &work[ki + (iv + 1) * *n], & + c__1); + } + work[j + iv * *n] = x[0]; + work[j + (iv + 1) * *n] = x[2]; +/* Computing MAX */ + d__3 = (d__1 = work[j + iv * *n], abs(d__1)), d__4 = ( + d__2 = work[j + (iv + 1) * *n], abs(d__2)), + d__3 = f2cmax(d__3,d__4); + vmax = f2cmax(d__3,vmax); + vcrit = bignum / vmax; + + } else { + +/* 2-by-2 diagonal block */ + +/* Scale if necessary to avoid overflow when forming */ +/* the right-hand side elements. */ + +/* Computing MAX */ + d__1 = work[j], d__2 = work[j + 1]; + beta = f2cmax(d__1,d__2); + if (beta > vcrit) { + rec = 1. / vmax; + i__4 = *n - ki + 1; + dscal_(&i__4, &rec, &work[ki + iv * *n], &c__1); + i__4 = *n - ki + 1; + dscal_(&i__4, &rec, &work[ki + (iv + 1) * *n], & + c__1); + vmax = 1.; + vcrit = bignum; + } + + i__4 = j - ki - 2; + work[j + iv * *n] -= ddot_(&i__4, &t[ki + 2 + j * + t_dim1], &c__1, &work[ki + 2 + iv * *n], & + c__1); + + i__4 = j - ki - 2; + work[j + (iv + 1) * *n] -= ddot_(&i__4, &t[ki + 2 + j + * t_dim1], &c__1, &work[ki + 2 + (iv + 1) * * + n], &c__1); + + i__4 = j - ki - 2; + work[j + 1 + iv * *n] -= ddot_(&i__4, &t[ki + 2 + (j + + 1) * t_dim1], &c__1, &work[ki + 2 + iv * *n] + , &c__1); + + i__4 = j - ki - 2; + work[j + 1 + (iv + 1) * *n] -= ddot_(&i__4, &t[ki + 2 + + (j + 1) * t_dim1], &c__1, &work[ki + 2 + ( + iv + 1) * *n], &c__1); + +/* Solve 2-by-2 complex linear equation */ +/* [ (T(j,j) T(j,j+1) )**T - (wr-i*wi)*I ]*X = SCALE*B */ +/* [ (T(j+1,j) T(j+1,j+1)) ] */ + + d__1 = -wi; + dlaln2_(&c_true, &c__2, &c__2, &smin, &c_b29, &t[j + + j * t_dim1], ldt, &c_b29, &c_b29, &work[j + + iv * *n], n, &wr, &d__1, x, &c__2, &scale, & + xnorm, &ierr); + +/* Scale if necessary */ + + if (scale != 1.) { + i__4 = *n - ki + 1; + dscal_(&i__4, &scale, &work[ki + iv * *n], &c__1); + i__4 = *n - ki + 1; + dscal_(&i__4, &scale, &work[ki + (iv + 1) * *n], & + c__1); + } + work[j + iv * *n] = x[0]; + work[j + (iv + 1) * *n] = x[2]; + work[j + 1 + iv * *n] = x[1]; + work[j + 1 + (iv + 1) * *n] = x[3]; +/* Computing MAX */ + d__1 = abs(x[0]), d__2 = abs(x[2]), d__1 = f2cmax(d__1, + d__2), d__2 = abs(x[1]), d__1 = f2cmax(d__1,d__2) + , d__2 = abs(x[3]), d__1 = f2cmax(d__1,d__2); + vmax = f2cmax(d__1,vmax); + vcrit = bignum / vmax; + + } +L200: + ; + } + +/* Copy the vector x or Q*x to VL and normalize. */ + + if (! over) { +/* ------------------------------ */ +/* no back-transform: copy x to VL and normalize. */ + i__3 = *n - ki + 1; + dcopy_(&i__3, &work[ki + iv * *n], &c__1, &vl[ki + is * + vl_dim1], &c__1); + i__3 = *n - ki + 1; + dcopy_(&i__3, &work[ki + (iv + 1) * *n], &c__1, &vl[ki + ( + is + 1) * vl_dim1], &c__1); + + emax = 0.; + i__3 = *n; + for (k = ki; k <= i__3; ++k) { +/* Computing MAX */ + d__3 = emax, d__4 = (d__1 = vl[k + is * vl_dim1], abs( + d__1)) + (d__2 = vl[k + (is + 1) * vl_dim1], + abs(d__2)); + emax = f2cmax(d__3,d__4); +/* L220: */ + } + remax = 1. / emax; + i__3 = *n - ki + 1; + dscal_(&i__3, &remax, &vl[ki + is * vl_dim1], &c__1); + i__3 = *n - ki + 1; + dscal_(&i__3, &remax, &vl[ki + (is + 1) * vl_dim1], &c__1) + ; + + i__3 = ki - 1; + for (k = 1; k <= i__3; ++k) { + vl[k + is * vl_dim1] = 0.; + vl[k + (is + 1) * vl_dim1] = 0.; +/* L230: */ + } + + } else if (nb == 1) { +/* ------------------------------ */ +/* version 1: back-transform each vector with GEMV, Q*x. */ + if (ki < *n - 1) { + i__3 = *n - ki - 1; + dgemv_("N", n, &i__3, &c_b29, &vl[(ki + 2) * vl_dim1 + + 1], ldvl, &work[ki + 2 + iv * *n], &c__1, & + work[ki + iv * *n], &vl[ki * vl_dim1 + 1], & + c__1); + i__3 = *n - ki - 1; + dgemv_("N", n, &i__3, &c_b29, &vl[(ki + 2) * vl_dim1 + + 1], ldvl, &work[ki + 2 + (iv + 1) * *n], & + c__1, &work[ki + 1 + (iv + 1) * *n], &vl[(ki + + 1) * vl_dim1 + 1], &c__1); + } else { + dscal_(n, &work[ki + iv * *n], &vl[ki * vl_dim1 + 1], + &c__1); + dscal_(n, &work[ki + 1 + (iv + 1) * *n], &vl[(ki + 1) + * vl_dim1 + 1], &c__1); + } + + emax = 0.; + i__3 = *n; + for (k = 1; k <= i__3; ++k) { +/* Computing MAX */ + d__3 = emax, d__4 = (d__1 = vl[k + ki * vl_dim1], abs( + d__1)) + (d__2 = vl[k + (ki + 1) * vl_dim1], + abs(d__2)); + emax = f2cmax(d__3,d__4); +/* L240: */ + } + remax = 1. / emax; + dscal_(n, &remax, &vl[ki * vl_dim1 + 1], &c__1); + dscal_(n, &remax, &vl[(ki + 1) * vl_dim1 + 1], &c__1); + + } else { +/* ------------------------------ */ +/* version 2: back-transform block of vectors with GEMM */ +/* zero out above vector */ +/* could go from KI-NV+1 to KI-1 */ + i__3 = ki - 1; + for (k = 1; k <= i__3; ++k) { + work[k + iv * *n] = 0.; + work[k + (iv + 1) * *n] = 0.; + } + iscomplex[iv - 1] = ip; + iscomplex[iv] = -ip; + ++iv; +/* back-transform and normalization is done below */ + } + } + if (nb > 1) { +/* -------------------------------------------------------- */ +/* Blocked version of back-transform */ +/* For complex case, KI2 includes both vectors (KI and KI+1) */ + if (ip == 0) { + ki2 = ki; + } else { + ki2 = ki + 1; + } +/* Columns 1:IV of work are valid vectors. */ +/* When the number of vectors stored reaches NB-1 or NB, */ +/* or if this was last vector, do the GEMM */ + if (iv >= nb - 1 || ki2 == *n) { + i__3 = *n - ki2 + iv; + dgemm_("N", "N", n, &iv, &i__3, &c_b29, &vl[(ki2 - iv + 1) + * vl_dim1 + 1], ldvl, &work[ki2 - iv + 1 + *n], + n, &c_b17, &work[(nb + 1) * *n + 1], n); +/* normalize vectors */ + i__3 = iv; + for (k = 1; k <= i__3; ++k) { + if (iscomplex[k - 1] == 0) { +/* real eigenvector */ + ii = idamax_(n, &work[(nb + k) * *n + 1], &c__1); + remax = 1. / (d__1 = work[ii + (nb + k) * *n], + abs(d__1)); + } else if (iscomplex[k - 1] == 1) { +/* first eigenvector of conjugate pair */ + emax = 0.; + i__4 = *n; + for (ii = 1; ii <= i__4; ++ii) { +/* Computing MAX */ + d__3 = emax, d__4 = (d__1 = work[ii + (nb + k) + * *n], abs(d__1)) + (d__2 = work[ii + + (nb + k + 1) * *n], abs(d__2)); + emax = f2cmax(d__3,d__4); + } + remax = 1. / emax; +/* else if ISCOMPLEX(K).EQ.-1 */ +/* second eigenvector of conjugate pair */ +/* reuse same REMAX as previous K */ + } + dscal_(n, &remax, &work[(nb + k) * *n + 1], &c__1); + } + dlacpy_("F", n, &iv, &work[(nb + 1) * *n + 1], n, &vl[( + ki2 - iv + 1) * vl_dim1 + 1], ldvl); + iv = 1; + } else { + ++iv; + } + } + +/* blocked back-transform */ + ++is; + if (ip != 0) { + ++is; + } +L260: + ; + } + } + + return 0; + +/* End of DTREVC3 */ + +} /* dtrevc3_ */ + diff --git a/lapack-netlib/SRC/dtrexc.c b/lapack-netlib/SRC/dtrexc.c new file mode 100644 index 000000000..eb6be188e --- /dev/null +++ b/lapack-netlib/SRC/dtrexc.c @@ -0,0 +1,844 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTREXC */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTREXC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK, */ +/* INFO ) */ + +/* CHARACTER COMPQ */ +/* INTEGER IFST, ILST, INFO, LDQ, LDT, N */ +/* DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTREXC reorders the real Schur factorization of a real matrix */ +/* > A = Q*T*Q**T, so that the diagonal block of T with row index IFST is */ +/* > moved to row ILST. */ +/* > */ +/* > The real Schur form T is reordered by an orthogonal similarity */ +/* > transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors */ +/* > is updated by postmultiplying it with Z. */ +/* > */ +/* > T must be in Schur canonical form (as returned by DHSEQR), that is, */ +/* > block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */ +/* > 2-by-2 diagonal block has its diagonal elements equal and its */ +/* > off-diagonal elements of opposite sign. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] COMPQ */ +/* > \verbatim */ +/* > COMPQ is CHARACTER*1 */ +/* > = 'V': update the matrix Q of Schur vectors; */ +/* > = 'N': do not update Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix T. N >= 0. */ +/* > If N == 0 arguments ILST and IFST may be any value. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] T */ +/* > \verbatim */ +/* > T is DOUBLE PRECISION array, dimension (LDT,N) */ +/* > On entry, the upper quasi-triangular matrix T, in Schur */ +/* > Schur canonical form. */ +/* > On exit, the reordered upper quasi-triangular matrix, again */ +/* > in Schur canonical form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is DOUBLE PRECISION array, dimension (LDQ,N) */ +/* > On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */ +/* > On exit, if COMPQ = 'V', Q has been postmultiplied by the */ +/* > orthogonal transformation matrix Z which reorders T. */ +/* > If COMPQ = 'N', Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= 1, and if */ +/* > COMPQ = 'V', LDQ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] IFST */ +/* > \verbatim */ +/* > IFST is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ILST */ +/* > \verbatim */ +/* > ILST is INTEGER */ +/* > */ +/* > Specify the reordering of the diagonal blocks of T. */ +/* > The block with row index IFST is moved to row ILST, by a */ +/* > sequence of transpositions between adjacent blocks. */ +/* > On exit, if IFST pointed on entry to the second row of a */ +/* > 2-by-2 block, it is changed to point to the first row; ILST */ +/* > always points to the first row of the block in its final */ +/* > position (which may differ from its input value by +1 or -1). */ +/* > 1 <= IFST <= N; 1 <= ILST <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > = 1: two adjacent blocks were too close to swap (the problem */ +/* > is very ill-conditioned); T may have been partially */ +/* > reordered, and ILST points to the first row of the */ +/* > current position of the block being moved. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dtrexc_(char *compq, integer *n, doublereal *t, integer * + ldt, doublereal *q, integer *ldq, integer *ifst, integer *ilst, + doublereal *work, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, t_dim1, t_offset, i__1; + + /* Local variables */ + integer here; + extern logical lsame_(char *, char *); + logical wantq; + extern /* Subroutine */ int dlaexc_(logical *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *, integer *, integer + *, doublereal *, integer *), xerbla_(char *, integer *, ftnlen); + integer nbnext, nbf, nbl; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and test the input arguments. */ + + /* Parameter adjustments */ + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --work; + + /* Function Body */ + *info = 0; + wantq = lsame_(compq, "V"); + if (! wantq && ! lsame_(compq, "N")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ldt < f2cmax(1,*n)) { + *info = -4; + } else if (*ldq < 1 || wantq && *ldq < f2cmax(1,*n)) { + *info = -6; + } else if ((*ifst < 1 || *ifst > *n) && *n > 0) { + *info = -7; + } else if ((*ilst < 1 || *ilst > *n) && *n > 0) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTREXC", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 1) { + return 0; + } + +/* Determine the first row of specified block */ +/* and find out it is 1 by 1 or 2 by 2. */ + + if (*ifst > 1) { + if (t[*ifst + (*ifst - 1) * t_dim1] != 0.) { + --(*ifst); + } + } + nbf = 1; + if (*ifst < *n) { + if (t[*ifst + 1 + *ifst * t_dim1] != 0.) { + nbf = 2; + } + } + +/* Determine the first row of the final block */ +/* and find out it is 1 by 1 or 2 by 2. */ + + if (*ilst > 1) { + if (t[*ilst + (*ilst - 1) * t_dim1] != 0.) { + --(*ilst); + } + } + nbl = 1; + if (*ilst < *n) { + if (t[*ilst + 1 + *ilst * t_dim1] != 0.) { + nbl = 2; + } + } + + if (*ifst == *ilst) { + return 0; + } + + if (*ifst < *ilst) { + +/* Update ILST */ + + if (nbf == 2 && nbl == 1) { + --(*ilst); + } + if (nbf == 1 && nbl == 2) { + ++(*ilst); + } + + here = *ifst; + +L10: + +/* Swap block with next one below */ + + if (nbf == 1 || nbf == 2) { + +/* Current block either 1 by 1 or 2 by 2 */ + + nbnext = 1; + if (here + nbf + 1 <= *n) { + if (t[here + nbf + 1 + (here + nbf) * t_dim1] != 0.) { + nbnext = 2; + } + } + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &here, & + nbf, &nbnext, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + here += nbnext; + +/* Test if 2 by 2 block breaks into two 1 by 1 blocks */ + + if (nbf == 2) { + if (t[here + 1 + here * t_dim1] == 0.) { + nbf = 3; + } + } + + } else { + +/* Current block consists of two 1 by 1 blocks each of which */ +/* must be swapped individually */ + + nbnext = 1; + if (here + 3 <= *n) { + if (t[here + 3 + (here + 2) * t_dim1] != 0.) { + nbnext = 2; + } + } + i__1 = here + 1; + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, & + c__1, &nbnext, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + if (nbnext == 1) { + +/* Swap two 1 by 1 blocks, no problems possible */ + + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + here, &c__1, &nbnext, &work[1], info); + ++here; + } else { + +/* Recompute NBNEXT in case 2 by 2 split */ + + if (t[here + 2 + (here + 1) * t_dim1] == 0.) { + nbnext = 1; + } + if (nbnext == 2) { + +/* 2 by 2 Block did not split */ + + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + here, &c__1, &nbnext, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + here += 2; + } else { + +/* 2 by 2 Block did split */ + + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + here, &c__1, &c__1, &work[1], info); + i__1 = here + 1; + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + i__1, &c__1, &c__1, &work[1], info); + here += 2; + } + } + } + if (here < *ilst) { + goto L10; + } + + } else { + + here = *ifst; +L20: + +/* Swap block with next one above */ + + if (nbf == 1 || nbf == 2) { + +/* Current block either 1 by 1 or 2 by 2 */ + + nbnext = 1; + if (here >= 3) { + if (t[here - 1 + (here - 2) * t_dim1] != 0.) { + nbnext = 2; + } + } + i__1 = here - nbnext; + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, & + nbnext, &nbf, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + here -= nbnext; + +/* Test if 2 by 2 block breaks into two 1 by 1 blocks */ + + if (nbf == 2) { + if (t[here + 1 + here * t_dim1] == 0.) { + nbf = 3; + } + } + + } else { + +/* Current block consists of two 1 by 1 blocks each of which */ +/* must be swapped individually */ + + nbnext = 1; + if (here >= 3) { + if (t[here - 1 + (here - 2) * t_dim1] != 0.) { + nbnext = 2; + } + } + i__1 = here - nbnext; + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, &i__1, & + nbnext, &c__1, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + if (nbnext == 1) { + +/* Swap two 1 by 1 blocks, no problems possible */ + + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + here, &nbnext, &c__1, &work[1], info); + --here; + } else { + +/* Recompute NBNEXT in case 2 by 2 split */ + + if (t[here + (here - 1) * t_dim1] == 0.) { + nbnext = 1; + } + if (nbnext == 2) { + +/* 2 by 2 Block did not split */ + + i__1 = here - 1; + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + i__1, &c__2, &c__1, &work[1], info); + if (*info != 0) { + *ilst = here; + return 0; + } + here += -2; + } else { + +/* 2 by 2 Block did split */ + + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + here, &c__1, &c__1, &work[1], info); + i__1 = here - 1; + dlaexc_(&wantq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + i__1, &c__1, &c__1, &work[1], info); + here += -2; + } + } + } + if (here > *ilst) { + goto L20; + } + } + *ilst = here; + + return 0; + +/* End of DTREXC */ + +} /* dtrexc_ */ + diff --git a/lapack-netlib/SRC/dtrrfs.c b/lapack-netlib/SRC/dtrrfs.c new file mode 100644 index 000000000..8daad6ded --- /dev/null +++ b/lapack-netlib/SRC/dtrrfs.c @@ -0,0 +1,946 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTRRFS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTRRFS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X, */ +/* LDX, FERR, BERR, WORK, IWORK, INFO ) */ + +/* CHARACTER DIAG, TRANS, UPLO */ +/* INTEGER INFO, LDA, LDB, LDX, N, NRHS */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ), */ +/* $ WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTRRFS provides error bounds and backward error estimates for the */ +/* > solution to a system of linear equations with a triangular */ +/* > coefficient matrix. */ +/* > */ +/* > The solution matrix X must be computed by DTRTRS or some other */ +/* > means before entering this routine. DTRRFS does not do iterative */ +/* > refinement because doing so cannot improve the backward error. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > The triangular matrix A. If UPLO = 'U', the leading N-by-N */ +/* > upper triangular part of the array A contains the upper */ +/* > triangular matrix, and the strictly lower triangular part of */ +/* > A is not referenced. If UPLO = 'L', the leading N-by-N lower */ +/* > triangular part of the array A contains the lower triangular */ +/* > matrix, and the strictly upper triangular part of A is not */ +/* > referenced. If DIAG = 'U', the diagonal elements of A are */ +/* > also not referenced and are assumed to be 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > The right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is DOUBLE PRECISION array, dimension (LDX,NRHS) */ +/* > The solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dtrrfs_(char *uplo, char *trans, char *diag, integer *n, + integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer * + ldb, doublereal *x, integer *ldx, doublereal *ferr, doublereal *berr, + doublereal *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1, i__2, + i__3; + doublereal d__1, d__2, d__3; + + /* Local variables */ + integer kase; + doublereal safe1, safe2; + integer i__, j, k; + doublereal s; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *), daxpy_(integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *); + logical upper; + extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *, + doublereal *, integer *, doublereal *, integer *), dtrsv_(char *, char *, char *, integer *, doublereal *, + integer *, doublereal *, integer *), + dlacn2_(integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, integer *); + extern doublereal dlamch_(char *); + doublereal xk; + integer nz; + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical notran; + char transt[1]; + logical nounit; + doublereal lstres, eps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + notran = lsame_(trans, "N"); + nounit = lsame_(diag, "N"); + + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*lda < f2cmax(1,*n)) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } else if (*ldx < f2cmax(1,*n)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTRRFS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.; + berr[j] = 0.; +/* L10: */ + } + return 0; + } + + if (notran) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + + nz = *n + 1; + eps = dlamch_("Epsilon"); + safmin = dlamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Compute residual R = B - op(A) * X, */ +/* where op(A) = A or A**T, depending on TRANS. */ + + dcopy_(n, &x[j * x_dim1 + 1], &c__1, &work[*n + 1], &c__1); + dtrmv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1], &c__1); + daxpy_(n, &c_b19, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* f2cmax(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] = (d__1 = b[i__ + j * b_dim1], abs(d__1)); +/* L20: */ + } + + if (notran) { + +/* Compute abs(A)*abs(X) + abs(B). */ + + if (upper) { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = k; + for (i__ = 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = a[i__ + k * a_dim1], abs( + d__1)) * xk; +/* L30: */ + } +/* L40: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = a[i__ + k * a_dim1], abs( + d__1)) * xk; +/* L50: */ + } + work[k] += xk; +/* L60: */ + } + } + } else { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = *n; + for (i__ = k; i__ <= i__3; ++i__) { + work[i__] += (d__1 = a[i__ + k * a_dim1], abs( + d__1)) * xk; +/* L70: */ + } +/* L80: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + xk = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + work[i__] += (d__1 = a[i__ + k * a_dim1], abs( + d__1)) * xk; +/* L90: */ + } + work[k] += xk; +/* L100: */ + } + } + } + } else { + +/* Compute abs(A**T)*abs(X) + abs(B). */ + + if (upper) { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + i__3 = k; + for (i__ = 1; i__ <= i__3; ++i__) { + s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * ( + d__2 = x[i__ + j * x_dim1], abs(d__2)); +/* L110: */ + } + work[k] += s; +/* L120: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * ( + d__2 = x[i__ + j * x_dim1], abs(d__2)); +/* L130: */ + } + work[k] += s; +/* L140: */ + } + } + } else { + if (nounit) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + i__3 = *n; + for (i__ = k; i__ <= i__3; ++i__) { + s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * ( + d__2 = x[i__ + j * x_dim1], abs(d__2)); +/* L150: */ + } + work[k] += s; +/* L160: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = (d__1 = x[k + j * x_dim1], abs(d__1)); + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + s += (d__1 = a[i__ + k * a_dim1], abs(d__1)) * ( + d__2 = x[i__ + j * x_dim1], abs(d__2)); +/* L170: */ + } + work[k] += s; +/* L180: */ + } + } + } + } + s = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + d__2 = s, d__3 = (d__1 = work[*n + i__], abs(d__1)) / work[ + i__]; + s = f2cmax(d__2,d__3); + } else { +/* Computing MAX */ + d__2 = s, d__3 = ((d__1 = work[*n + i__], abs(d__1)) + safe1) + / (work[i__] + safe1); + s = f2cmax(d__2,d__3); + } +/* L190: */ + } + berr[j] = s; + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(op(A)))* */ +/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(op(A)) is the inverse of op(A) */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ + +/* Use DLACN2 to estimate the infinity-norm of the matrix */ +/* inv(op(A)) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (d__1 = work[*n + i__], abs(d__1)) + nz * eps * + work[i__] + safe1; + } +/* L200: */ + } + + kase = 0; +L210: + dlacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & + kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(op(A)**T). */ + + dtrsv_(uplo, transt, diag, n, &a[a_offset], lda, &work[*n + 1] + , &c__1); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L220: */ + } + } else { + +/* Multiply by inv(op(A))*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] = work[i__] * work[*n + i__]; +/* L230: */ + } + dtrsv_(uplo, trans, diag, n, &a[a_offset], lda, &work[*n + 1], + &c__1); + } + goto L210; + } + +/* Normalize error. */ + + lstres = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + d__2 = lstres, d__3 = (d__1 = x[i__ + j * x_dim1], abs(d__1)); + lstres = f2cmax(d__2,d__3); +/* L240: */ + } + if (lstres != 0.) { + ferr[j] /= lstres; + } + +/* L250: */ + } + + return 0; + +/* End of DTRRFS */ + +} /* dtrrfs_ */ + diff --git a/lapack-netlib/SRC/dtrsen.c b/lapack-netlib/SRC/dtrsen.c new file mode 100644 index 000000000..d8e940c90 --- /dev/null +++ b/lapack-netlib/SRC/dtrsen.c @@ -0,0 +1,997 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTRSEN */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTRSEN + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI, */ +/* M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO ) */ + +/* CHARACTER COMPQ, JOB */ +/* INTEGER INFO, LDQ, LDT, LIWORK, LWORK, M, N */ +/* DOUBLE PRECISION S, SEP */ +/* LOGICAL SELECT( * ) */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ), */ +/* $ WR( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTRSEN reorders the real Schur factorization of a real matrix */ +/* > A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in */ +/* > the leading diagonal blocks of the upper quasi-triangular matrix T, */ +/* > and the leading columns of Q form an orthonormal basis of the */ +/* > corresponding right invariant subspace. */ +/* > */ +/* > Optionally the routine computes the reciprocal condition numbers of */ +/* > the cluster of eigenvalues and/or the invariant subspace. */ +/* > */ +/* > T must be in Schur canonical form (as returned by DHSEQR), that is, */ +/* > block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */ +/* > 2-by-2 diagonal block has its diagonal elements equal and its */ +/* > off-diagonal elements of opposite sign. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOB */ +/* > \verbatim */ +/* > JOB is CHARACTER*1 */ +/* > Specifies whether condition numbers are required for the */ +/* > cluster of eigenvalues (S) or the invariant subspace (SEP): */ +/* > = 'N': none; */ +/* > = 'E': for eigenvalues only (S); */ +/* > = 'V': for invariant subspace only (SEP); */ +/* > = 'B': for both eigenvalues and invariant subspace (S and */ +/* > SEP). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COMPQ */ +/* > \verbatim */ +/* > COMPQ is CHARACTER*1 */ +/* > = 'V': update the matrix Q of Schur vectors; */ +/* > = 'N': do not update Q. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > SELECT specifies the eigenvalues in the selected cluster. To */ +/* > select a real eigenvalue w(j), SELECT(j) must be set to */ +/* > .TRUE.. To select a complex conjugate pair of eigenvalues */ +/* > w(j) and w(j+1), corresponding to a 2-by-2 diagonal block, */ +/* > either SELECT(j) or SELECT(j+1) or both must be set to */ +/* > .TRUE.; a complex conjugate pair of eigenvalues must be */ +/* > either both included in the cluster or both excluded. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix T. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] T */ +/* > \verbatim */ +/* > T is DOUBLE PRECISION array, dimension (LDT,N) */ +/* > On entry, the upper quasi-triangular matrix T, in Schur */ +/* > canonical form. */ +/* > On exit, T is overwritten by the reordered matrix T, again in */ +/* > Schur canonical form, with the selected eigenvalues in the */ +/* > leading diagonal blocks. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is DOUBLE PRECISION array, dimension (LDQ,N) */ +/* > On entry, if COMPQ = 'V', the matrix Q of Schur vectors. */ +/* > On exit, if COMPQ = 'V', Q has been postmultiplied by the */ +/* > orthogonal transformation matrix which reorders T; the */ +/* > leading M columns of Q form an orthonormal basis for the */ +/* > specified invariant subspace. */ +/* > If COMPQ = 'N', Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. */ +/* > LDQ >= 1; and if COMPQ = 'V', LDQ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WR */ +/* > \verbatim */ +/* > WR is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > \param[out] WI */ +/* > \verbatim */ +/* > WI is DOUBLE PRECISION array, dimension (N) */ +/* > */ +/* > The real and imaginary parts, respectively, of the reordered */ +/* > eigenvalues of T. The eigenvalues are stored in the same */ +/* > order as on the diagonal of T, with WR(i) = T(i,i) and, if */ +/* > T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and */ +/* > WI(i+1) = -WI(i). Note that if a complex eigenvalue is */ +/* > sufficiently ill-conditioned, then its value may differ */ +/* > significantly from its value before reordering. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The dimension of the specified invariant subspace. */ +/* > 0 < = M <= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is DOUBLE PRECISION */ +/* > If JOB = 'E' or 'B', S is a lower bound on the reciprocal */ +/* > condition number for the selected cluster of eigenvalues. */ +/* > S cannot underestimate the true reciprocal condition number */ +/* > by more than a factor of sqrt(N). If M = 0 or N, S = 1. */ +/* > If JOB = 'N' or 'V', S is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SEP */ +/* > \verbatim */ +/* > SEP is DOUBLE PRECISION */ +/* > If JOB = 'V' or 'B', SEP is the estimated reciprocal */ +/* > condition number of the specified invariant subspace. If */ +/* > M = 0 or N, SEP = norm(T). */ +/* > If JOB = 'N' or 'E', SEP is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > If JOB = 'N', LWORK >= f2cmax(1,N); */ +/* > if JOB = 'E', LWORK >= f2cmax(1,M*(N-M)); */ +/* > if JOB = 'V' or 'B', LWORK >= f2cmax(1,2*M*(N-M)). */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */ +/* > On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the array IWORK. */ +/* > If JOB = 'N' or 'E', LIWORK >= 1; */ +/* > if JOB = 'V' or 'B', LIWORK >= f2cmax(1,M*(N-M)). */ +/* > */ +/* > If LIWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal size of the IWORK array, */ +/* > returns this value as the first entry of the IWORK array, and */ +/* > no error message related to LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > = 1: reordering of T failed because some eigenvalues are too */ +/* > close to separate (the problem is very ill-conditioned); */ +/* > T may have been partially reordered, and WR and WI */ +/* > contain the eigenvalues in the same order as in T; S and */ +/* > SEP (if requested) are set to zero. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTRSEN first collects the selected eigenvalues by computing an */ +/* > orthogonal transformation Z to move them to the top left corner of T. */ +/* > In other words, the selected eigenvalues are the eigenvalues of T11 */ +/* > in: */ +/* > */ +/* > Z**T * T * Z = ( T11 T12 ) n1 */ +/* > ( 0 T22 ) n2 */ +/* > n1 n2 */ +/* > */ +/* > where N = n1+n2 and Z**T means the transpose of Z. The first n1 columns */ +/* > of Z span the specified invariant subspace of T. */ +/* > */ +/* > If T has been obtained from the real Schur factorization of a matrix */ +/* > A = Q*T*Q**T, then the reordered real Schur factorization of A is given */ +/* > by A = (Q*Z)*(Z**T*T*Z)*(Q*Z)**T, and the first n1 columns of Q*Z span */ +/* > the corresponding invariant subspace of A. */ +/* > */ +/* > The reciprocal condition number of the average of the eigenvalues of */ +/* > T11 may be returned in S. S lies between 0 (very badly conditioned) */ +/* > and 1 (very well conditioned). It is computed as follows. First we */ +/* > compute R so that */ +/* > */ +/* > P = ( I R ) n1 */ +/* > ( 0 0 ) n2 */ +/* > n1 n2 */ +/* > */ +/* > is the projector on the invariant subspace associated with T11. */ +/* > R is the solution of the Sylvester equation: */ +/* > */ +/* > T11*R - R*T22 = T12. */ +/* > */ +/* > Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote */ +/* > the two-norm of M. Then S is computed as the lower bound */ +/* > */ +/* > (1 + F-norm(R)**2)**(-1/2) */ +/* > */ +/* > on the reciprocal of 2-norm(P), the true reciprocal condition number. */ +/* > S cannot underestimate 1 / 2-norm(P) by more than a factor of */ +/* > sqrt(N). */ +/* > */ +/* > An approximate error bound for the computed average of the */ +/* > eigenvalues of T11 is */ +/* > */ +/* > EPS * norm(T) / S */ +/* > */ +/* > where EPS is the machine precision. */ +/* > */ +/* > The reciprocal condition number of the right invariant subspace */ +/* > spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP. */ +/* > SEP is defined as the separation of T11 and T22: */ +/* > */ +/* > sep( T11, T22 ) = sigma-f2cmin( C ) */ +/* > */ +/* > where sigma-f2cmin(C) is the smallest singular value of the */ +/* > n1*n2-by-n1*n2 matrix */ +/* > */ +/* > C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) ) */ +/* > */ +/* > I(m) is an m by m identity matrix, and kprod denotes the Kronecker */ +/* > product. We estimate sigma-f2cmin(C) by the reciprocal of an estimate of */ +/* > the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C) */ +/* > cannot differ from sigma-f2cmin(C) by more than a factor of sqrt(n1*n2). */ +/* > */ +/* > When SEP is small, small changes in T can cause large changes in */ +/* > the invariant subspace. An approximate bound on the maximum angular */ +/* > error in the computed right invariant subspace is */ +/* > */ +/* > EPS * norm(T) / SEP */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtrsen_(char *job, char *compq, logical *select, integer + *n, doublereal *t, integer *ldt, doublereal *q, integer *ldq, + doublereal *wr, doublereal *wi, integer *m, doublereal *s, doublereal + *sep, doublereal *work, integer *lwork, integer *iwork, integer * + liwork, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, t_dim1, t_offset, i__1, i__2; + doublereal d__1, d__2; + + /* Local variables */ + integer kase; + logical pair; + integer ierr; + logical swap; + integer k; + doublereal scale; + extern logical lsame_(char *, char *); + integer isave[3], lwmin; + logical wantq, wants; + doublereal rnorm; + integer n1, n2; + extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + integer kk; + extern doublereal dlange_(char *, integer *, integer *, doublereal *, + integer *, doublereal *); + integer nn, ks; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen); + logical wantbh; + extern /* Subroutine */ int dtrexc_(char *, integer *, doublereal *, + integer *, doublereal *, integer *, integer *, integer *, + doublereal *, integer *); + integer liwmin; + logical wantsp, lquery; + extern /* Subroutine */ int dtrsyl_(char *, char *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *); + doublereal est; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + --select; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + --wr; + --wi; + --work; + --iwork; + + /* Function Body */ + wantbh = lsame_(job, "B"); + wants = lsame_(job, "E") || wantbh; + wantsp = lsame_(job, "V") || wantbh; + wantq = lsame_(compq, "V"); + + *info = 0; + lquery = *lwork == -1; + if (! lsame_(job, "N") && ! wants && ! wantsp) { + *info = -1; + } else if (! lsame_(compq, "N") && ! wantq) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*ldt < f2cmax(1,*n)) { + *info = -6; + } else if (*ldq < 1 || wantq && *ldq < *n) { + *info = -8; + } else { + +/* Set M to the dimension of the specified invariant subspace, */ +/* and test LWORK and LIWORK. */ + + *m = 0; + pair = FALSE_; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = FALSE_; + } else { + if (k < *n) { + if (t[k + 1 + k * t_dim1] == 0.) { + if (select[k]) { + ++(*m); + } + } else { + pair = TRUE_; + if (select[k] || select[k + 1]) { + *m += 2; + } + } + } else { + if (select[*n]) { + ++(*m); + } + } + } +/* L10: */ + } + + n1 = *m; + n2 = *n - *m; + nn = n1 * n2; + + if (wantsp) { +/* Computing MAX */ + i__1 = 1, i__2 = nn << 1; + lwmin = f2cmax(i__1,i__2); + liwmin = f2cmax(1,nn); + } else if (lsame_(job, "N")) { + lwmin = f2cmax(1,*n); + liwmin = 1; + } else if (lsame_(job, "E")) { + lwmin = f2cmax(1,nn); + liwmin = 1; + } + + if (*lwork < lwmin && ! lquery) { + *info = -15; + } else if (*liwork < liwmin && ! lquery) { + *info = -17; + } + } + + if (*info == 0) { + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTRSEN", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible. */ + + if (*m == *n || *m == 0) { + if (wants) { + *s = 1.; + } + if (wantsp) { + *sep = dlange_("1", n, n, &t[t_offset], ldt, &work[1]); + } + goto L40; + } + +/* Collect the selected blocks at the top-left corner of T. */ + + ks = 0; + pair = FALSE_; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = FALSE_; + } else { + swap = select[k]; + if (k < *n) { + if (t[k + 1 + k * t_dim1] != 0.) { + pair = TRUE_; + swap = swap || select[k + 1]; + } + } + if (swap) { + ++ks; + +/* Swap the K-th block to position KS. */ + + ierr = 0; + kk = k; + if (k != ks) { + dtrexc_(compq, n, &t[t_offset], ldt, &q[q_offset], ldq, & + kk, &ks, &work[1], &ierr); + } + if (ierr == 1 || ierr == 2) { + +/* Blocks too close to swap: exit. */ + + *info = 1; + if (wants) { + *s = 0.; + } + if (wantsp) { + *sep = 0.; + } + goto L40; + } + if (pair) { + ++ks; + } + } + } +/* L20: */ + } + + if (wants) { + +/* Solve Sylvester equation for R: */ + +/* T11*R - R*T22 = scale*T12 */ + + dlacpy_("F", &n1, &n2, &t[(n1 + 1) * t_dim1 + 1], ldt, &work[1], &n1); + dtrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + 1 + (n1 + + 1) * t_dim1], ldt, &work[1], &n1, &scale, &ierr); + +/* Estimate the reciprocal of the condition number of the cluster */ +/* of eigenvalues. */ + + rnorm = dlange_("F", &n1, &n2, &work[1], &n1, &work[1]); + if (rnorm == 0.) { + *s = 1.; + } else { + *s = scale / (sqrt(scale * scale / rnorm + rnorm) * sqrt(rnorm)); + } + } + + if (wantsp) { + +/* Estimate sep(T11,T22). */ + + est = 0.; + kase = 0; +L30: + dlacn2_(&nn, &work[nn + 1], &work[1], &iwork[1], &est, &kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Solve T11*R - R*T22 = scale*X. */ + + dtrsyl_("N", "N", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + + 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, & + ierr); + } else { + +/* Solve T11**T*R - R*T22**T = scale*X. */ + + dtrsyl_("T", "T", &c_n1, &n1, &n2, &t[t_offset], ldt, &t[n1 + + 1 + (n1 + 1) * t_dim1], ldt, &work[1], &n1, &scale, & + ierr); + } + goto L30; + } + + *sep = scale / est; + } + +L40: + +/* Store the output eigenvalues in WR and WI. */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + wr[k] = t[k + k * t_dim1]; + wi[k] = 0.; +/* L50: */ + } + i__1 = *n - 1; + for (k = 1; k <= i__1; ++k) { + if (t[k + 1 + k * t_dim1] != 0.) { + wi[k] = sqrt((d__1 = t[k + (k + 1) * t_dim1], abs(d__1))) * sqrt(( + d__2 = t[k + 1 + k * t_dim1], abs(d__2))); + wi[k + 1] = -wi[k]; + } +/* L60: */ + } + + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + + return 0; + +/* End of DTRSEN */ + +} /* dtrsen_ */ + diff --git a/lapack-netlib/SRC/dtrsna.c b/lapack-netlib/SRC/dtrsna.c new file mode 100644 index 000000000..5c9349b5e --- /dev/null +++ b/lapack-netlib/SRC/dtrsna.c @@ -0,0 +1,1070 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTRSNA */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTRSNA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR, */ +/* LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK, */ +/* INFO ) */ + +/* CHARACTER HOWMNY, JOB */ +/* INTEGER INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N */ +/* LOGICAL SELECT( * ) */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION S( * ), SEP( * ), T( LDT, * ), VL( LDVL, * ), */ +/* $ VR( LDVR, * ), WORK( LDWORK, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTRSNA estimates reciprocal condition numbers for specified */ +/* > eigenvalues and/or right eigenvectors of a real upper */ +/* > quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q */ +/* > orthogonal). */ +/* > */ +/* > T must be in Schur canonical form (as returned by DHSEQR), that is, */ +/* > block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each */ +/* > 2-by-2 diagonal block has its diagonal elements equal and its */ +/* > off-diagonal elements of opposite sign. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOB */ +/* > \verbatim */ +/* > JOB is CHARACTER*1 */ +/* > Specifies whether condition numbers are required for */ +/* > eigenvalues (S) or eigenvectors (SEP): */ +/* > = 'E': for eigenvalues only (S); */ +/* > = 'V': for eigenvectors only (SEP); */ +/* > = 'B': for both eigenvalues and eigenvectors (S and SEP). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] HOWMNY */ +/* > \verbatim */ +/* > HOWMNY is CHARACTER*1 */ +/* > = 'A': compute condition numbers for all eigenpairs; */ +/* > = 'S': compute condition numbers for selected eigenpairs */ +/* > specified by the array SELECT. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > If HOWMNY = 'S', SELECT specifies the eigenpairs for which */ +/* > condition numbers are required. To select condition numbers */ +/* > for the eigenpair corresponding to a real eigenvalue w(j), */ +/* > SELECT(j) must be set to .TRUE.. To select condition numbers */ +/* > corresponding to a complex conjugate pair of eigenvalues w(j) */ +/* > and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be */ +/* > set to .TRUE.. */ +/* > If HOWMNY = 'A', SELECT is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix T. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] T */ +/* > \verbatim */ +/* > T is DOUBLE PRECISION array, dimension (LDT,N) */ +/* > The upper quasi-triangular matrix T, in Schur canonical form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VL */ +/* > \verbatim */ +/* > VL is DOUBLE PRECISION array, dimension (LDVL,M) */ +/* > If JOB = 'E' or 'B', VL must contain left eigenvectors of T */ +/* > (or of any Q*T*Q**T with Q orthogonal), corresponding to the */ +/* > eigenpairs specified by HOWMNY and SELECT. The eigenvectors */ +/* > must be stored in consecutive columns of VL, as returned by */ +/* > DHSEIN or DTREVC. */ +/* > If JOB = 'V', VL is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the array VL. */ +/* > LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VR */ +/* > \verbatim */ +/* > VR is DOUBLE PRECISION array, dimension (LDVR,M) */ +/* > If JOB = 'E' or 'B', VR must contain right eigenvectors of T */ +/* > (or of any Q*T*Q**T with Q orthogonal), corresponding to the */ +/* > eigenpairs specified by HOWMNY and SELECT. The eigenvectors */ +/* > must be stored in consecutive columns of VR, as returned by */ +/* > DHSEIN or DTREVC. */ +/* > If JOB = 'V', VR is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the array VR. */ +/* > LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is DOUBLE PRECISION array, dimension (MM) */ +/* > If JOB = 'E' or 'B', the reciprocal condition numbers of the */ +/* > selected eigenvalues, stored in consecutive elements of the */ +/* > array. For a complex conjugate pair of eigenvalues two */ +/* > consecutive elements of S are set to the same value. Thus */ +/* > S(j), SEP(j), and the j-th columns of VL and VR all */ +/* > correspond to the same eigenpair (but not in general the */ +/* > j-th eigenpair, unless all eigenpairs are selected). */ +/* > If JOB = 'V', S is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SEP */ +/* > \verbatim */ +/* > SEP is DOUBLE PRECISION array, dimension (MM) */ +/* > If JOB = 'V' or 'B', the estimated reciprocal condition */ +/* > numbers of the selected eigenvectors, stored in consecutive */ +/* > elements of the array. For a complex eigenvector two */ +/* > consecutive elements of SEP are set to the same value. If */ +/* > the eigenvalues cannot be reordered to compute SEP(j), SEP(j) */ +/* > is set to 0; this can only occur when the true value would be */ +/* > very small anyway. */ +/* > If JOB = 'E', SEP is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] MM */ +/* > \verbatim */ +/* > MM is INTEGER */ +/* > The number of elements in the arrays S (if JOB = 'E' or 'B') */ +/* > and/or SEP (if JOB = 'V' or 'B'). MM >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of elements of the arrays S and/or SEP actually */ +/* > used to store the estimated condition numbers. */ +/* > If HOWMNY = 'A', M is set to N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (LDWORK,N+6) */ +/* > If JOB = 'E', WORK is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDWORK */ +/* > \verbatim */ +/* > LDWORK is INTEGER */ +/* > The leading dimension of the array WORK. */ +/* > LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (2*(N-1)) */ +/* > If JOB = 'E', IWORK is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The reciprocal of the condition number of an eigenvalue lambda is */ +/* > defined as */ +/* > */ +/* > S(lambda) = |v**T*u| / (norm(u)*norm(v)) */ +/* > */ +/* > where u and v are the right and left eigenvectors of T corresponding */ +/* > to lambda; v**T denotes the transpose of v, and norm(u) */ +/* > denotes the Euclidean norm. These reciprocal condition numbers always */ +/* > lie between zero (very badly conditioned) and one (very well */ +/* > conditioned). If n = 1, S(lambda) is defined to be 1. */ +/* > */ +/* > An approximate error bound for a computed eigenvalue W(i) is given by */ +/* > */ +/* > EPS * norm(T) / S(i) */ +/* > */ +/* > where EPS is the machine precision. */ +/* > */ +/* > The reciprocal of the condition number of the right eigenvector u */ +/* > corresponding to lambda is defined as follows. Suppose */ +/* > */ +/* > T = ( lambda c ) */ +/* > ( 0 T22 ) */ +/* > */ +/* > Then the reciprocal condition number is */ +/* > */ +/* > SEP( lambda, T22 ) = sigma-f2cmin( T22 - lambda*I ) */ +/* > */ +/* > where sigma-f2cmin denotes the smallest singular value. We approximate */ +/* > the smallest singular value by the reciprocal of an estimate of the */ +/* > one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is */ +/* > defined to be abs(T(1,1)). */ +/* > */ +/* > An approximate error bound for a computed right eigenvector VR(i) */ +/* > is given by */ +/* > */ +/* > EPS * norm(T) / SEP(i) */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtrsna_(char *job, char *howmny, logical *select, + integer *n, doublereal *t, integer *ldt, doublereal *vl, integer * + ldvl, doublereal *vr, integer *ldvr, doublereal *s, doublereal *sep, + integer *mm, integer *m, doublereal *work, integer *ldwork, integer * + iwork, integer *info) +{ + /* System generated locals */ + integer t_dim1, t_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, + work_dim1, work_offset, i__1, i__2; + doublereal d__1, d__2; + + /* Local variables */ + integer kase; + doublereal cond; + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + logical pair; + integer ierr; + doublereal dumm, prod; + integer ifst; + doublereal lnrm; + integer ilst; + doublereal rnrm; + extern doublereal dnrm2_(integer *, doublereal *, integer *); + doublereal prod1, prod2; + integer i__, j, k; + doublereal scale, delta; + extern logical lsame_(char *, char *); + integer isave[3]; + logical wants; + doublereal dummy[1]; + integer n2; + extern /* Subroutine */ int dlacn2_(integer *, doublereal *, doublereal *, + integer *, doublereal *, integer *, integer *); + extern doublereal dlapy2_(doublereal *, doublereal *); + extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); + doublereal cs; + extern doublereal dlamch_(char *); + integer nn, ks; + doublereal sn, mu; + extern /* Subroutine */ int dlacpy_(char *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *), + xerbla_(char *, integer *, ftnlen); + doublereal bignum; + logical wantbh; + extern /* Subroutine */ int dlaqtr_(logical *, logical *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, integer *), dtrexc_(char *, integer * + , doublereal *, integer *, doublereal *, integer *, integer *, + integer *, doublereal *, integer *); + logical somcon; + doublereal smlnum; + logical wantsp; + doublereal eps, est; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + +/* Decode and test the input parameters */ + + /* Parameter adjustments */ + --select; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --s; + --sep; + work_dim1 = *ldwork; + work_offset = 1 + work_dim1 * 1; + work -= work_offset; + --iwork; + + /* Function Body */ + wantbh = lsame_(job, "B"); + wants = lsame_(job, "E") || wantbh; + wantsp = lsame_(job, "V") || wantbh; + + somcon = lsame_(howmny, "S"); + + *info = 0; + if (! wants && ! wantsp) { + *info = -1; + } else if (! lsame_(howmny, "A") && ! somcon) { + *info = -2; + } else if (*n < 0) { + *info = -4; + } else if (*ldt < f2cmax(1,*n)) { + *info = -6; + } else if (*ldvl < 1 || wants && *ldvl < *n) { + *info = -8; + } else if (*ldvr < 1 || wants && *ldvr < *n) { + *info = -10; + } else { + +/* Set M to the number of eigenpairs for which condition numbers */ +/* are required, and test MM. */ + + if (somcon) { + *m = 0; + pair = FALSE_; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (pair) { + pair = FALSE_; + } else { + if (k < *n) { + if (t[k + 1 + k * t_dim1] == 0.) { + if (select[k]) { + ++(*m); + } + } else { + pair = TRUE_; + if (select[k] || select[k + 1]) { + *m += 2; + } + } + } else { + if (select[*n]) { + ++(*m); + } + } + } +/* L10: */ + } + } else { + *m = *n; + } + + if (*mm < *m) { + *info = -13; + } else if (*ldwork < 1 || wantsp && *ldwork < *n) { + *info = -16; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTRSNA", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (somcon) { + if (! select[1]) { + return 0; + } + } + if (wants) { + s[1] = 1.; + } + if (wantsp) { + sep[1] = (d__1 = t[t_dim1 + 1], abs(d__1)); + } + return 0; + } + +/* Get machine constants */ + + eps = dlamch_("P"); + smlnum = dlamch_("S") / eps; + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + + ks = 0; + pair = FALSE_; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + +/* Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block. */ + + if (pair) { + pair = FALSE_; + goto L60; + } else { + if (k < *n) { + pair = t[k + 1 + k * t_dim1] != 0.; + } + } + +/* Determine whether condition numbers are required for the k-th */ +/* eigenpair. */ + + if (somcon) { + if (pair) { + if (! select[k] && ! select[k + 1]) { + goto L60; + } + } else { + if (! select[k]) { + goto L60; + } + } + } + + ++ks; + + if (wants) { + +/* Compute the reciprocal condition number of the k-th */ +/* eigenvalue. */ + + if (! pair) { + +/* Real eigenvalue. */ + + prod = ddot_(n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks * + vl_dim1 + 1], &c__1); + rnrm = dnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1); + lnrm = dnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1); + s[ks] = abs(prod) / (rnrm * lnrm); + } else { + +/* Complex eigenvalue. */ + + prod1 = ddot_(n, &vr[ks * vr_dim1 + 1], &c__1, &vl[ks * + vl_dim1 + 1], &c__1); + prod1 += ddot_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1, &vl[(ks + + 1) * vl_dim1 + 1], &c__1); + prod2 = ddot_(n, &vl[ks * vl_dim1 + 1], &c__1, &vr[(ks + 1) * + vr_dim1 + 1], &c__1); + prod2 -= ddot_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1, &vr[ks * + vr_dim1 + 1], &c__1); + d__1 = dnrm2_(n, &vr[ks * vr_dim1 + 1], &c__1); + d__2 = dnrm2_(n, &vr[(ks + 1) * vr_dim1 + 1], &c__1); + rnrm = dlapy2_(&d__1, &d__2); + d__1 = dnrm2_(n, &vl[ks * vl_dim1 + 1], &c__1); + d__2 = dnrm2_(n, &vl[(ks + 1) * vl_dim1 + 1], &c__1); + lnrm = dlapy2_(&d__1, &d__2); + cond = dlapy2_(&prod1, &prod2) / (rnrm * lnrm); + s[ks] = cond; + s[ks + 1] = cond; + } + } + + if (wantsp) { + +/* Estimate the reciprocal condition number of the k-th */ +/* eigenvector. */ + +/* Copy the matrix T to the array WORK and swap the diagonal */ +/* block beginning at T(k,k) to the (1,1) position. */ + + dlacpy_("Full", n, n, &t[t_offset], ldt, &work[work_offset], + ldwork); + ifst = k; + ilst = 1; + dtrexc_("No Q", n, &work[work_offset], ldwork, dummy, &c__1, & + ifst, &ilst, &work[(*n + 1) * work_dim1 + 1], &ierr); + + if (ierr == 1 || ierr == 2) { + +/* Could not swap because blocks not well separated */ + + scale = 1.; + est = bignum; + } else { + +/* Reordering successful */ + + if (work[work_dim1 + 2] == 0.) { + +/* Form C = T22 - lambda*I in WORK(2:N,2:N). */ + + i__2 = *n; + for (i__ = 2; i__ <= i__2; ++i__) { + work[i__ + i__ * work_dim1] -= work[work_dim1 + 1]; +/* L20: */ + } + n2 = 1; + nn = *n - 1; + } else { + +/* Triangularize the 2 by 2 block by unitary */ +/* transformation U = [ cs i*ss ] */ +/* [ i*ss cs ]. */ +/* such that the (1,1) position of WORK is complex */ +/* eigenvalue lambda with positive imaginary part. (2,2) */ +/* position of WORK is the complex eigenvalue lambda */ +/* with negative imaginary part. */ + + mu = sqrt((d__1 = work[(work_dim1 << 1) + 1], abs(d__1))) + * sqrt((d__2 = work[work_dim1 + 2], abs(d__2))); + delta = dlapy2_(&mu, &work[work_dim1 + 2]); + cs = mu / delta; + sn = -work[work_dim1 + 2] / delta; + +/* Form */ + +/* C**T = WORK(2:N,2:N) + i*[rwork(1) ..... rwork(n-1) ] */ +/* [ mu ] */ +/* [ .. ] */ +/* [ .. ] */ +/* [ mu ] */ +/* where C**T is transpose of matrix C, */ +/* and RWORK is stored starting in the N+1-st column of */ +/* WORK. */ + + i__2 = *n; + for (j = 3; j <= i__2; ++j) { + work[j * work_dim1 + 2] = cs * work[j * work_dim1 + 2] + ; + work[j + j * work_dim1] -= work[work_dim1 + 1]; +/* L30: */ + } + work[(work_dim1 << 1) + 2] = 0.; + + work[(*n + 1) * work_dim1 + 1] = mu * 2.; + i__2 = *n - 1; + for (i__ = 2; i__ <= i__2; ++i__) { + work[i__ + (*n + 1) * work_dim1] = sn * work[(i__ + 1) + * work_dim1 + 1]; +/* L40: */ + } + n2 = 2; + nn = *n - 1 << 1; + } + +/* Estimate norm(inv(C**T)) */ + + est = 0.; + kase = 0; +L50: + dlacn2_(&nn, &work[(*n + 2) * work_dim1 + 1], &work[(*n + 4) * + work_dim1 + 1], &iwork[1], &est, &kase, isave); + if (kase != 0) { + if (kase == 1) { + if (n2 == 1) { + +/* Real eigenvalue: solve C**T*x = scale*c. */ + + i__2 = *n - 1; + dlaqtr_(&c_true, &c_true, &i__2, &work[(work_dim1 + << 1) + 2], ldwork, dummy, &dumm, &scale, + &work[(*n + 4) * work_dim1 + 1], &work[(* + n + 6) * work_dim1 + 1], &ierr); + } else { + +/* Complex eigenvalue: solve */ +/* C**T*(p+iq) = scale*(c+id) in real arithmetic. */ + + i__2 = *n - 1; + dlaqtr_(&c_true, &c_false, &i__2, &work[( + work_dim1 << 1) + 2], ldwork, &work[(*n + + 1) * work_dim1 + 1], &mu, &scale, &work[(* + n + 4) * work_dim1 + 1], &work[(*n + 6) * + work_dim1 + 1], &ierr); + } + } else { + if (n2 == 1) { + +/* Real eigenvalue: solve C*x = scale*c. */ + + i__2 = *n - 1; + dlaqtr_(&c_false, &c_true, &i__2, &work[( + work_dim1 << 1) + 2], ldwork, dummy, & + dumm, &scale, &work[(*n + 4) * work_dim1 + + 1], &work[(*n + 6) * work_dim1 + 1], & + ierr); + } else { + +/* Complex eigenvalue: solve */ +/* C*(p+iq) = scale*(c+id) in real arithmetic. */ + + i__2 = *n - 1; + dlaqtr_(&c_false, &c_false, &i__2, &work[( + work_dim1 << 1) + 2], ldwork, &work[(*n + + 1) * work_dim1 + 1], &mu, &scale, &work[(* + n + 4) * work_dim1 + 1], &work[(*n + 6) * + work_dim1 + 1], &ierr); + + } + } + + goto L50; + } + } + + sep[ks] = scale / f2cmax(est,smlnum); + if (pair) { + sep[ks + 1] = sep[ks]; + } + } + + if (pair) { + ++ks; + } + +L60: + ; + } + return 0; + +/* End of DTRSNA */ + +} /* dtrsna_ */ + diff --git a/lapack-netlib/SRC/dtrsyl.c b/lapack-netlib/SRC/dtrsyl.c new file mode 100644 index 000000000..0dccea7c4 --- /dev/null +++ b/lapack-netlib/SRC/dtrsyl.c @@ -0,0 +1,1763 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTRSYL */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTRSYL + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C, */ +/* LDC, SCALE, INFO ) */ + +/* CHARACTER TRANA, TRANB */ +/* INTEGER INFO, ISGN, LDA, LDB, LDC, M, N */ +/* DOUBLE PRECISION SCALE */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTRSYL solves the real Sylvester matrix equation: */ +/* > */ +/* > op(A)*X + X*op(B) = scale*C or */ +/* > op(A)*X - X*op(B) = scale*C, */ +/* > */ +/* > where op(A) = A or A**T, and A and B are both upper quasi- */ +/* > triangular. A is M-by-M and B is N-by-N; the right hand side C and */ +/* > the solution X are M-by-N; and scale is an output scale factor, set */ +/* > <= 1 to avoid overflow in X. */ +/* > */ +/* > A and B must be in Schur canonical form (as returned by DHSEQR), that */ +/* > is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; */ +/* > each 2-by-2 diagonal block has its diagonal elements equal and its */ +/* > off-diagonal elements of opposite sign. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANA */ +/* > \verbatim */ +/* > TRANA is CHARACTER*1 */ +/* > Specifies the option op(A): */ +/* > = 'N': op(A) = A (No transpose) */ +/* > = 'T': op(A) = A**T (Transpose) */ +/* > = 'C': op(A) = A**H (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANB */ +/* > \verbatim */ +/* > TRANB is CHARACTER*1 */ +/* > Specifies the option op(B): */ +/* > = 'N': op(B) = B (No transpose) */ +/* > = 'T': op(B) = B**T (Transpose) */ +/* > = 'C': op(B) = B**H (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ISGN */ +/* > \verbatim */ +/* > ISGN is INTEGER */ +/* > Specifies the sign in the equation: */ +/* > = +1: solve op(A)*X + X*op(B) = scale*C */ +/* > = -1: solve op(A)*X - X*op(B) = scale*C */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The order of the matrix A, and the number of rows in the */ +/* > matrices X and C. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix B, and the number of columns in the */ +/* > matrices X and C. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,M) */ +/* > The upper quasi-triangular matrix A, in Schur canonical form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,N) */ +/* > The upper quasi-triangular matrix B, in Schur canonical form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (LDC,N) */ +/* > On entry, the M-by-N right hand side matrix C. */ +/* > On exit, C is overwritten by the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. LDC >= f2cmax(1,M) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SCALE */ +/* > \verbatim */ +/* > SCALE is DOUBLE PRECISION */ +/* > The scale factor, scale, set <= 1 to avoid overflow in X. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > = 1: A and B have common or very close eigenvalues; perturbed */ +/* > values were used to solve the equation (but the matrices */ +/* > A and B are unchanged). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleSYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dtrsyl_(char *trana, char *tranb, integer *isgn, integer + *m, integer *n, doublereal *a, integer *lda, doublereal *b, integer * + ldb, doublereal *c__, integer *ldc, doublereal *scale, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, + i__3, i__4; + doublereal d__1, d__2; + + /* Local variables */ + extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, + integer *); + integer ierr; + doublereal smin, suml, sumr; + integer j, k, l; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + doublereal x[4] /* was [2][2] */; + extern logical lsame_(char *, char *); + integer knext, lnext, k1, k2, l1, l2; + doublereal xnorm; + extern /* Subroutine */ int dlaln2_(logical *, integer *, integer *, + doublereal *, doublereal *, doublereal *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, doublereal * + , doublereal *, integer *, doublereal *, doublereal *, integer *), + dlasy2_(logical *, logical *, integer *, integer *, integer *, + doublereal *, integer *, doublereal *, integer *, doublereal *, + integer *, doublereal *, doublereal *, integer *, doublereal *, + integer *); + doublereal a11, db; + extern /* Subroutine */ int dlabad_(doublereal *, doublereal *); + extern doublereal dlamch_(char *), dlange_(char *, integer *, + integer *, doublereal *, integer *, doublereal *); + doublereal scaloc; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal bignum; + logical notrna, notrnb; + doublereal smlnum, da11, vec[4] /* was [2][2] */, dum[1], eps, sgn; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Decode and Test input parameters */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + + /* Function Body */ + notrna = lsame_(trana, "N"); + notrnb = lsame_(tranb, "N"); + + *info = 0; + if (! notrna && ! lsame_(trana, "T") && ! lsame_( + trana, "C")) { + *info = -1; + } else if (! notrnb && ! lsame_(tranb, "T") && ! + lsame_(tranb, "C")) { + *info = -2; + } else if (*isgn != 1 && *isgn != -1) { + *info = -3; + } else if (*m < 0) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else if (*lda < f2cmax(1,*m)) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } else if (*ldc < f2cmax(1,*m)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTRSYL", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + *scale = 1.; + if (*m == 0 || *n == 0) { + return 0; + } + +/* Set constants to control overflow */ + + eps = dlamch_("P"); + smlnum = dlamch_("S"); + bignum = 1. / smlnum; + dlabad_(&smlnum, &bignum); + smlnum = smlnum * (doublereal) (*m * *n) / eps; + bignum = 1. / smlnum; + +/* Computing MAX */ + d__1 = smlnum, d__2 = eps * dlange_("M", m, m, &a[a_offset], lda, dum), d__1 = f2cmax(d__1,d__2), d__2 = eps * dlange_("M", n, n, + &b[b_offset], ldb, dum); + smin = f2cmax(d__1,d__2); + + sgn = (doublereal) (*isgn); + + if (notrna && notrnb) { + +/* Solve A*X + ISGN*X*B = scale*C. */ + +/* The (K,L)th block of X is determined starting from */ +/* bottom-left corner column by column by */ + +/* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */ + +/* Where */ +/* M L-1 */ +/* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)]. */ +/* I=K+1 J=1 */ + +/* Start column loop (index = L) */ +/* L1 (L2) : column index of the first (first) row of X(K,L). */ + + lnext = 1; + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + if (l < lnext) { + goto L60; + } + if (l == *n) { + l1 = l; + l2 = l; + } else { + if (b[l + 1 + l * b_dim1] != 0.) { + l1 = l; + l2 = l + 1; + lnext = l + 2; + } else { + l1 = l; + l2 = l; + lnext = l + 1; + } + } + +/* Start row loop (index = K) */ +/* K1 (K2): row index of the first (last) row of X(K,L). */ + + knext = *m; + for (k = *m; k >= 1; --k) { + if (k > knext) { + goto L50; + } + if (k == 1) { + k1 = k; + k2 = k; + } else { + if (a[k + (k - 1) * a_dim1] != 0.) { + k1 = k - 1; + k2 = k; + knext = k - 2; + } else { + k1 = k; + k2 = k; + knext = k - 1; + } + } + + if (l1 == l2 && k1 == k2) { + i__2 = *m - k1; +/* Computing MIN */ + i__3 = k1 + 1; +/* Computing MIN */ + i__4 = k1 + 1; + suml = ddot_(&i__2, &a[k1 + f2cmin(i__3,*m) * a_dim1], lda, & + c__[f2cmin(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + scaloc = 1.; + + a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; + da11 = abs(a11); + if (da11 <= smin) { + a11 = smin; + da11 = smin; + *info = 1; + } + db = abs(vec[0]); + if (da11 < 1. && db > 1.) { + if (db > bignum * da11) { + scaloc = 1. / db; + } + } + x[0] = vec[0] * scaloc / a11; + + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L10: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + + } else if (l1 == l2 && k1 != k2) { + + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = ddot_(&i__2, &a[k1 + f2cmin(i__3,*m) * a_dim1], lda, & + c__[f2cmin(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = ddot_(&i__2, &a[k2 + f2cmin(i__3,*m) * a_dim1], lda, & + c__[f2cmin(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + d__1 = -sgn * b[l1 + l1 * b_dim1]; + dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 + * a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L20: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k2 + l1 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 == k2) { + + i__2 = *m - k1; +/* Computing MIN */ + i__3 = k1 + 1; +/* Computing MIN */ + i__4 = k1 + 1; + suml = ddot_(&i__2, &a[k1 + f2cmin(i__3,*m) * a_dim1], lda, & + c__[f2cmin(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * + sumr)); + + i__2 = *m - k1; +/* Computing MIN */ + i__3 = k1 + 1; +/* Computing MIN */ + i__4 = k1 + 1; + suml = ddot_(&i__2, &a[k1 + f2cmin(i__3,*m) * a_dim1], lda, & + c__[f2cmin(i__4,*m) + l2 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * + sumr)); + + d__1 = -sgn * a[k1 + k1 * a_dim1]; + dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 * + b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L30: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 != k2) { + + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = ddot_(&i__2, &a[k1 + f2cmin(i__3,*m) * a_dim1], lda, & + c__[f2cmin(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = ddot_(&i__2, &a[k1 + f2cmin(i__3,*m) * a_dim1], lda, & + c__[f2cmin(i__4,*m) + l2 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k1 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); + + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = ddot_(&i__2, &a[k2 + f2cmin(i__3,*m) * a_dim1], lda, & + c__[f2cmin(i__4,*m) + l1 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + i__2 = *m - k2; +/* Computing MIN */ + i__3 = k2 + 1; +/* Computing MIN */ + i__4 = k2 + 1; + suml = ddot_(&i__2, &a[k2 + f2cmin(i__3,*m) * a_dim1], lda, & + c__[f2cmin(i__4,*m) + l2 * c_dim1], &c__1); + i__2 = l1 - 1; + sumr = ddot_(&i__2, &c__[k2 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); + + dlasy2_(&c_false, &c_false, isgn, &c__2, &c__2, &a[k1 + + k1 * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, + &c__2, &scaloc, x, &c__2, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L40: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[2]; + c__[k2 + l1 * c_dim1] = x[1]; + c__[k2 + l2 * c_dim1] = x[3]; + } + +L50: + ; + } + +L60: + ; + } + + } else if (! notrna && notrnb) { + +/* Solve A**T *X + ISGN*X*B = scale*C. */ + +/* The (K,L)th block of X is determined starting from */ +/* upper-left corner column by column by */ + +/* A(K,K)**T*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) */ + +/* Where */ +/* K-1 T L-1 */ +/* R(K,L) = SUM [A(I,K)**T*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)] */ +/* I=1 J=1 */ + +/* Start column loop (index = L) */ +/* L1 (L2): column index of the first (last) row of X(K,L) */ + + lnext = 1; + i__1 = *n; + for (l = 1; l <= i__1; ++l) { + if (l < lnext) { + goto L120; + } + if (l == *n) { + l1 = l; + l2 = l; + } else { + if (b[l + 1 + l * b_dim1] != 0.) { + l1 = l; + l2 = l + 1; + lnext = l + 2; + } else { + l1 = l; + l2 = l; + lnext = l + 1; + } + } + +/* Start row loop (index = K) */ +/* K1 (K2): row index of the first (last) row of X(K,L) */ + + knext = 1; + i__2 = *m; + for (k = 1; k <= i__2; ++k) { + if (k < knext) { + goto L110; + } + if (k == *m) { + k1 = k; + k2 = k; + } else { + if (a[k + 1 + k * a_dim1] != 0.) { + k1 = k; + k2 = k + 1; + knext = k + 2; + } else { + k1 = k; + k2 = k; + knext = k + 1; + } + } + + if (l1 == l2 && k1 == k2) { + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + scaloc = 1.; + + a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; + da11 = abs(a11); + if (da11 <= smin) { + a11 = smin; + da11 = smin; + *info = 1; + } + db = abs(vec[0]); + if (da11 < 1. && db > 1.) { + if (db > bignum * da11) { + scaloc = 1. / db; + } + } + x[0] = vec[0] * scaloc / a11; + + if (scaloc != 1.) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L70: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + + } else if (l1 == l2 && k1 != k2) { + + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + d__1 = -sgn * b[l1 + l1 * b_dim1]; + dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 * + a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L80: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k2 + l1 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 == k2) { + + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * + sumr)); + + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * + sumr)); + + d__1 = -sgn * a[k1 + k1 * a_dim1]; + dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 * + b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L90: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 != k2) { + + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k1 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); + + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l1 * + b_dim1 + 1], &c__1); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + i__3 = k1 - 1; + suml = ddot_(&i__3, &a[k2 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__3 = l1 - 1; + sumr = ddot_(&i__3, &c__[k2 + c_dim1], ldc, &b[l2 * + b_dim1 + 1], &c__1); + vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); + + dlasy2_(&c_true, &c_false, isgn, &c__2, &c__2, &a[k1 + k1 + * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, & + c__2, &scaloc, x, &c__2, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__3 = *n; + for (j = 1; j <= i__3; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L100: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[2]; + c__[k2 + l1 * c_dim1] = x[1]; + c__[k2 + l2 * c_dim1] = x[3]; + } + +L110: + ; + } +L120: + ; + } + + } else if (! notrna && ! notrnb) { + +/* Solve A**T*X + ISGN*X*B**T = scale*C. */ + +/* The (K,L)th block of X is determined starting from */ +/* top-right corner column by column by */ + +/* A(K,K)**T*X(K,L) + ISGN*X(K,L)*B(L,L)**T = C(K,L) - R(K,L) */ + +/* Where */ +/* K-1 N */ +/* R(K,L) = SUM [A(I,K)**T*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)**T]. */ +/* I=1 J=L+1 */ + +/* Start column loop (index = L) */ +/* L1 (L2): column index of the first (last) row of X(K,L) */ + + lnext = *n; + for (l = *n; l >= 1; --l) { + if (l > lnext) { + goto L180; + } + if (l == 1) { + l1 = l; + l2 = l; + } else { + if (b[l + (l - 1) * b_dim1] != 0.) { + l1 = l - 1; + l2 = l; + lnext = l - 2; + } else { + l1 = l; + l2 = l; + lnext = l - 1; + } + } + +/* Start row loop (index = K) */ +/* K1 (K2): row index of the first (last) row of X(K,L) */ + + knext = 1; + i__1 = *m; + for (k = 1; k <= i__1; ++k) { + if (k < knext) { + goto L170; + } + if (k == *m) { + k1 = k; + k2 = k; + } else { + if (a[k + 1 + k * a_dim1] != 0.) { + k1 = k; + k2 = k + 1; + knext = k + 2; + } else { + k1 = k; + k2 = k; + knext = k + 1; + } + } + + if (l1 == l2 && k1 == k2) { + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l1; +/* Computing MIN */ + i__3 = l1 + 1; +/* Computing MIN */ + i__4 = l1 + 1; + sumr = ddot_(&i__2, &c__[k1 + f2cmin(i__3,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__4,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + scaloc = 1.; + + a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; + da11 = abs(a11); + if (da11 <= smin) { + a11 = smin; + da11 = smin; + *info = 1; + } + db = abs(vec[0]); + if (da11 < 1. && db > 1.) { + if (db > bignum * da11) { + scaloc = 1. / db; + } + } + x[0] = vec[0] * scaloc / a11; + + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L130: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + + } else if (l1 == l2 && k1 != k2) { + + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k1 + f2cmin(i__3,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__4,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k2 + f2cmin(i__3,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__4,*n) * b_dim1], ldb); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + d__1 = -sgn * b[l1 + l1 * b_dim1]; + dlaln2_(&c_true, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 * + a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L140: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k2 + l1 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 == k2) { + + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k1 + f2cmin(i__3,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__4,*n) * b_dim1], ldb); + vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * + sumr)); + + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k1 + f2cmin(i__3,*n) * c_dim1], ldc, + &b[l2 + f2cmin(i__4,*n) * b_dim1], ldb); + vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * + sumr)); + + d__1 = -sgn * a[k1 + k1 * a_dim1]; + dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 + * b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L150: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 != k2) { + + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k1 + f2cmin(i__3,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__4,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k1 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k1 + f2cmin(i__3,*n) * c_dim1], ldc, + &b[l2 + f2cmin(i__4,*n) * b_dim1], ldb); + vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); + + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l1 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k2 + f2cmin(i__3,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__4,*n) * b_dim1], ldb); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + i__2 = k1 - 1; + suml = ddot_(&i__2, &a[k2 * a_dim1 + 1], &c__1, &c__[l2 * + c_dim1 + 1], &c__1); + i__2 = *n - l2; +/* Computing MIN */ + i__3 = l2 + 1; +/* Computing MIN */ + i__4 = l2 + 1; + sumr = ddot_(&i__2, &c__[k2 + f2cmin(i__3,*n) * c_dim1], ldc, + &b[l2 + f2cmin(i__4,*n) * b_dim1], ldb); + vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); + + dlasy2_(&c_true, &c_true, isgn, &c__2, &c__2, &a[k1 + k1 * + a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, & + c__2, &scaloc, x, &c__2, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L160: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[2]; + c__[k2 + l1 * c_dim1] = x[1]; + c__[k2 + l2 * c_dim1] = x[3]; + } + +L170: + ; + } +L180: + ; + } + + } else if (notrna && ! notrnb) { + +/* Solve A*X + ISGN*X*B**T = scale*C. */ + +/* The (K,L)th block of X is determined starting from */ +/* bottom-right corner column by column by */ + +/* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L)**T = C(K,L) - R(K,L) */ + +/* Where */ +/* M N */ +/* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)**T]. */ +/* I=K+1 J=L+1 */ + +/* Start column loop (index = L) */ +/* L1 (L2): column index of the first (last) row of X(K,L) */ + + lnext = *n; + for (l = *n; l >= 1; --l) { + if (l > lnext) { + goto L240; + } + if (l == 1) { + l1 = l; + l2 = l; + } else { + if (b[l + (l - 1) * b_dim1] != 0.) { + l1 = l - 1; + l2 = l; + lnext = l - 2; + } else { + l1 = l; + l2 = l; + lnext = l - 1; + } + } + +/* Start row loop (index = K) */ +/* K1 (K2): row index of the first (last) row of X(K,L) */ + + knext = *m; + for (k = *m; k >= 1; --k) { + if (k > knext) { + goto L230; + } + if (k == 1) { + k1 = k; + k2 = k; + } else { + if (a[k + (k - 1) * a_dim1] != 0.) { + k1 = k - 1; + k2 = k; + knext = k - 2; + } else { + k1 = k; + k2 = k; + knext = k - 1; + } + } + + if (l1 == l2 && k1 == k2) { + i__1 = *m - k1; +/* Computing MIN */ + i__2 = k1 + 1; +/* Computing MIN */ + i__3 = k1 + 1; + suml = ddot_(&i__1, &a[k1 + f2cmin(i__2,*m) * a_dim1], lda, & + c__[f2cmin(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l1; +/* Computing MIN */ + i__2 = l1 + 1; +/* Computing MIN */ + i__3 = l1 + 1; + sumr = ddot_(&i__1, &c__[k1 + f2cmin(i__2,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__3,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + scaloc = 1.; + + a11 = a[k1 + k1 * a_dim1] + sgn * b[l1 + l1 * b_dim1]; + da11 = abs(a11); + if (da11 <= smin) { + a11 = smin; + da11 = smin; + *info = 1; + } + db = abs(vec[0]); + if (da11 < 1. && db > 1.) { + if (db > bignum * da11) { + scaloc = 1. / db; + } + } + x[0] = vec[0] * scaloc / a11; + + if (scaloc != 1.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L190: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + + } else if (l1 == l2 && k1 != k2) { + + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = ddot_(&i__1, &a[k1 + f2cmin(i__2,*m) * a_dim1], lda, & + c__[f2cmin(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k1 + f2cmin(i__2,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__3,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = ddot_(&i__1, &a[k2 + f2cmin(i__2,*m) * a_dim1], lda, & + c__[f2cmin(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k2 + f2cmin(i__2,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__3,*n) * b_dim1], ldb); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + d__1 = -sgn * b[l1 + l1 * b_dim1]; + dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &a[k1 + k1 + * a_dim1], lda, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L200: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k2 + l1 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 == k2) { + + i__1 = *m - k1; +/* Computing MIN */ + i__2 = k1 + 1; +/* Computing MIN */ + i__3 = k1 + 1; + suml = ddot_(&i__1, &a[k1 + f2cmin(i__2,*m) * a_dim1], lda, & + c__[f2cmin(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k1 + f2cmin(i__2,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__3,*n) * b_dim1], ldb); + vec[0] = sgn * (c__[k1 + l1 * c_dim1] - (suml + sgn * + sumr)); + + i__1 = *m - k1; +/* Computing MIN */ + i__2 = k1 + 1; +/* Computing MIN */ + i__3 = k1 + 1; + suml = ddot_(&i__1, &a[k1 + f2cmin(i__2,*m) * a_dim1], lda, & + c__[f2cmin(i__3,*m) + l2 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k1 + f2cmin(i__2,*n) * c_dim1], ldc, + &b[l2 + f2cmin(i__3,*n) * b_dim1], ldb); + vec[1] = sgn * (c__[k1 + l2 * c_dim1] - (suml + sgn * + sumr)); + + d__1 = -sgn * a[k1 + k1 * a_dim1]; + dlaln2_(&c_false, &c__2, &c__1, &smin, &c_b26, &b[l1 + l1 + * b_dim1], ldb, &c_b26, &c_b26, vec, &c__2, &d__1, + &c_b30, x, &c__2, &scaloc, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L210: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[1]; + + } else if (l1 != l2 && k1 != k2) { + + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = ddot_(&i__1, &a[k1 + f2cmin(i__2,*m) * a_dim1], lda, & + c__[f2cmin(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k1 + f2cmin(i__2,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__3,*n) * b_dim1], ldb); + vec[0] = c__[k1 + l1 * c_dim1] - (suml + sgn * sumr); + + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = ddot_(&i__1, &a[k1 + f2cmin(i__2,*m) * a_dim1], lda, & + c__[f2cmin(i__3,*m) + l2 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k1 + f2cmin(i__2,*n) * c_dim1], ldc, + &b[l2 + f2cmin(i__3,*n) * b_dim1], ldb); + vec[2] = c__[k1 + l2 * c_dim1] - (suml + sgn * sumr); + + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = ddot_(&i__1, &a[k2 + f2cmin(i__2,*m) * a_dim1], lda, & + c__[f2cmin(i__3,*m) + l1 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k2 + f2cmin(i__2,*n) * c_dim1], ldc, + &b[l1 + f2cmin(i__3,*n) * b_dim1], ldb); + vec[1] = c__[k2 + l1 * c_dim1] - (suml + sgn * sumr); + + i__1 = *m - k2; +/* Computing MIN */ + i__2 = k2 + 1; +/* Computing MIN */ + i__3 = k2 + 1; + suml = ddot_(&i__1, &a[k2 + f2cmin(i__2,*m) * a_dim1], lda, & + c__[f2cmin(i__3,*m) + l2 * c_dim1], &c__1); + i__1 = *n - l2; +/* Computing MIN */ + i__2 = l2 + 1; +/* Computing MIN */ + i__3 = l2 + 1; + sumr = ddot_(&i__1, &c__[k2 + f2cmin(i__2,*n) * c_dim1], ldc, + &b[l2 + f2cmin(i__3,*n) * b_dim1], ldb); + vec[3] = c__[k2 + l2 * c_dim1] - (suml + sgn * sumr); + + dlasy2_(&c_false, &c_true, isgn, &c__2, &c__2, &a[k1 + k1 + * a_dim1], lda, &b[l1 + l1 * b_dim1], ldb, vec, & + c__2, &scaloc, x, &c__2, &xnorm, &ierr); + if (ierr != 0) { + *info = 1; + } + + if (scaloc != 1.) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + dscal_(m, &scaloc, &c__[j * c_dim1 + 1], &c__1); +/* L220: */ + } + *scale *= scaloc; + } + c__[k1 + l1 * c_dim1] = x[0]; + c__[k1 + l2 * c_dim1] = x[2]; + c__[k2 + l1 * c_dim1] = x[1]; + c__[k2 + l2 * c_dim1] = x[3]; + } + +L230: + ; + } +L240: + ; + } + + } + + return 0; + +/* End of DTRSYL */ + +} /* dtrsyl_ */ + diff --git a/lapack-netlib/SRC/dtrti2.c b/lapack-netlib/SRC/dtrti2.c new file mode 100644 index 000000000..15819f673 --- /dev/null +++ b/lapack-netlib/SRC/dtrti2.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 DTRTI2 computes the inverse of a triangular matrix (unblocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTRTI2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO ) */ + +/* CHARACTER DIAG, UPLO */ +/* INTEGER INFO, LDA, N */ +/* DOUBLE PRECISION A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTRTI2 computes the inverse of a real upper or lower triangular */ +/* > matrix. */ +/* > */ +/* > This is the Level 2 BLAS version of the algorithm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the matrix A is upper or lower triangular. */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > Specifies whether or not the matrix A is unit triangular. */ +/* > = 'N': Non-unit triangular */ +/* > = 'U': Unit triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the triangular matrix A. If UPLO = 'U', the */ +/* > leading n by n upper triangular part of the array A contains */ +/* > the upper triangular matrix, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading n by n lower triangular part of the array A contains */ +/* > the lower triangular matrix, and the strictly upper */ +/* > triangular part of A is not referenced. If DIAG = 'U', the */ +/* > diagonal elements of A are also not referenced and are */ +/* > assumed to be 1. */ +/* > */ +/* > On exit, the (triangular) inverse of the original matrix, in */ +/* > the same storage format. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -k, the k-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dtrti2_(char *uplo, char *diag, integer *n, doublereal * + a, integer *lda, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer j; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + extern logical lsame_(char *, char *); + logical upper; + extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *, + doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *, ftnlen); + logical nounit; + doublereal ajj; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + nounit = lsame_(diag, "N"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTRTI2", &i__1, (ftnlen)6); + return 0; + } + + if (upper) { + +/* Compute inverse of upper triangular matrix. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (nounit) { + a[j + j * a_dim1] = 1. / a[j + j * a_dim1]; + ajj = -a[j + j * a_dim1]; + } else { + ajj = -1.; + } + +/* Compute elements 1:j-1 of j-th column. */ + + i__2 = j - 1; + dtrmv_("Upper", "No transpose", diag, &i__2, &a[a_offset], lda, & + a[j * a_dim1 + 1], &c__1); + i__2 = j - 1; + dscal_(&i__2, &ajj, &a[j * a_dim1 + 1], &c__1); +/* L10: */ + } + } else { + +/* Compute inverse of lower triangular matrix. */ + + for (j = *n; j >= 1; --j) { + if (nounit) { + a[j + j * a_dim1] = 1. / a[j + j * a_dim1]; + ajj = -a[j + j * a_dim1]; + } else { + ajj = -1.; + } + if (j < *n) { + +/* Compute elements j+1:n of j-th column. */ + + i__1 = *n - j; + dtrmv_("Lower", "No transpose", diag, &i__1, &a[j + 1 + (j + + 1) * a_dim1], lda, &a[j + 1 + j * a_dim1], &c__1); + i__1 = *n - j; + dscal_(&i__1, &ajj, &a[j + 1 + j * a_dim1], &c__1); + } +/* L20: */ + } + } + + return 0; + +/* End of DTRTI2 */ + +} /* dtrti2_ */ + diff --git a/lapack-netlib/SRC/dtrtri.c b/lapack-netlib/SRC/dtrtri.c new file mode 100644 index 000000000..4ed3d6bf3 --- /dev/null +++ b/lapack-netlib/SRC/dtrtri.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 DTRTRI */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTRTRI + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO ) */ + +/* CHARACTER DIAG, UPLO */ +/* INTEGER INFO, LDA, N */ +/* DOUBLE PRECISION A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTRTRI computes the inverse of a real upper or lower triangular */ +/* > matrix A. */ +/* > */ +/* > This is the Level 3 BLAS version of the algorithm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the triangular matrix A. If UPLO = 'U', the */ +/* > leading N-by-N upper triangular part of the array A contains */ +/* > the upper triangular matrix, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of the array A contains */ +/* > the lower triangular matrix, and the strictly upper */ +/* > triangular part of A is not referenced. If DIAG = 'U', the */ +/* > diagonal elements of A are also not referenced and are */ +/* > assumed to be 1. */ +/* > On exit, the (triangular) inverse of the original matrix, in */ +/* > the same storage format. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, A(i,i) is exactly zero. The triangular */ +/* > matrix is singular and its inverse can not be computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dtrtri_(char *uplo, char *diag, integer *n, doublereal * + a, integer *lda, integer *info) +{ + /* System generated locals */ + address a__1[2]; + integer a_dim1, a_offset, i__1, i__2[2], i__3, i__4, i__5; + char ch__1[2]; + + /* Local variables */ + integer j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *), dtrsm_( + char *, char *, char *, char *, integer *, integer *, doublereal * + , doublereal *, integer *, doublereal *, integer *); + logical upper; + extern /* Subroutine */ int dtrti2_(char *, char *, integer *, doublereal + *, integer *, integer *); + integer jb, nb, nn; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + logical nounit; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + nounit = lsame_(diag, "N"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTRTRI", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check for singularity if non-unit. */ + + if (nounit) { + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (a[*info + *info * a_dim1] == 0.) { + return 0; + } +/* L10: */ + } + *info = 0; + } + +/* Determine the block size for this environment. */ + +/* Writing concatenation */ + i__2[0] = 1, a__1[0] = uplo; + i__2[1] = 1, a__1[1] = diag; + s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2); + nb = ilaenv_(&c__1, "DTRTRI", ch__1, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, ( + ftnlen)2); + if (nb <= 1 || nb >= *n) { + +/* Use unblocked code */ + + dtrti2_(uplo, diag, n, &a[a_offset], lda, info); + } else { + +/* Use blocked code */ + + if (upper) { + +/* Compute inverse of upper triangular matrix */ + + i__1 = *n; + i__3 = nb; + for (j = 1; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) { +/* Computing MIN */ + i__4 = nb, i__5 = *n - j + 1; + jb = f2cmin(i__4,i__5); + +/* Compute rows 1:j-1 of current block column */ + + i__4 = j - 1; + dtrmm_("Left", "Upper", "No transpose", diag, &i__4, &jb, & + c_b18, &a[a_offset], lda, &a[j * a_dim1 + 1], lda); + i__4 = j - 1; + dtrsm_("Right", "Upper", "No transpose", diag, &i__4, &jb, & + c_b22, &a[j + j * a_dim1], lda, &a[j * a_dim1 + 1], + lda); + +/* Compute inverse of current diagonal block */ + + dtrti2_("Upper", diag, &jb, &a[j + j * a_dim1], lda, info); +/* L20: */ + } + } else { + +/* Compute inverse of lower triangular matrix */ + + nn = (*n - 1) / nb * nb + 1; + i__3 = -nb; + for (j = nn; i__3 < 0 ? j >= 1 : j <= 1; j += i__3) { +/* Computing MIN */ + i__1 = nb, i__4 = *n - j + 1; + jb = f2cmin(i__1,i__4); + if (j + jb <= *n) { + +/* Compute rows j+jb:n of current block column */ + + i__1 = *n - j - jb + 1; + dtrmm_("Left", "Lower", "No transpose", diag, &i__1, &jb, + &c_b18, &a[j + jb + (j + jb) * a_dim1], lda, &a[j + + jb + j * a_dim1], lda); + i__1 = *n - j - jb + 1; + dtrsm_("Right", "Lower", "No transpose", diag, &i__1, &jb, + &c_b22, &a[j + j * a_dim1], lda, &a[j + jb + j * + a_dim1], lda); + } + +/* Compute inverse of current diagonal block */ + + dtrti2_("Lower", diag, &jb, &a[j + j * a_dim1], lda, info); +/* L30: */ + } + } + } + + return 0; + +/* End of DTRTRI */ + +} /* dtrtri_ */ + diff --git a/lapack-netlib/SRC/dtrtrs.c b/lapack-netlib/SRC/dtrtrs.c new file mode 100644 index 000000000..3cbe72969 --- /dev/null +++ b/lapack-netlib/SRC/dtrtrs.c @@ -0,0 +1,619 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTRTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTRTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, */ +/* INFO ) */ + +/* CHARACTER DIAG, TRANS, UPLO */ +/* INTEGER INFO, LDA, LDB, N, NRHS */ +/* DOUBLE PRECISION A( LDA, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTRTRS solves a triangular system of the form */ +/* > */ +/* > A * X = B or A**T * X = B, */ +/* > */ +/* > where A is a triangular matrix of order N, and B is an N-by-NRHS */ +/* > matrix. A check is made to verify that A is nonsingular. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular; */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DIAG */ +/* > \verbatim */ +/* > DIAG is CHARACTER*1 */ +/* > = 'N': A is non-unit triangular; */ +/* > = 'U': A is unit triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > The triangular matrix A. If UPLO = 'U', the leading N-by-N */ +/* > upper triangular part of the array A contains the upper */ +/* > triangular matrix, and the strictly lower triangular part of */ +/* > A is not referenced. If UPLO = 'L', the leading N-by-N lower */ +/* > triangular part of the array A contains the lower triangular */ +/* > matrix, and the strictly upper triangular part of A is not */ +/* > referenced. If DIAG = 'U', the diagonal elements of A are */ +/* > also not referenced and are assumed to be 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is DOUBLE PRECISION array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, if INFO = 0, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, the i-th diagonal element of A is zero, */ +/* > indicating that the matrix is singular and the solutions */ +/* > X have not been computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dtrtrs_(char *uplo, char *trans, char *diag, integer *n, + integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer * + ldb, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + extern logical lsame_(char *, char *); + extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, + integer *, integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *), xerbla_(char *, integer *, ftnlen); + logical nounit; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + nounit = lsame_(diag, "N"); + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (! lsame_(trans, "N") && ! lsame_(trans, + "T") && ! lsame_(trans, "C")) { + *info = -2; + } else if (! nounit && ! lsame_(diag, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*lda < f2cmax(1,*n)) { + *info = -7; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTRTRS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check for singularity. */ + + if (nounit) { + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + if (a[*info + *info * a_dim1] == 0.) { + return 0; + } +/* L10: */ + } + } + *info = 0; + +/* Solve A * x = b or A**T * x = b. */ + + dtrsm_("Left", uplo, trans, diag, n, nrhs, &c_b12, &a[a_offset], lda, &b[ + b_offset], ldb); + + return 0; + +/* End of DTRTRS */ + +} /* dtrtrs_ */ + diff --git a/lapack-netlib/SRC/dtrttf.c b/lapack-netlib/SRC/dtrttf.c new file mode 100644 index 000000000..d893444ee --- /dev/null +++ b/lapack-netlib/SRC/dtrttf.c @@ -0,0 +1,916 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTRTTF copies a triangular matrix from the standard full format (TR) to the rectangular full pa +cked format (TF). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTRTTF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTRTTF( TRANSR, UPLO, N, A, LDA, ARF, INFO ) */ + +/* CHARACTER TRANSR, UPLO */ +/* INTEGER INFO, N, LDA */ +/* DOUBLE PRECISION A( 0: LDA-1, 0: * ), ARF( 0: * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTRTTF copies a triangular matrix A from standard full format (TR) */ +/* > to rectangular full packed format (TF) . */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER*1 */ +/* > = 'N': ARF in Normal form is wanted; */ +/* > = 'T': ARF in Transpose form is wanted. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N). */ +/* > On entry, the triangular matrix A. If UPLO = 'U', the */ +/* > leading N-by-N upper triangular part of the array A contains */ +/* > the upper triangular matrix, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of the array A contains */ +/* > the lower triangular matrix, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the matrix A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ARF */ +/* > \verbatim */ +/* > ARF is DOUBLE PRECISION array, dimension (NT). */ +/* > NT=N*(N+1)/2. On exit, the triangular matrix A in RFP format. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > We first consider Rectangular Full Packed (RFP) Format when N is */ +/* > even. We give an example where N = 6. */ +/* > */ +/* > AP is Upper AP is Lower */ +/* > */ +/* > 00 01 02 03 04 05 00 */ +/* > 11 12 13 14 15 10 11 */ +/* > 22 23 24 25 20 21 22 */ +/* > 33 34 35 30 31 32 33 */ +/* > 44 45 40 41 42 43 44 */ +/* > 55 50 51 52 53 54 55 */ +/* > */ +/* > */ +/* > Let TRANSR = 'N'. RFP holds AP as follows: */ +/* > For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last */ +/* > three columns of AP upper. The lower triangle A(4:6,0:2) consists of */ +/* > the transpose of the first three columns of AP upper. */ +/* > For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first */ +/* > three columns of AP lower. The upper triangle A(0:2,0:2) consists of */ +/* > the transpose of the last three columns of AP lower. */ +/* > This covers the case N even and TRANSR = 'N'. */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 03 04 05 33 43 53 */ +/* > 13 14 15 00 44 54 */ +/* > 23 24 25 10 11 55 */ +/* > 33 34 35 20 21 22 */ +/* > 00 44 45 30 31 32 */ +/* > 01 11 55 40 41 42 */ +/* > 02 12 22 50 51 52 */ +/* > */ +/* > Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* > transpose of RFP A above. One therefore gets: */ +/* > */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 03 13 23 33 00 01 02 33 00 10 20 30 40 50 */ +/* > 04 14 24 34 44 11 12 43 44 11 21 31 41 51 */ +/* > 05 15 25 35 45 55 22 53 54 55 22 32 42 52 */ +/* > */ +/* > */ +/* > We then consider Rectangular Full Packed (RFP) Format when N is */ +/* > odd. We give an example where N = 5. */ +/* > */ +/* > AP is Upper AP is Lower */ +/* > */ +/* > 00 01 02 03 04 00 */ +/* > 11 12 13 14 10 11 */ +/* > 22 23 24 20 21 22 */ +/* > 33 34 30 31 32 33 */ +/* > 44 40 41 42 43 44 */ +/* > */ +/* > */ +/* > Let TRANSR = 'N'. RFP holds AP as follows: */ +/* > For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last */ +/* > three columns of AP upper. The lower triangle A(3:4,0:1) consists of */ +/* > the transpose of the first two columns of AP upper. */ +/* > For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first */ +/* > three columns of AP lower. The upper triangle A(0:1,1:2) consists of */ +/* > the transpose of the last two columns of AP lower. */ +/* > This covers the case N odd and TRANSR = 'N'. */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 02 03 04 00 33 43 */ +/* > 12 13 14 10 11 44 */ +/* > 22 23 24 20 21 22 */ +/* > 00 33 34 30 31 32 */ +/* > 01 11 44 40 41 42 */ +/* > */ +/* > Now let TRANSR = 'T'. RFP A in both UPLO cases is just the */ +/* > transpose of RFP A above. One therefore gets: */ +/* > */ +/* > RFP A RFP A */ +/* > */ +/* > 02 12 22 00 01 00 10 20 30 40 50 */ +/* > 03 13 23 33 11 33 11 21 31 41 51 */ +/* > 04 14 24 34 44 43 44 22 32 42 52 */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int dtrttf_(char *transr, char *uplo, integer *n, doublereal + *a, integer *lda, doublereal *arf, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer np1x2, i__, j, k, l; + logical normaltransr; + extern logical lsame_(char *, char *); + logical lower; + integer n1, n2, ij, nt; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical nisodd; + integer nx2; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda - 1 - 0 + 1; + a_offset = 0 + a_dim1 * 0; + a -= a_offset; + + /* Function Body */ + *info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + if (! normaltransr && ! lsame_(transr, "T")) { + *info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTRTTF", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 1) { + if (*n == 1) { + arf[0] = a[0]; + } + return 0; + } + +/* Size of array ARF(0:nt-1) */ + + nt = *n * (*n + 1) / 2; + +/* Set N1 and N2 depending on LOWER: for N even N1=N2=K */ + + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + +/* If N is odd, set NISODD = .TRUE., LDA=N+1 and A is (N+1)--by--K2. */ +/* If N is even, set K = N/2 and NISODD = .FALSE., LDA=N and A is */ +/* N--by--(N+1)/2. */ + + if (*n % 2 == 0) { + k = *n / 2; + nisodd = FALSE_; + if (! lower) { + np1x2 = *n + *n + 2; + } + } else { + nisodd = TRUE_; + if (! lower) { + nx2 = *n + *n; + } + } + + if (nisodd) { + +/* N is odd */ + + if (normaltransr) { + +/* N is odd and TRANSR = 'N' */ + + if (lower) { + +/* N is odd, TRANSR = 'N', and UPLO = 'L' */ + + ij = 0; + i__1 = n2; + for (j = 0; j <= i__1; ++j) { + i__2 = n2 + j; + for (i__ = n1; i__ <= i__2; ++i__) { + arf[ij] = a[n2 + j + i__ * a_dim1]; + ++ij; + } + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + } + + } else { + +/* N is odd, TRANSR = 'N', and UPLO = 'U' */ + + ij = nt - *n; + i__1 = n1; + for (j = *n - 1; j >= i__1; --j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + i__2 = n1 - 1; + for (l = j - n1; l <= i__2; ++l) { + arf[ij] = a[j - n1 + l * a_dim1]; + ++ij; + } + ij -= nx2; + } + + } + + } else { + +/* N is odd and TRANSR = 'T' */ + + if (lower) { + +/* N is odd, TRANSR = 'T', and UPLO = 'L' */ + + ij = 0; + i__1 = n2 - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[j + i__ * a_dim1]; + ++ij; + } + i__2 = *n - 1; + for (i__ = n1 + j; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + (n1 + j) * a_dim1]; + ++ij; + } + } + i__1 = *n - 1; + for (j = n2; j <= i__1; ++j) { + i__2 = n1 - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[j + i__ * a_dim1]; + ++ij; + } + } + + } else { + +/* N is odd, TRANSR = 'T', and UPLO = 'U' */ + + ij = 0; + i__1 = n1; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = n1; i__ <= i__2; ++i__) { + arf[ij] = a[j + i__ * a_dim1]; + ++ij; + } + } + i__1 = n1 - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + i__2 = *n - 1; + for (l = n2 + j; l <= i__2; ++l) { + arf[ij] = a[n2 + j + l * a_dim1]; + ++ij; + } + } + + } + + } + + } else { + +/* N is even */ + + if (normaltransr) { + +/* N is even and TRANSR = 'N' */ + + if (lower) { + +/* N is even, TRANSR = 'N', and UPLO = 'L' */ + + ij = 0; + i__1 = k - 1; + for (j = 0; j <= i__1; ++j) { + i__2 = k + j; + for (i__ = k; i__ <= i__2; ++i__) { + arf[ij] = a[k + j + i__ * a_dim1]; + ++ij; + } + i__2 = *n - 1; + for (i__ = j; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + } + + } else { + +/* N is even, TRANSR = 'N', and UPLO = 'U' */ + + ij = nt - *n - 1; + i__1 = k; + for (j = *n - 1; j >= i__1; --j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + i__2 = k - 1; + for (l = j - k; l <= i__2; ++l) { + arf[ij] = a[j - k + l * a_dim1]; + ++ij; + } + ij -= np1x2; + } + + } + + } else { + +/* N is even and TRANSR = 'T' */ + + if (lower) { + +/* N is even, TRANSR = 'T', and UPLO = 'L' */ + + ij = 0; + j = k; + i__1 = *n - 1; + for (i__ = k; i__ <= i__1; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[j + i__ * a_dim1]; + ++ij; + } + i__2 = *n - 1; + for (i__ = k + 1 + j; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + (k + 1 + j) * a_dim1]; + ++ij; + } + } + i__1 = *n - 1; + for (j = k - 1; j <= i__1; ++j) { + i__2 = k - 1; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[j + i__ * a_dim1]; + ++ij; + } + } + + } else { + +/* N is even, TRANSR = 'T', and UPLO = 'U' */ + + ij = 0; + i__1 = k; + for (j = 0; j <= i__1; ++j) { + i__2 = *n - 1; + for (i__ = k; i__ <= i__2; ++i__) { + arf[ij] = a[j + i__ * a_dim1]; + ++ij; + } + } + i__1 = k - 2; + for (j = 0; j <= i__1; ++j) { + i__2 = j; + for (i__ = 0; i__ <= i__2; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + i__2 = *n - 1; + for (l = k + 1 + j; l <= i__2; ++l) { + arf[ij] = a[k + 1 + j + l * a_dim1]; + ++ij; + } + } +/* Note that here, on exit of the loop, J = K-1 */ + i__1 = j; + for (i__ = 0; i__ <= i__1; ++i__) { + arf[ij] = a[i__ + j * a_dim1]; + ++ij; + } + + } + + } + + } + + return 0; + +/* End of DTRTTF */ + +} /* dtrttf_ */ + diff --git a/lapack-netlib/SRC/dtrttp.c b/lapack-netlib/SRC/dtrttp.c new file mode 100644 index 000000000..9a8aa7326 --- /dev/null +++ b/lapack-netlib/SRC/dtrttp.c @@ -0,0 +1,567 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DTRTTP copies a triangular matrix from the standard full format (TR) to the standard packed for +mat (TP). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTRTTP + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTRTTP( UPLO, N, A, LDA, AP, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N, LDA */ +/* DOUBLE PRECISION A( LDA, * ), AP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTRTTP copies a triangular matrix A from full format (TR) to standard */ +/* > packed format (TP). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': A is upper triangular. */ +/* > = 'L': A is lower triangular. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices AP and A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On exit, the triangular matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] AP */ +/* > \verbatim */ +/* > AP is DOUBLE PRECISION array, dimension (N*(N+1)/2) */ +/* > On exit, the upper or lower triangular matrix A, packed */ +/* > columnwise in a linear array. The j-th column of A is stored */ +/* > in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int dtrttp_(char *uplo, integer *n, doublereal *a, integer * + lda, doublereal *ap, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + integer i__, j, k; + extern logical lsame_(char *, char *); + logical lower; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ap; + + /* Function Body */ + *info = 0; + lower = lsame_(uplo, "L"); + if (! lower && ! lsame_(uplo, "U")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTRTTP", &i__1, (ftnlen)6); + return 0; + } + + if (lower) { + k = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + ++k; + ap[k] = a[i__ + j * a_dim1]; + } + } + } else { + k = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { + ++k; + ap[k] = a[i__ + j * a_dim1]; + } + } + } + + + return 0; + +/* End of DTRTTP */ + +} /* dtrttp_ */ + diff --git a/lapack-netlib/SRC/dtzrzf.c b/lapack-netlib/SRC/dtzrzf.c new file mode 100644 index 000000000..c145e0ff9 --- /dev/null +++ b/lapack-netlib/SRC/dtzrzf.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 DTZRZF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DTZRZF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO ) */ + +/* INTEGER INFO, LDA, LWORK, M, N */ +/* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DTZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A */ +/* > to upper triangular form by means of orthogonal transformations. */ +/* > */ +/* > The upper trapezoidal matrix A is factored as */ +/* > */ +/* > A = ( R 0 ) * Z, */ +/* > */ +/* > where Z is an N-by-N orthogonal matrix and R is an M-by-M upper */ +/* > triangular matrix. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > On entry, the leading M-by-N upper trapezoidal part of the */ +/* > array A must contain the matrix to be factorized. */ +/* > On exit, the leading M-by-M upper triangular part of A */ +/* > contains the upper triangular matrix R, and elements M+1 to */ +/* > N of the first M rows of A, with the array TAU, represent the */ +/* > orthogonal matrix Z as a product of M elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is DOUBLE PRECISION array, dimension (M) */ +/* > The scalar factors of the elementary reflectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,M). */ +/* > For optimum performance LWORK >= M*NB, where NB is */ +/* > the optimal blocksize. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup doubleOTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The N-by-N matrix Z can be computed by */ +/* > */ +/* > Z = Z(1)*Z(2)* ... *Z(M) */ +/* > */ +/* > where each N-by-N Z(k) is given by */ +/* > */ +/* > Z(k) = I - tau(k)*v(k)*v(k)**T */ +/* > */ +/* > with v(k) is the kth row vector of the M-by-N matrix */ +/* > */ +/* > V = ( I A(:,M+1:N) ) */ +/* > */ +/* > I is the M-by-M identity matrix, A(:,M+1:N) */ +/* > is the output stored in A on exit from DTZRZF, */ +/* > and tau(k) is the kth element of the array TAU. */ +/* > */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int dtzrzf_(integer *m, integer *n, doublereal *a, integer * + lda, doublereal *tau, doublereal *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5; + + /* Local variables */ + integer i__, nbmin, m1, ib, nb, ki, kk, mu, nx; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), dlarzb_( + char *, char *, char *, char *, integer *, integer *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, integer *); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int dlarzt_(char *, char *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, integer *); + integer lwkmin, ldwork; + extern /* Subroutine */ int dlatrz_(integer *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *); + integer lwkopt; + logical lquery; + integer iws; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tau; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + if (*m < 0) { + *info = -1; + } else if (*n < *m) { + *info = -2; + } else if (*lda < f2cmax(1,*m)) { + *info = -4; + } + + if (*info == 0) { + if (*m == 0 || *m == *n) { + lwkopt = 1; + lwkmin = 1; + } else { + +/* Determine the block size. */ + + nb = ilaenv_(&c__1, "DGERQF", " ", m, n, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); + lwkopt = *m * nb; + lwkmin = f2cmax(1,*m); + } + work[1] = (doublereal) lwkopt; + + if (*lwork < lwkmin && ! lquery) { + *info = -7; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DTZRZF", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*m == 0) { + return 0; + } else if (*m == *n) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tau[i__] = 0.; +/* L10: */ + } + return 0; + } + + nbmin = 2; + nx = 1; + iws = *m; + if (nb > 1 && nb < *m) { + +/* Determine when to cross over from blocked to unblocked code. */ + +/* Computing MAX */ + i__1 = 0, i__2 = ilaenv_(&c__3, "DGERQF", " ", m, n, &c_n1, &c_n1, ( + ftnlen)6, (ftnlen)1); + nx = f2cmax(i__1,i__2); + if (nx < *m) { + +/* Determine if workspace is large enough for blocked code. */ + + ldwork = *m; + iws = ldwork * nb; + if (*lwork < iws) { + +/* Not enough workspace to use optimal NB: reduce NB and */ +/* determine the minimum value of NB. */ + + nb = *lwork / ldwork; +/* Computing MAX */ + i__1 = 2, i__2 = ilaenv_(&c__2, "DGERQF", " ", m, n, &c_n1, & + c_n1, (ftnlen)6, (ftnlen)1); + nbmin = f2cmax(i__1,i__2); + } + } + } + + if (nb >= nbmin && nb < *m && nx < *m) { + +/* Use blocked code initially. */ +/* The last kk rows are handled by the block method. */ + +/* Computing MIN */ + i__1 = *m + 1; + m1 = f2cmin(i__1,*n); + ki = (*m - nx - 1) / nb * nb; +/* Computing MIN */ + i__1 = *m, i__2 = ki + nb; + kk = f2cmin(i__1,i__2); + + i__1 = *m - kk + 1; + i__2 = -nb; + for (i__ = *m - kk + ki + 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; + i__ += i__2) { +/* Computing MIN */ + i__3 = *m - i__ + 1; + ib = f2cmin(i__3,nb); + +/* Compute the TZ factorization of the current block */ +/* A(i:i+ib-1,i:n) */ + + i__3 = *n - i__ + 1; + i__4 = *n - *m; + dlatrz_(&ib, &i__3, &i__4, &a[i__ + i__ * a_dim1], lda, &tau[i__], + &work[1]); + if (i__ > 1) { + +/* Form the triangular factor of the block reflector */ +/* H = H(i+ib-1) . . . H(i+1) H(i) */ + + i__3 = *n - *m; + dlarzt_("Backward", "Rowwise", &i__3, &ib, &a[i__ + m1 * + a_dim1], lda, &tau[i__], &work[1], &ldwork); + +/* Apply H to A(1:i-1,i:n) from the right */ + + i__3 = i__ - 1; + i__4 = *n - i__ + 1; + i__5 = *n - *m; + dlarzb_("Right", "No transpose", "Backward", "Rowwise", &i__3, + &i__4, &ib, &i__5, &a[i__ + m1 * a_dim1], lda, &work[ + 1], &ldwork, &a[i__ * a_dim1 + 1], lda, &work[ib + 1], + &ldwork) + ; + } +/* L20: */ + } + mu = i__ + nb - 1; + } else { + mu = *m; + } + +/* Use unblocked code to factor the last or only block */ + + if (mu > 0) { + i__2 = *n - *m; + dlatrz_(&mu, n, &i__2, &a[a_offset], lda, &tau[1], &work[1]); + } + + work[1] = (doublereal) lwkopt; + + return 0; + +/* End of DTZRZF */ + +} /* dtzrzf_ */ + diff --git a/lapack-netlib/SRC/dzsum1.c b/lapack-netlib/SRC/dzsum1.c new file mode 100644 index 000000000..8fccf6ca7 --- /dev/null +++ b/lapack-netlib/SRC/dzsum1.c @@ -0,0 +1,534 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b DZSUM1 forms the 1-norm of the complex vector using the true absolute value. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download DZSUM1 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION DZSUM1( N, CX, INCX ) */ + +/* INTEGER INCX, N */ +/* COMPLEX*16 CX( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DZSUM1 takes the sum of the absolute values of a complex */ +/* > vector and returns a double precision result. */ +/* > */ +/* > Based on DZASUM from the Level 1 BLAS. */ +/* > The change is to use the 'genuine' absolute value. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of elements in the vector CX. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CX */ +/* > \verbatim */ +/* > CX is COMPLEX*16 array, dimension (N) */ +/* > The vector whose elements will be summed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The spacing between successive values of CX. INCX > 0. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Nick Higham for use with ZLACON. */ + +/* ===================================================================== */ +doublereal dzsum1_(integer *n, doublecomplex *cx, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal ret_val; + + /* Local variables */ + integer i__, nincx; + doublereal stemp; + + +/* -- 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 */ + --cx; + + /* Function Body */ + ret_val = 0.; + stemp = 0.; + if (*n <= 0) { + return ret_val; + } + if (*incx == 1) { + goto L20; + } + +/* CODE FOR INCREMENT NOT EQUAL TO 1 */ + + nincx = *n * *incx; + i__1 = nincx; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + +/* NEXT LINE MODIFIED. */ + + stemp += z_abs(&cx[i__]); +/* L10: */ + } + ret_val = stemp; + return ret_val; + +/* CODE FOR INCREMENT EQUAL TO 1 */ + +L20: + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + +/* NEXT LINE MODIFIED. */ + + stemp += z_abs(&cx[i__]); +/* L30: */ + } + ret_val = stemp; + return ret_val; + +/* End of DZSUM1 */ + +} /* dzsum1_ */ + diff --git a/lapack-netlib/SRC/icmax1.c b/lapack-netlib/SRC/icmax1.c new file mode 100644 index 000000000..7130d4707 --- /dev/null +++ b/lapack-netlib/SRC/icmax1.c @@ -0,0 +1,533 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ICMAX1 finds the index of the first vector element of maximum absolute value. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ICMAX1 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* INTEGER FUNCTION ICMAX1( N, CX, INCX ) */ + +/* INTEGER INCX, N */ +/* COMPLEX CX( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ICMAX1 finds the index of the first vector element of maximum absolute value. */ +/* > */ +/* > Based on ICAMAX from Level 1 BLAS. */ +/* > The change is to use the 'genuine' absolute value. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of elements in the vector CX. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CX */ +/* > \verbatim */ +/* > CX is COMPLEX array, dimension (N) */ +/* > The vector CX. The ICMAX1 function returns the index of its first */ +/* > element of maximum absolute value. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The spacing between successive values of CX. INCX >= 1. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date February 2014 */ + +/* > \ingroup complexOTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Nick Higham for use with CLACON. */ + +/* ===================================================================== */ +integer icmax1_(integer *n, complex *cx, integer *incx) +{ + /* System generated locals */ + integer ret_val, i__1; + + /* Local variables */ + real smax; + integer i__, ix; + + +/* -- 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..-- */ +/* February 2014 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --cx; + + /* Function Body */ + ret_val = 0; + if (*n < 1 || *incx <= 0) { + return ret_val; + } + ret_val = 1; + if (*n == 1) { + return ret_val; + } + if (*incx == 1) { + +/* code for increment equal to 1 */ + + smax = c_abs(&cx[1]); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if (c_abs(&cx[i__]) > smax) { + ret_val = i__; + smax = c_abs(&cx[i__]); + } + } + } else { + +/* code for increment not equal to 1 */ + + ix = 1; + smax = c_abs(&cx[1]); + ix += *incx; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if (c_abs(&cx[ix]) > smax) { + ret_val = i__; + smax = c_abs(&cx[ix]); + } + ix += *incx; + } + } + return ret_val; + +/* End of ICMAX1 */ + +} /* icmax1_ */ + diff --git a/lapack-netlib/SRC/ieeeck.c b/lapack-netlib/SRC/ieeeck.c new file mode 100644 index 000000000..316d3a0da --- /dev/null +++ b/lapack-netlib/SRC/ieeeck.c @@ -0,0 +1,592 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b IEEECK */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download IEEECK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE ) */ + +/* INTEGER ISPEC */ +/* REAL ONE, ZERO */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > IEEECK is called from the ILAENV to verify that Infinity and */ +/* > possibly NaN arithmetic is safe (i.e. will not trap). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ISPEC */ +/* > \verbatim */ +/* > ISPEC is INTEGER */ +/* > Specifies whether to test just for inifinity arithmetic */ +/* > or whether to test for infinity and NaN arithmetic. */ +/* > = 0: Verify infinity arithmetic only. */ +/* > = 1: Verify infinity and NaN arithmetic. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ZERO */ +/* > \verbatim */ +/* > ZERO is REAL */ +/* > Must contain the value 0.0 */ +/* > This is passed to prevent the compiler from optimizing */ +/* > away this code. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ONE */ +/* > \verbatim */ +/* > ONE is REAL */ +/* > Must contain the value 1.0 */ +/* > This is passed to prevent the compiler from optimizing */ +/* > away this code. */ +/* > */ +/* > RETURN VALUE: INTEGER */ +/* > = 0: Arithmetic failed to produce the correct answers */ +/* > = 1: Arithmetic produced the correct answers */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* ===================================================================== */ +integer ieeeck_(integer *ispec, real *zero, real *one) +{ + /* System generated locals */ + integer ret_val; + + /* Local variables */ + real neginf, posinf, negzro, newzro, nan1, nan2, nan3, nan4, nan5, nan6; + + +/* -- 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 */ + + +/* ===================================================================== */ + + ret_val = 1; + + posinf = *one / *zero; + if (posinf <= *one) { + ret_val = 0; + return ret_val; + } + + neginf = -(*one) / *zero; + if (neginf >= *zero) { + ret_val = 0; + return ret_val; + } + + negzro = *one / (neginf + *one); + if (negzro != *zero) { + ret_val = 0; + return ret_val; + } + + neginf = *one / negzro; + if (neginf >= *zero) { + ret_val = 0; + return ret_val; + } + + newzro = negzro + *zero; + if (newzro != *zero) { + ret_val = 0; + return ret_val; + } + + posinf = *one / newzro; + if (posinf <= *one) { + ret_val = 0; + return ret_val; + } + + neginf *= posinf; + if (neginf >= *zero) { + ret_val = 0; + return ret_val; + } + + posinf *= posinf; + if (posinf <= *one) { + ret_val = 0; + return ret_val; + } + + + + +/* Return if we were only asked to check infinity arithmetic */ + + if (*ispec == 0) { + return ret_val; + } + + nan1 = posinf + neginf; + + nan2 = posinf / neginf; + + nan3 = posinf / posinf; + + nan4 = posinf * *zero; + + nan5 = neginf * negzro; + + nan6 = nan5 * *zero; + + if (nan1 == nan1) { + ret_val = 0; + return ret_val; + } + + if (nan2 == nan2) { + ret_val = 0; + return ret_val; + } + + if (nan3 == nan3) { + ret_val = 0; + return ret_val; + } + + if (nan4 == nan4) { + ret_val = 0; + return ret_val; + } + + if (nan5 == nan5) { + ret_val = 0; + return ret_val; + } + + if (nan6 == nan6) { + ret_val = 0; + return ret_val; + } + + return ret_val; +} /* ieeeck_ */ + diff --git a/lapack-netlib/SRC/ilaclc.c b/lapack-netlib/SRC/ilaclc.c new file mode 100644 index 000000000..dbe812171 --- /dev/null +++ b/lapack-netlib/SRC/ilaclc.c @@ -0,0 +1,514 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ILACLC scans a matrix for its last non-zero column. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ILACLC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* INTEGER FUNCTION ILACLC( M, N, A, LDA ) */ + +/* INTEGER M, N, LDA */ +/* COMPLEX A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ILACLC scans A for its last non-zero column. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > The m by n matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(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 complexOTHERauxiliary */ + +/* ===================================================================== */ +integer ilaclc_(integer *m, integer *n, complex *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, ret_val, i__1, i__2; + + /* Local variables */ + integer i__; + + +/* -- 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 test for the common case where one corner is non-zero. */ + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + if (*n == 0) { + ret_val = *n; + } else /* if(complicated condition) */ { + i__1 = *n * a_dim1 + 1; + i__2 = *m + *n * a_dim1; + if (a[i__1].r != 0.f || a[i__1].i != 0.f || (a[i__2].r != 0.f || a[ + i__2].i != 0.f)) { + ret_val = *n; + } else { +/* Now scan each column from the end, returning with the first non-zero. */ + for (ret_val = *n; ret_val >= 1; --ret_val) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + ret_val * a_dim1; + if (a[i__2].r != 0.f || a[i__2].i != 0.f) { + return ret_val; + } + } + } + } + } + return ret_val; +} /* ilaclc_ */ + diff --git a/lapack-netlib/SRC/ilaclr.c b/lapack-netlib/SRC/ilaclr.c new file mode 100644 index 000000000..34aabd6e6 --- /dev/null +++ b/lapack-netlib/SRC/ilaclr.c @@ -0,0 +1,517 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ILACLR scans a matrix for its last non-zero row. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ILACLR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* INTEGER FUNCTION ILACLR( M, N, A, LDA ) */ + +/* INTEGER M, N, LDA */ +/* COMPLEX A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ILACLR scans A for its last non-zero row. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX array, dimension (LDA,N) */ +/* > The m by n matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup complexOTHERauxiliary */ + +/* ===================================================================== */ +integer ilaclr_(integer *m, integer *n, complex *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, ret_val, i__1, i__2; + + /* Local variables */ + integer i__, j; + + +/* -- 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 test for the common case where one corner is non-zero. */ + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + if (*m == 0) { + ret_val = *m; + } else /* if(complicated condition) */ { + i__1 = *m + a_dim1; + i__2 = *m + *n * a_dim1; + if (a[i__1].r != 0.f || a[i__1].i != 0.f || (a[i__2].r != 0.f || a[ + i__2].i != 0.f)) { + ret_val = *m; + } else { +/* Scan up each column tracking the last zero row seen. */ + ret_val = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__ = *m; + for(;;) { /* while(complicated condition) */ + i__2 = f2cmax(i__,1) + j * a_dim1; + if (!(a[i__2].r == 0.f && a[i__2].i == 0.f && i__ >= 1)) + break; + --i__; + } + ret_val = f2cmax(ret_val,i__); + } + } + } + return ret_val; +} /* ilaclr_ */ + diff --git a/lapack-netlib/SRC/iladiag.c b/lapack-netlib/SRC/iladiag.c new file mode 100644 index 000000000..c5adba46f --- /dev/null +++ b/lapack-netlib/SRC/iladiag.c @@ -0,0 +1,477 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ILADIAG */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ILADIAG + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* INTEGER FUNCTION ILADIAG( DIAG ) */ + +/* CHARACTER DIAG */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This subroutine translated from a character string specifying if a */ +/* > matrix has unit diagonal or not to the relevant BLAST-specified */ +/* > integer constant. */ +/* > */ +/* > ILADIAG returns an INTEGER. If ILADIAG < 0, then the input is not a */ +/* > character indicating a unit or non-unit diagonal. Otherwise ILADIAG */ +/* > returns the constant value corresponding to DIAG. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* ===================================================================== */ +integer iladiag_(char *diag) +{ + /* System generated locals */ + integer ret_val; + + /* Local variables */ + extern logical lsame_(char *, char *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + if (lsame_(diag, "N")) { + ret_val = 131; + } else if (lsame_(diag, "U")) { + ret_val = 132; + } else { + ret_val = -1; + } + return ret_val; + +/* End of ILADIAG */ + +} /* iladiag_ */ + diff --git a/lapack-netlib/SRC/iladlc.c b/lapack-netlib/SRC/iladlc.c new file mode 100644 index 000000000..064056c61 --- /dev/null +++ b/lapack-netlib/SRC/iladlc.c @@ -0,0 +1,508 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ILADLC scans a matrix for its last non-zero column. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ILADLC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* INTEGER FUNCTION ILADLC( M, N, A, LDA ) */ + +/* INTEGER M, N, LDA */ +/* DOUBLE PRECISION A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ILADLC scans A for its last non-zero column. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > The m by n matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(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 */ + +/* ===================================================================== */ +integer iladlc_(integer *m, integer *n, doublereal *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, ret_val, i__1; + + /* Local variables */ + integer i__; + + +/* -- 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 test for the common case where one corner is non-zero. */ + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + if (*n == 0) { + ret_val = *n; + } else if (a[*n * a_dim1 + 1] != 0. || a[*m + *n * a_dim1] != 0.) { + ret_val = *n; + } else { +/* Now scan each column from the end, returning with the first non-zero. */ + for (ret_val = *n; ret_val >= 1; --ret_val) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (a[i__ + ret_val * a_dim1] != 0.) { + return ret_val; + } + } + } + } + return ret_val; +} /* iladlc_ */ + diff --git a/lapack-netlib/SRC/iladlr.c b/lapack-netlib/SRC/iladlr.c new file mode 100644 index 000000000..14bb2e1ea --- /dev/null +++ b/lapack-netlib/SRC/iladlr.c @@ -0,0 +1,509 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ILADLR scans a matrix for its last non-zero row. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ILADLR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* INTEGER FUNCTION ILADLR( M, N, A, LDA ) */ + +/* INTEGER M, N, LDA */ +/* DOUBLE PRECISION A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ILADLR scans A for its last non-zero row. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is DOUBLE PRECISION array, dimension (LDA,N) */ +/* > The m by n matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(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 */ + +/* ===================================================================== */ +integer iladlr_(integer *m, integer *n, doublereal *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, ret_val, i__1; + + /* Local variables */ + integer i__, j; + + +/* -- 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 test for the common case where one corner is non-zero. */ + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + if (*m == 0) { + ret_val = *m; + } else if (a[*m + a_dim1] != 0. || a[*m + *n * a_dim1] != 0.) { + ret_val = *m; + } else { +/* Scan up each column tracking the last zero row seen. */ + ret_val = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__ = *m; + while(a[f2cmax(i__,1) + j * a_dim1] == 0. && i__ >= 1) { + --i__; + } + ret_val = f2cmax(ret_val,i__); + } + } + return ret_val; +} /* iladlr_ */ + diff --git a/lapack-netlib/SRC/ilaenv.c b/lapack-netlib/SRC/ilaenv.c new file mode 100644 index 000000000..20483fd59 --- /dev/null +++ b/lapack-netlib/SRC/ilaenv.c @@ -0,0 +1,1181 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +//#define i_len(s, n) (n) +#define i_len(s, n) strlen(s) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ILAENV */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ILAENV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) */ + +/* CHARACTER*( * ) NAME, OPTS */ +/* INTEGER ISPEC, N1, N2, N3, N4 */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ILAENV is called from the LAPACK routines to choose problem-dependent */ +/* > parameters for the local environment. See ISPEC for a description of */ +/* > the parameters. */ +/* > */ +/* > ILAENV returns an INTEGER */ +/* > if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC */ +/* > if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value. */ +/* > */ +/* > This version provides a set of parameters which should give good, */ +/* > but not optimal, performance on many of the currently available */ +/* > computers. Users are encouraged to modify this subroutine to set */ +/* > the tuning parameters for their particular machine using the option */ +/* > and problem size information in the arguments. */ +/* > */ +/* > This routine will not function correctly if it is converted to all */ +/* > lower case. Converting it to all upper case is allowed. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ISPEC */ +/* > \verbatim */ +/* > ISPEC is INTEGER */ +/* > Specifies the parameter to be returned as the value of */ +/* > ILAENV. */ +/* > = 1: the optimal blocksize; if this value is 1, an unblocked */ +/* > algorithm will give the best performance. */ +/* > = 2: the minimum block size for which the block routine */ +/* > should be used; if the usable block size is less than */ +/* > this value, an unblocked routine should be used. */ +/* > = 3: the crossover point (in a block routine, for N less */ +/* > than this value, an unblocked routine should be used) */ +/* > = 4: the number of shifts, used in the nonsymmetric */ +/* > eigenvalue routines (DEPRECATED) */ +/* > = 5: the minimum column dimension for blocking to be used; */ +/* > rectangular blocks must have dimension at least k by m, */ +/* > where k is given by ILAENV(2,...) and m by ILAENV(5,...) */ +/* > = 6: the crossover point for the SVD (when reducing an m by n */ +/* > matrix to bidiagonal form, if f2cmax(m,n)/f2cmin(m,n) exceeds */ +/* > this value, a QR factorization is used first to reduce */ +/* > the matrix to a triangular form.) */ +/* > = 7: the number of processors */ +/* > = 8: the crossover point for the multishift QR method */ +/* > for nonsymmetric eigenvalue problems (DEPRECATED) */ +/* > = 9: maximum size of the subproblems at the bottom of the */ +/* > computation tree in the divide-and-conquer algorithm */ +/* > (used by xGELSD and xGESDD) */ +/* > =10: ieee NaN arithmetic can be trusted not to trap */ +/* > =11: infinity arithmetic can be trusted not to trap */ +/* > 12 <= ISPEC <= 16: */ +/* > xHSEQR or related subroutines, */ +/* > see IPARMQ for detailed explanation */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NAME */ +/* > \verbatim */ +/* > NAME is CHARACTER*(*) */ +/* > The name of the calling subroutine, in either upper case or */ +/* > lower case. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] OPTS */ +/* > \verbatim */ +/* > OPTS is CHARACTER*(*) */ +/* > The character options to the subroutine NAME, concatenated */ +/* > into a single character string. For example, UPLO = 'U', */ +/* > TRANS = 'T', and DIAG = 'N' for a triangular routine would */ +/* > be specified as OPTS = 'UTN'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N1 */ +/* > \verbatim */ +/* > N1 is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N2 */ +/* > \verbatim */ +/* > N2 is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N3 */ +/* > \verbatim */ +/* > N3 is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N4 */ +/* > \verbatim */ +/* > N4 is INTEGER */ +/* > Problem dimensions for the subroutine NAME; these may not all */ +/* > be required. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2019 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The following conventions have been used when calling ILAENV from the */ +/* > LAPACK routines: */ +/* > 1) OPTS is a concatenation of all of the character options to */ +/* > subroutine NAME, in the same order that they appear in the */ +/* > argument list for NAME, even if they are not used in determining */ +/* > the value of the parameter specified by ISPEC. */ +/* > 2) The problem dimensions N1, N2, N3, N4 are specified in the order */ +/* > that they appear in the argument list for NAME. N1 is used */ +/* > first, N2 second, and so on, and unused problem dimensions are */ +/* > passed a value of -1. */ +/* > 3) The parameter value returned by ILAENV is checked for validity in */ +/* > the calling subroutine. For example, ILAENV is used to retrieve */ +/* > the optimal blocksize for STRTRI as follows: */ +/* > */ +/* > NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) */ +/* > IF( NB.LE.1 ) NB = MAX( 1, N ) */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, + integer *n2, integer *n3, integer *n4, ftnlen name_len, ftnlen + opts_len) +{ + /* System generated locals */ + integer ret_val; + + /* Local variables */ + logical twostage; + integer i__; + logical cname; + integer nbmin; + logical sname; + char c1[1], c2[2], c3[3], c4[2]; + integer ic, nb; + extern integer ieeeck_(integer *, real *, real *); + integer iz, nx; + char subnam[16]; + extern integer iparmq_(integer *, char *, char *, integer *, integer *, + integer *, integer *); + + +/* -- LAPACK auxiliary 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 */ + + +/* ===================================================================== */ + + + switch (*ispec) { + case 1: goto L10; + case 2: goto L10; + case 3: goto L10; + case 4: goto L80; + case 5: goto L90; + case 6: goto L100; + case 7: goto L110; + case 8: goto L120; + case 9: goto L130; + case 10: goto L140; + case 11: goto L150; + case 12: goto L160; + case 13: goto L160; + case 14: goto L160; + case 15: goto L160; + case 16: goto L160; + } + +/* Invalid value for ISPEC */ + + ret_val = -1; + return ret_val; + +L10: + +/* Convert NAME to upper case if the first character is lower case. */ + + ret_val = 1; + s_copy(subnam, name__, (ftnlen)16, name_len); + ic = *(unsigned char *)subnam; + iz = 'Z'; + if (iz == 90 || iz == 122) { + +/* ASCII character set */ + + if (ic >= 97 && ic <= 122) { + *(unsigned char *)subnam = (char) (ic - 32); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 97 && ic <= 122) { + *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); + } +/* L20: */ + } + } + + } else if (iz == 233 || iz == 169) { + +/* EBCDIC character set */ + + if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 && + ic <= 169) { + *(unsigned char *)subnam = (char) (ic + 64); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= + 162 && ic <= 169) { + *(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64); + } +/* L30: */ + } + } + + } else if (iz == 218 || iz == 250) { + +/* Prime machines: ASCII+128 */ + + if (ic >= 225 && ic <= 250) { + *(unsigned char *)subnam = (char) (ic - 32); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 225 && ic <= 250) { + *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); + } +/* L40: */ + } + } + } + + *(unsigned char *)c1 = *(unsigned char *)subnam; + sname = *(unsigned char *)c1 == 'S' || *(unsigned char *)c1 == 'D'; + cname = *(unsigned char *)c1 == 'C' || *(unsigned char *)c1 == 'Z'; + if (! (cname || sname)) { + return ret_val; + } + s_copy(c2, subnam + 1, (ftnlen)2, (ftnlen)2); + s_copy(c3, subnam + 3, (ftnlen)3, (ftnlen)3); + s_copy(c4, c3 + 1, (ftnlen)2, (ftnlen)2); + twostage = i_len(subnam, (ftnlen)16) >= 11 && *(unsigned char *)&subnam[ + 10] == '2'; + + switch (*ispec) { + case 1: goto L50; + case 2: goto L60; + case 3: goto L70; + } + +L50: + +/* ISPEC = 1: block size */ + +/* In these examples, separate code is provided for setting NB for */ +/* real and complex. We assume that NB will take the same value in */ +/* single or double precision. */ + + nb = 1; + + if (s_cmp(subnam + 1, "LAORH", (ftnlen)5, (ftnlen)5) == 0) { + +/* This is for *LAORHR_GETRFNP routine */ + + if (sname) { + nb = 32; + } else { + nb = 32; + } + } else if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) { + if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } else if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, + "RQF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen) + 3, (ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3) + == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } + } else if (s_cmp(c3, "QR ", (ftnlen)3, (ftnlen)3) == 0) { + if (*n3 == 1) { + if (sname) { +/* M*N */ + if (*n1 * *n2 <= 131072 || *n1 <= 8192) { + nb = *n1; + } else { + nb = 32768 / *n2; + } + } else { + if (*n1 * *n2 <= 131072 || *n1 <= 8192) { + nb = *n1; + } else { + nb = 32768 / *n2; + } + } + } else { + if (sname) { + nb = 1; + } else { + nb = 1; + } + } + } else if (s_cmp(c3, "LQ ", (ftnlen)3, (ftnlen)3) == 0) { + if (*n3 == 2) { + if (sname) { +/* M*N */ + if (*n1 * *n2 <= 131072 || *n1 <= 8192) { + nb = *n1; + } else { + nb = 32768 / *n2; + } + } else { + if (*n1 * *n2 <= 131072 || *n1 <= 8192) { + nb = *n1; + } else { + nb = 32768 / *n2; + } + } + } else { + if (sname) { + nb = 1; + } else { + nb = 1; + } + } + } else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } + } else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } + } else if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } + } else if (s_cmp(c2, "PO", (ftnlen)2, (ftnlen)2) == 0) { + if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } + } else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) { + if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + if (twostage) { + nb = 192; + } else { + nb = 64; + } + } else { + if (twostage) { + nb = 192; + } else { + nb = 64; + } + } + } else if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) { + nb = 32; + } else if (sname && s_cmp(c3, "GST", (ftnlen)3, (ftnlen)3) == 0) { + nb = 64; + } + } else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) { + if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) { + if (twostage) { + nb = 192; + } else { + nb = 64; + } + } else if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) { + nb = 32; + } else if (s_cmp(c3, "GST", (ftnlen)3, (ftnlen)3) == 0) { + nb = 64; + } + } else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", + (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, ( + ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) == + 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( + c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", ( + ftnlen)2, (ftnlen)2) == 0) { + nb = 32; + } + } else if (*(unsigned char *)c3 == 'M') { + if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", + (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, ( + ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) == + 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( + c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", ( + ftnlen)2, (ftnlen)2) == 0) { + nb = 32; + } + } + } else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", + (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, ( + ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) == + 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( + c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", ( + ftnlen)2, (ftnlen)2) == 0) { + nb = 32; + } + } else if (*(unsigned char *)c3 == 'M') { + if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", + (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, ( + ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) == + 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( + c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", ( + ftnlen)2, (ftnlen)2) == 0) { + nb = 32; + } + } + } else if (s_cmp(c2, "GB", (ftnlen)2, (ftnlen)2) == 0) { + if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + if (*n4 <= 64) { + nb = 1; + } else { + nb = 32; + } + } else { + if (*n4 <= 64) { + nb = 1; + } else { + nb = 32; + } + } + } + } else if (s_cmp(c2, "PB", (ftnlen)2, (ftnlen)2) == 0) { + if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + if (*n2 <= 64) { + nb = 1; + } else { + nb = 32; + } + } else { + if (*n2 <= 64) { + nb = 1; + } else { + nb = 32; + } + } + } + } else if (s_cmp(c2, "TR", (ftnlen)2, (ftnlen)2) == 0) { + if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } else if (s_cmp(c3, "EVC", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } + } else if (s_cmp(c2, "LA", (ftnlen)2, (ftnlen)2) == 0) { + if (s_cmp(c3, "UUM", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 64; + } else { + nb = 64; + } + } + } else if (sname && s_cmp(c2, "ST", (ftnlen)2, (ftnlen)2) == 0) { + if (s_cmp(c3, "EBZ", (ftnlen)3, (ftnlen)3) == 0) { + nb = 1; + } + } else if (s_cmp(c2, "GG", (ftnlen)2, (ftnlen)2) == 0) { + nb = 32; + if (s_cmp(c3, "HD3", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nb = 32; + } else { + nb = 32; + } + } + } + ret_val = nb; + return ret_val; + +L60: + +/* ISPEC = 2: minimum block size */ + + nbmin = 2; + if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) { + if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "RQF", ( + ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)3, ( + ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3) == 0) + { + if (sname) { + nbmin = 2; + } else { + nbmin = 2; + } + } else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nbmin = 2; + } else { + nbmin = 2; + } + } else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nbmin = 2; + } else { + nbmin = 2; + } + } else if (s_cmp(c3, "TRI", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nbmin = 2; + } else { + nbmin = 2; + } + } + } else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) { + if (s_cmp(c3, "TRF", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nbmin = 8; + } else { + nbmin = 8; + } + } else if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) { + nbmin = 2; + } + } else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) { + if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) { + nbmin = 2; + } + } else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", + (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, ( + ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) == + 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( + c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", ( + ftnlen)2, (ftnlen)2) == 0) { + nbmin = 2; + } + } else if (*(unsigned char *)c3 == 'M') { + if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", + (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, ( + ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) == + 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( + c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", ( + ftnlen)2, (ftnlen)2) == 0) { + nbmin = 2; + } + } + } else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", + (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, ( + ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) == + 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( + c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", ( + ftnlen)2, (ftnlen)2) == 0) { + nbmin = 2; + } + } else if (*(unsigned char *)c3 == 'M') { + if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", + (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, ( + ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) == + 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( + c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", ( + ftnlen)2, (ftnlen)2) == 0) { + nbmin = 2; + } + } + } else if (s_cmp(c2, "GG", (ftnlen)2, (ftnlen)2) == 0) { + nbmin = 2; + if (s_cmp(c3, "HD3", (ftnlen)3, (ftnlen)3) == 0) { + nbmin = 2; + } + } + ret_val = nbmin; + return ret_val; + +L70: + +/* ISPEC = 3: crossover point */ + + nx = 0; + if (s_cmp(c2, "GE", (ftnlen)2, (ftnlen)2) == 0) { + if (s_cmp(c3, "QRF", (ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "RQF", ( + ftnlen)3, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)3, ( + ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)3, (ftnlen)3) == 0) + { + if (sname) { + nx = 128; + } else { + nx = 128; + } + } else if (s_cmp(c3, "HRD", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nx = 128; + } else { + nx = 128; + } + } else if (s_cmp(c3, "BRD", (ftnlen)3, (ftnlen)3) == 0) { + if (sname) { + nx = 128; + } else { + nx = 128; + } + } + } else if (s_cmp(c2, "SY", (ftnlen)2, (ftnlen)2) == 0) { + if (sname && s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) { + nx = 32; + } + } else if (cname && s_cmp(c2, "HE", (ftnlen)2, (ftnlen)2) == 0) { + if (s_cmp(c3, "TRD", (ftnlen)3, (ftnlen)3) == 0) { + nx = 32; + } + } else if (sname && s_cmp(c2, "OR", (ftnlen)2, (ftnlen)2) == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", + (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, ( + ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) == + 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( + c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", ( + ftnlen)2, (ftnlen)2) == 0) { + nx = 128; + } + } + } else if (cname && s_cmp(c2, "UN", (ftnlen)2, (ftnlen)2) == 0) { + if (*(unsigned char *)c3 == 'G') { + if (s_cmp(c4, "QR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "RQ", + (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)2, ( + ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)2, (ftnlen)2) == + 0 || s_cmp(c4, "HR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp( + c4, "TR", (ftnlen)2, (ftnlen)2) == 0 || s_cmp(c4, "BR", ( + ftnlen)2, (ftnlen)2) == 0) { + nx = 128; + } + } + } else if (s_cmp(c2, "GG", (ftnlen)2, (ftnlen)2) == 0) { + nx = 128; + if (s_cmp(c3, "HD3", (ftnlen)3, (ftnlen)3) == 0) { + nx = 128; + } + } + ret_val = nx; + return ret_val; + +L80: + +/* ISPEC = 4: number of shifts (used by xHSEQR) */ + + ret_val = 6; + return ret_val; + +L90: + +/* ISPEC = 5: minimum column dimension (not used) */ + + ret_val = 2; + return ret_val; + +L100: + +/* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD) */ + + ret_val = (integer) ((real) f2cmin(*n1,*n2) * 1.6f); + return ret_val; + +L110: + +/* ISPEC = 7: number of processors (not used) */ + + ret_val = 1; + return ret_val; + +L120: + +/* ISPEC = 8: crossover point for multishift (used by xHSEQR) */ + + ret_val = 50; + return ret_val; + +L130: + +/* ISPEC = 9: maximum size of the subproblems at the bottom of the */ +/* computation tree in the divide-and-conquer algorithm */ +/* (used by xGELSD and xGESDD) */ + + ret_val = 25; + return ret_val; + +L140: + +/* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap */ + +/* ILAENV = 0 */ + ret_val = 1; + if (ret_val == 1) { + ret_val = ieeeck_(&c__1, &c_b174, &c_b175); + } + return ret_val; + +L150: + +/* ISPEC = 11: infinity arithmetic can be trusted not to trap */ + +/* ILAENV = 0 */ + ret_val = 1; + if (ret_val == 1) { + ret_val = ieeeck_(&c__0, &c_b174, &c_b175); + } + return ret_val; + +L160: + +/* 12 <= ISPEC <= 16: xHSEQR or related subroutines. */ + + ret_val = iparmq_(ispec, name__, opts, n1, n2, n3, n4) + ; + return ret_val; + +/* End of ILAENV */ + +} /* ilaenv_ */ + diff --git a/lapack-netlib/SRC/ilaenv2stage.c b/lapack-netlib/SRC/ilaenv2stage.c new file mode 100644 index 000000000..cee28a77f --- /dev/null +++ b/lapack-netlib/SRC/ilaenv2stage.c @@ -0,0 +1,583 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ILAENV2STAGE */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ILAENV2STAGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* INTEGER FUNCTION ILAENV2STAGE( ISPEC, NAME, OPTS, N1, N2, N3, N4 ) */ + +/* CHARACTER*( * ) NAME, OPTS */ +/* INTEGER ISPEC, N1, N2, N3, N4 */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ILAENV2STAGE is called from the LAPACK routines to choose problem-dependent */ +/* > parameters for the local environment. See ISPEC for a description of */ +/* > the parameters. */ +/* > It sets problem and machine dependent parameters useful for *_2STAGE and */ +/* > related subroutines. */ +/* > */ +/* > ILAENV2STAGE returns an INTEGER */ +/* > if ILAENV2STAGE >= 0: ILAENV2STAGE returns the value of the parameter */ +/* > specified by ISPEC */ +/* > if ILAENV2STAGE < 0: if ILAENV2STAGE = -k, the k-th argument had an */ +/* > illegal value. */ +/* > */ +/* > This version provides a set of parameters which should give good, */ +/* > but not optimal, performance on many of the currently available */ +/* > computers for the 2-stage solvers. Users are encouraged to modify this */ +/* > subroutine to set the tuning parameters for their particular machine using */ +/* > the option and problem size information in the arguments. */ +/* > */ +/* > This routine will not function correctly if it is converted to all */ +/* > lower case. Converting it to all upper case is allowed. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ISPEC */ +/* > \verbatim */ +/* > ISPEC is INTEGER */ +/* > Specifies the parameter to be returned as the value of */ +/* > ILAENV2STAGE. */ +/* > = 1: the optimal blocksize nb for the reduction to BAND */ +/* > */ +/* > = 2: the optimal blocksize ib for the eigenvectors */ +/* > singular vectors update routine */ +/* > */ +/* > = 3: The length of the array that store the Housholder */ +/* > representation for the second stage */ +/* > Band to Tridiagonal or Bidiagonal */ +/* > */ +/* > = 4: The workspace needed for the routine in input. */ +/* > */ +/* > = 5: For future release. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NAME */ +/* > \verbatim */ +/* > NAME is CHARACTER*(*) */ +/* > The name of the calling subroutine, in either upper case or */ +/* > lower case. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] OPTS */ +/* > \verbatim */ +/* > OPTS is CHARACTER*(*) */ +/* > The character options to the subroutine NAME, concatenated */ +/* > into a single character string. For example, UPLO = 'U', */ +/* > TRANS = 'T', and DIAG = 'N' for a triangular routine would */ +/* > be specified as OPTS = 'UTN'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N1 */ +/* > \verbatim */ +/* > N1 is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N2 */ +/* > \verbatim */ +/* > N2 is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N3 */ +/* > \verbatim */ +/* > N3 is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N4 */ +/* > \verbatim */ +/* > N4 is INTEGER */ +/* > Problem dimensions for the subroutine NAME; these may not all */ +/* > be required. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ +/* > \author Nick R. Papior */ + +/* > \date July 2017 */ + +/* > \ingroup OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The following conventions have been used when calling ILAENV2STAGE */ +/* > from the LAPACK routines: */ +/* > 1) OPTS is a concatenation of all of the character options to */ +/* > subroutine NAME, in the same order that they appear in the */ +/* > argument list for NAME, even if they are not used in determining */ +/* > the value of the parameter specified by ISPEC. */ +/* > 2) The problem dimensions N1, N2, N3, N4 are specified in the order */ +/* > that they appear in the argument list for NAME. N1 is used */ +/* > first, N2 second, and so on, and unused problem dimensions are */ +/* > passed a value of -1. */ +/* > 3) The parameter value returned by ILAENV2STAGE is checked for validity in */ +/* > the calling subroutine. */ +/* > */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +integer ilaenv2stage_(integer *ispec, char *name__, char *opts, integer *n1, + integer *n2, integer *n3, integer *n4) +{ + /* System generated locals */ + integer ret_val; + + /* Local variables */ + extern integer iparam2stage_(integer *, char *, char *, integer *, + integer *, integer *, integer *); + integer iispec; + + +/* -- 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..-- */ +/* July 2017 */ + + +/* ===================================================================== */ + + switch (*ispec) { + case 1: goto L10; + case 2: goto L10; + case 3: goto L10; + case 4: goto L10; + case 5: goto L10; + } + +/* Invalid value for ISPEC */ + + ret_val = -1; + return ret_val; + +L10: + +/* 2stage eigenvalues and SVD or related subroutines. */ + + iispec = *ispec + 16; + ret_val = iparam2stage_(&iispec, name__, opts, n1, n2, n3, n4); + return ret_val; + +/* End of ILAENV2STAGE */ + +} /* ilaenv2stage_ */ + diff --git a/lapack-netlib/SRC/ilaprec.c b/lapack-netlib/SRC/ilaprec.c new file mode 100644 index 000000000..c05207a2b --- /dev/null +++ b/lapack-netlib/SRC/ilaprec.c @@ -0,0 +1,481 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ILAPREC */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ILAPREC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* INTEGER FUNCTION ILAPREC( PREC ) */ + +/* CHARACTER PREC */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This subroutine translated from a character string specifying an */ +/* > intermediate precision to the relevant BLAST-specified integer */ +/* > constant. */ +/* > */ +/* > ILAPREC returns an INTEGER. If ILAPREC < 0, then the input is not a */ +/* > character indicating a supported intermediate precision. Otherwise */ +/* > ILAPREC returns the constant value corresponding to PREC. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* ===================================================================== */ +integer ilaprec_(char *prec) +{ + /* System generated locals */ + integer ret_val; + + /* Local variables */ + extern logical lsame_(char *, char *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + if (lsame_(prec, "S")) { + ret_val = 211; + } else if (lsame_(prec, "D")) { + ret_val = 212; + } else if (lsame_(prec, "I")) { + ret_val = 213; + } else if (lsame_(prec, "X") || lsame_(prec, "E")) { + ret_val = 214; + } else { + ret_val = -1; + } + return ret_val; + +/* End of ILAPREC */ + +} /* ilaprec_ */ + diff --git a/lapack-netlib/SRC/ilaslc.c b/lapack-netlib/SRC/ilaslc.c new file mode 100644 index 000000000..8e4563eae --- /dev/null +++ b/lapack-netlib/SRC/ilaslc.c @@ -0,0 +1,508 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ILASLC scans a matrix for its last non-zero column. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ILASLC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* INTEGER FUNCTION ILASLC( M, N, A, LDA ) */ + +/* INTEGER M, N, LDA */ +/* REAL A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ILASLC scans A for its last non-zero column. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > The m by n matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup realOTHERauxiliary */ + +/* ===================================================================== */ +integer ilaslc_(integer *m, integer *n, real *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, ret_val, i__1; + + /* Local variables */ + integer i__; + + +/* -- 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 test for the common case where one corner is non-zero. */ + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + if (*n == 0) { + ret_val = *n; + } else if (a[*n * a_dim1 + 1] != 0.f || a[*m + *n * a_dim1] != 0.f) { + ret_val = *n; + } else { +/* Now scan each column from the end, returning with the first non-zero. */ + for (ret_val = *n; ret_val >= 1; --ret_val) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (a[i__ + ret_val * a_dim1] != 0.f) { + return ret_val; + } + } + } + } + return ret_val; +} /* ilaslc_ */ + diff --git a/lapack-netlib/SRC/ilaslr.c b/lapack-netlib/SRC/ilaslr.c new file mode 100644 index 000000000..a856b79e1 --- /dev/null +++ b/lapack-netlib/SRC/ilaslr.c @@ -0,0 +1,509 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ILASLR scans a matrix for its last non-zero row. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ILASLR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* INTEGER FUNCTION ILASLR( M, N, A, LDA ) */ + +/* INTEGER M, N, LDA */ +/* REAL A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ILASLR scans A for its last non-zero row. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is REAL array, dimension (LDA,N) */ +/* > The m by n matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(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 realOTHERauxiliary */ + +/* ===================================================================== */ +integer ilaslr_(integer *m, integer *n, real *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, ret_val, i__1; + + /* Local variables */ + integer i__, j; + + +/* -- 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 test for the common case where one corner is non-zero. */ + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + if (*m == 0) { + ret_val = *m; + } else if (a[*m + a_dim1] != 0.f || a[*m + *n * a_dim1] != 0.f) { + ret_val = *m; + } else { +/* Scan up each column tracking the last zero row seen. */ + ret_val = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__ = *m; + while(a[f2cmax(i__,1) + j * a_dim1] == 0.f && i__ >= 1) { + --i__; + } + ret_val = f2cmax(ret_val,i__); + } + } + return ret_val; +} /* ilaslr_ */ + diff --git a/lapack-netlib/SRC/ilatrans.c b/lapack-netlib/SRC/ilatrans.c new file mode 100644 index 000000000..f04293200 --- /dev/null +++ b/lapack-netlib/SRC/ilatrans.c @@ -0,0 +1,479 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ILATRANS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ILATRANS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* INTEGER FUNCTION ILATRANS( TRANS ) */ + +/* CHARACTER TRANS */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This subroutine translates from a character string specifying a */ +/* > transposition operation to the relevant BLAST-specified integer */ +/* > constant. */ +/* > */ +/* > ILATRANS returns an INTEGER. If ILATRANS < 0, then the input is not */ +/* > a character indicating a transposition operator. Otherwise ILATRANS */ +/* > returns the constant value corresponding to TRANS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* ===================================================================== */ +integer ilatrans_(char *trans) +{ + /* System generated locals */ + integer ret_val; + + /* Local variables */ + extern logical lsame_(char *, char *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + if (lsame_(trans, "N")) { + ret_val = 111; + } else if (lsame_(trans, "T")) { + ret_val = 112; + } else if (lsame_(trans, "C")) { + ret_val = 113; + } else { + ret_val = -1; + } + return ret_val; + +/* End of ILATRANS */ + +} /* ilatrans_ */ + diff --git a/lapack-netlib/SRC/ilauplo.c b/lapack-netlib/SRC/ilauplo.c new file mode 100644 index 000000000..ad33c2982 --- /dev/null +++ b/lapack-netlib/SRC/ilauplo.c @@ -0,0 +1,477 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ILAUPLO */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ILAUPLO + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* INTEGER FUNCTION ILAUPLO( UPLO ) */ + +/* CHARACTER UPLO */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This subroutine translated from a character string specifying a */ +/* > upper- or lower-triangular matrix to the relevant BLAST-specified */ +/* > integer constant. */ +/* > */ +/* > ILAUPLO returns an INTEGER. If ILAUPLO < 0, then the input is not */ +/* > a character indicating an upper- or lower-triangular matrix. */ +/* > Otherwise ILAUPLO returns the constant value corresponding to UPLO. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup auxOTHERcomputational */ + +/* ===================================================================== */ +integer ilauplo_(char *uplo) +{ + /* System generated locals */ + integer ret_val; + + /* Local variables */ + extern logical lsame_(char *, char *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + if (lsame_(uplo, "U")) { + ret_val = 121; + } else if (lsame_(uplo, "L")) { + ret_val = 122; + } else { + ret_val = -1; + } + return ret_val; + +/* End of ILAUPLO */ + +} /* ilauplo_ */ + diff --git a/lapack-netlib/SRC/ilazlc.c b/lapack-netlib/SRC/ilazlc.c new file mode 100644 index 000000000..efc3787a1 --- /dev/null +++ b/lapack-netlib/SRC/ilazlc.c @@ -0,0 +1,514 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ILAZLC scans a matrix for its last non-zero column. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ILAZLC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* INTEGER FUNCTION ILAZLC( M, N, A, LDA ) */ + +/* INTEGER M, N, LDA */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ILAZLC scans A for its last non-zero column. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > The m by n matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +integer ilazlc_(integer *m, integer *n, doublecomplex *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, ret_val, i__1, i__2; + + /* Local variables */ + integer i__; + + +/* -- 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 test for the common case where one corner is non-zero. */ + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + if (*n == 0) { + ret_val = *n; + } else /* if(complicated condition) */ { + i__1 = *n * a_dim1 + 1; + i__2 = *m + *n * a_dim1; + if (a[i__1].r != 0. || a[i__1].i != 0. || (a[i__2].r != 0. || a[i__2] + .i != 0.)) { + ret_val = *n; + } else { +/* Now scan each column from the end, returning with the first non-zero. */ + for (ret_val = *n; ret_val >= 1; --ret_val) { + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__ + ret_val * a_dim1; + if (a[i__2].r != 0. || a[i__2].i != 0.) { + return ret_val; + } + } + } + } + } + return ret_val; +} /* ilazlc_ */ + diff --git a/lapack-netlib/SRC/ilazlr.c b/lapack-netlib/SRC/ilazlr.c new file mode 100644 index 000000000..75e920f8a --- /dev/null +++ b/lapack-netlib/SRC/ilazlr.c @@ -0,0 +1,517 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ILAZLR scans a matrix for its last non-zero row. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ILAZLR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* INTEGER FUNCTION ILAZLR( M, N, A, LDA ) */ + +/* INTEGER M, N, LDA */ +/* COMPLEX*16 A( LDA, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ILAZLR scans A for its last non-zero row. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > The m by n matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +integer ilazlr_(integer *m, integer *n, doublecomplex *a, integer *lda) +{ + /* System generated locals */ + integer a_dim1, a_offset, ret_val, i__1, i__2; + + /* Local variables */ + integer i__, j; + + +/* -- 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 test for the common case where one corner is non-zero. */ + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + + /* Function Body */ + if (*m == 0) { + ret_val = *m; + } else /* if(complicated condition) */ { + i__1 = *m + a_dim1; + i__2 = *m + *n * a_dim1; + if (a[i__1].r != 0. || a[i__1].i != 0. || (a[i__2].r != 0. || a[i__2] + .i != 0.)) { + ret_val = *m; + } else { +/* Scan up each column tracking the last zero row seen. */ + ret_val = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__ = *m; + for(;;) { /* while(complicated condition) */ + i__2 = f2cmax(i__,1) + j * a_dim1; + if (!(a[i__2].r == 0. && a[i__2].i == 0. && i__ >= 1)) + break; + --i__; + } + ret_val = f2cmax(ret_val,i__); + } + } + } + return ret_val; +} /* ilazlr_ */ + diff --git a/lapack-netlib/SRC/iparmq.c b/lapack-netlib/SRC/iparmq.c new file mode 100644 index 000000000..6ff33fc80 --- /dev/null +++ b/lapack-netlib/SRC/iparmq.c @@ -0,0 +1,791 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b IPARMQ */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download IPARMQ + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK ) */ + +/* INTEGER IHI, ILO, ISPEC, LWORK, N */ +/* CHARACTER NAME*( * ), OPTS*( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > This program sets problem and machine dependent parameters */ +/* > useful for xHSEQR and related subroutines for eigenvalue */ +/* > problems. It is called whenever */ +/* > IPARMQ is called with 12 <= ISPEC <= 16 */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ISPEC */ +/* > \verbatim */ +/* > ISPEC is INTEGER */ +/* > ISPEC specifies which tunable parameter IPARMQ should */ +/* > return. */ +/* > */ +/* > ISPEC=12: (INMIN) Matrices of order nmin or less */ +/* > are sent directly to xLAHQR, the implicit */ +/* > double shift QR algorithm. NMIN must be */ +/* > at least 11. */ +/* > */ +/* > ISPEC=13: (INWIN) Size of the deflation window. */ +/* > This is best set greater than or equal to */ +/* > the number of simultaneous shifts NS. */ +/* > Larger matrices benefit from larger deflation */ +/* > windows. */ +/* > */ +/* > ISPEC=14: (INIBL) Determines when to stop nibbling and */ +/* > invest in an (expensive) multi-shift QR sweep. */ +/* > If the aggressive early deflation subroutine */ +/* > finds LD converged eigenvalues from an order */ +/* > NW deflation window and LD > (NW*NIBBLE)/100, */ +/* > then the next QR sweep is skipped and early */ +/* > deflation is applied immediately to the */ +/* > remaining active diagonal block. Setting */ +/* > IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a */ +/* > multi-shift QR sweep whenever early deflation */ +/* > finds a converged eigenvalue. Setting */ +/* > IPARMQ(ISPEC=14) greater than or equal to 100 */ +/* > prevents TTQRE from skipping a multi-shift */ +/* > QR sweep. */ +/* > */ +/* > ISPEC=15: (NSHFTS) The number of simultaneous shifts in */ +/* > a multi-shift QR iteration. */ +/* > */ +/* > ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the */ +/* > following meanings. */ +/* > 0: During the multi-shift QR/QZ sweep, */ +/* > blocked eigenvalue reordering, blocked */ +/* > Hessenberg-triangular reduction, */ +/* > reflections and/or rotations are not */ +/* > accumulated when updating the */ +/* > far-from-diagonal matrix entries. */ +/* > 1: During the multi-shift QR/QZ sweep, */ +/* > blocked eigenvalue reordering, blocked */ +/* > Hessenberg-triangular reduction, */ +/* > reflections and/or rotations are */ +/* > accumulated, and matrix-matrix */ +/* > multiplication is used to update the */ +/* > far-from-diagonal matrix entries. */ +/* > 2: During the multi-shift QR/QZ sweep, */ +/* > blocked eigenvalue reordering, blocked */ +/* > Hessenberg-triangular reduction, */ +/* > reflections and/or rotations are */ +/* > accumulated, and 2-by-2 block structure */ +/* > is exploited during matrix-matrix */ +/* > multiplies. */ +/* > (If xTRMM is slower than xGEMM, then */ +/* > IPARMQ(ISPEC=16)=1 may be more efficient than */ +/* > IPARMQ(ISPEC=16)=2 despite the greater level of */ +/* > arithmetic work implied by the latter choice.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NAME */ +/* > \verbatim */ +/* > NAME is CHARACTER string */ +/* > Name of the calling subroutine */ +/* > \endverbatim */ +/* > */ +/* > \param[in] OPTS */ +/* > \verbatim */ +/* > OPTS is CHARACTER string */ +/* > This is a concatenation of the string arguments to */ +/* > TTQRE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > N is the order of the Hessenberg matrix H. */ +/* > \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. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The amount of workspace available. */ +/* > \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 Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Little is known about how best to choose these parameters. */ +/* > It is possible to use different values of the parameters */ +/* > for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. */ +/* > */ +/* > It is probably best to choose different parameters for */ +/* > different matrices and different parameters at different */ +/* > times during the iteration, but this has not been */ +/* > implemented --- yet. */ +/* > */ +/* > */ +/* > The best choices of most of the parameters depend */ +/* > in an ill-understood way on the relative execution */ +/* > rate of xLAQR3 and xLAQR5 and on the nature of each */ +/* > particular eigenvalue problem. Experiment may be the */ +/* > only practical way to determine which choices are most */ +/* > effective. */ +/* > */ +/* > Following is a list of default values supplied by IPARMQ. */ +/* > These defaults may be adjusted in order to attain better */ +/* > performance in any particular computational environment. */ +/* > */ +/* > IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. */ +/* > Default: 75. (Must be at least 11.) */ +/* > */ +/* > IPARMQ(ISPEC=13) Recommended deflation window size. */ +/* > This depends on ILO, IHI and NS, the */ +/* > number of simultaneous shifts returned */ +/* > by IPARMQ(ISPEC=15). The default for */ +/* > (IHI-ILO+1) <= 500 is NS. The default */ +/* > for (IHI-ILO+1) > 500 is 3*NS/2. */ +/* > */ +/* > IPARMQ(ISPEC=14) Nibble crossover point. Default: 14. */ +/* > */ +/* > IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. */ +/* > a multi-shift QR iteration. */ +/* > */ +/* > If IHI-ILO+1 is ... */ +/* > */ +/* > greater than ...but less ... the */ +/* > or equal to ... than default is */ +/* > */ +/* > 0 30 NS = 2+ */ +/* > 30 60 NS = 4+ */ +/* > 60 150 NS = 10 */ +/* > 150 590 NS = ** */ +/* > 590 3000 NS = 64 */ +/* > 3000 6000 NS = 128 */ +/* > 6000 infinity NS = 256 */ +/* > */ +/* > (+) By default matrices of this order are */ +/* > passed to the implicit double shift routine */ +/* > xLAHQR. See IPARMQ(ISPEC=12) above. These */ +/* > values of NS are used only in case of a rare */ +/* > xLAHQR failure. */ +/* > */ +/* > (**) The asterisks (**) indicate an ad-hoc */ +/* > function increasing from 10 to 64. */ +/* > */ +/* > IPARMQ(ISPEC=16) Select structured matrix multiply. */ +/* > (See ISPEC=16 above for details.) */ +/* > Default: 3. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +integer iparmq_(integer *ispec, char *name__, char *opts, integer *n, integer + *ilo, integer *ihi, integer *lwork) +{ + /* System generated locals */ + integer ret_val, i__1, i__2; + real r__1; + + /* Local variables */ + integer i__, ic, nh, ns, iz; + char subnam[6]; + integer name_len; + +/* -- 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 */ + + +/* ================================================================ */ + if (*ispec == 15 || *ispec == 13 || *ispec == 16) { + +/* ==== Set the number simultaneous shifts ==== */ + + nh = *ihi - *ilo + 1; + ns = 2; + if (nh >= 30) { + ns = 4; + } + if (nh >= 60) { + ns = 10; + } + if (nh >= 150) { +/* Computing MAX */ + r__1 = log((real) nh) / log(2.f); + i__1 = 10, i__2 = nh / i_nint(&r__1); + ns = f2cmax(i__1,i__2); + } + if (nh >= 590) { + ns = 64; + } + if (nh >= 3000) { + ns = 128; + } + if (nh >= 6000) { + ns = 256; + } +/* Computing MAX */ + i__1 = 2, i__2 = ns - ns % 2; + ns = f2cmax(i__1,i__2); + } + + if (*ispec == 12) { + + +/* ===== Matrices of order smaller than NMIN get sent */ +/* . to xLAHQR, the classic double shift algorithm. */ +/* . This must be at least 11. ==== */ + + ret_val = 75; + + } else if (*ispec == 14) { + +/* ==== INIBL: skip a multi-shift qr iteration and */ +/* . whenever aggressive early deflation finds */ +/* . at least (NIBBLE*(window size)/100) deflations. ==== */ + + ret_val = 14; + + } else if (*ispec == 15) { + +/* ==== NSHFTS: The number of simultaneous shifts ===== */ + + ret_val = ns; + + } else if (*ispec == 13) { + +/* ==== NW: deflation window size. ==== */ + + if (nh <= 500) { + ret_val = ns; + } else { + ret_val = ns * 3 / 2; + } + + } else if (*ispec == 16) { + +/* ==== IACC22: Whether to accumulate reflections */ +/* . before updating the far-from-diagonal elements */ +/* . and whether to use 2-by-2 block structure while */ +/* . doing it. A small amount of work could be saved */ +/* . by making this choice dependent also upon the */ +/* . NH=IHI-ILO+1. */ + + +/* Convert NAME to upper case if the first character is lower case. */ + + ret_val = 0; + s_copy(subnam, name__, (ftnlen)6, name_len); + ic = *(unsigned char *)subnam; + iz = 'Z'; + if (iz == 90 || iz == 122) { + +/* ASCII character set */ + + if (ic >= 97 && ic <= 122) { + *(unsigned char *)subnam = (char) (ic - 32); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 97 && ic <= 122) { + *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); + } + } + } + + } else if (iz == 233 || iz == 169) { + +/* EBCDIC character set */ + + if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 + && ic <= 169) { + *(unsigned char *)subnam = (char) (ic + 64); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || + ic >= 162 && ic <= 169) { + *(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64); + } + } + } + + } else if (iz == 218 || iz == 250) { + +/* Prime machines: ASCII+128 */ + + if (ic >= 225 && ic <= 250) { + *(unsigned char *)subnam = (char) (ic - 32); + for (i__ = 2; i__ <= 6; ++i__) { + ic = *(unsigned char *)&subnam[i__ - 1]; + if (ic >= 225 && ic <= 250) { + *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32); + } + } + } + } + + if (s_cmp(subnam + 1, "GGHRD", (ftnlen)5, (ftnlen)5) == 0 || s_cmp( + subnam + 1, "GGHD3", (ftnlen)5, (ftnlen)5) == 0) { + ret_val = 1; + if (nh >= 14) { + ret_val = 2; + } + } else if (s_cmp(subnam + 3, "EXC", (ftnlen)3, (ftnlen)3) == 0) { + if (nh >= 14) { + ret_val = 1; + } + if (nh >= 14) { + ret_val = 2; + } + } else if (s_cmp(subnam + 1, "HSEQR", (ftnlen)5, (ftnlen)5) == 0 || + s_cmp(subnam + 1, "LAQR", (ftnlen)4, (ftnlen)4) == 0) { + if (ns >= 14) { + ret_val = 1; + } + if (ns >= 14) { + ret_val = 2; + } + } + + } else { +/* ===== invalid value of ispec ===== */ + ret_val = -1; + + } + +/* ==== End of IPARMQ ==== */ + + return ret_val; +} /* iparmq_ */ + diff --git a/lapack-netlib/SRC/izmax1.c b/lapack-netlib/SRC/izmax1.c new file mode 100644 index 000000000..02473940b --- /dev/null +++ b/lapack-netlib/SRC/izmax1.c @@ -0,0 +1,533 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b IZMAX1 finds the index of the first vector element of maximum absolute value. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download IZMAX1 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* INTEGER FUNCTION IZMAX1( N, ZX, INCX ) */ + +/* INTEGER INCX, N */ +/* COMPLEX*16 ZX( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > IZMAX1 finds the index of the first vector element of maximum absolute value. */ +/* > */ +/* > Based on IZAMAX from Level 1 BLAS. */ +/* > The change is to use the 'genuine' absolute value. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of elements in the vector ZX. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ZX */ +/* > \verbatim */ +/* > ZX is COMPLEX*16 array, dimension (N) */ +/* > The vector ZX. The IZMAX1 function returns the index of its first */ +/* > element of maximum absolute value. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The spacing between successive values of ZX. INCX >= 1. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date February 2014 */ + +/* > \ingroup complexOTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Nick Higham for use with ZLACON. */ + +/* ===================================================================== */ +integer izmax1_(integer *n, doublecomplex *zx, integer *incx) +{ + /* System generated locals */ + integer ret_val, i__1; + + /* Local variables */ + doublereal dmax__; + integer i__, ix; + + +/* -- 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..-- */ +/* February 2014 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --zx; + + /* Function Body */ + ret_val = 0; + if (*n < 1 || *incx <= 0) { + return ret_val; + } + ret_val = 1; + if (*n == 1) { + return ret_val; + } + if (*incx == 1) { + +/* code for increment equal to 1 */ + + dmax__ = z_abs(&zx[1]); + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if (z_abs(&zx[i__]) > dmax__) { + ret_val = i__; + dmax__ = z_abs(&zx[i__]); + } + } + } else { + +/* code for increment not equal to 1 */ + + ix = 1; + dmax__ = z_abs(&zx[1]); + ix += *incx; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + if (z_abs(&zx[ix]) > dmax__) { + ret_val = i__; + dmax__ = z_abs(&zx[ix]); + } + ix += *incx; + } + } + return ret_val; + +/* End of IZMAX1 */ + +} /* izmax1_ */ + diff --git a/lapack-netlib/SRC/lsamen.c b/lapack-netlib/SRC/lsamen.c new file mode 100644 index 000000000..0c27e7682 --- /dev/null +++ b/lapack-netlib/SRC/lsamen.c @@ -0,0 +1,510 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +//#define i_len(s, n) (n) +#define i_len(s, n) strlen(s) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b LSAMEN */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download LSAMEN + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* LOGICAL FUNCTION LSAMEN( N, CA, CB ) */ + +/* CHARACTER*( * ) CA, CB */ +/* INTEGER N */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > LSAMEN tests if the first N letters of CA are the same as the */ +/* > first N letters of CB, regardless of case. */ +/* > LSAMEN returns .TRUE. if CA and CB are equivalent except for case */ +/* > and .FALSE. otherwise. LSAMEN also returns .FALSE. if LEN( CA ) */ +/* > or LEN( CB ) is less than N. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of characters in CA and CB to be compared. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CA */ +/* > \verbatim */ +/* > CA is CHARACTER*(*) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CB */ +/* > \verbatim */ +/* > CB is CHARACTER*(*) */ +/* > CA and CB specify two character strings of length at least N. */ +/* > Only the first N characters of each string will be accessed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup OTHERauxiliary */ + +/* ===================================================================== */ +logical lsamen_(integer *n, char *ca, char *cb) +{ + /* System generated locals */ + integer i__1; + logical ret_val; + + /* Local variables */ + integer i__; + extern logical lsame_(char *, char *); + integer ca_len,cb_len; + +/* -- 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 */ + + +/* ===================================================================== */ + + ret_val = FALSE_; + if (i_len(ca, ca_len) < *n || i_len(cb, cb_len) < *n) { + goto L20; + } + +/* Do for each character in the two strings. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Test if the characters are equal using LSAME. */ + + if (! lsame_(ca + (i__ - 1), cb + (i__ - 1))) { + goto L20; + } + +/* L10: */ + } + ret_val = TRUE_; + +L20: + return ret_val; + +/* End of LSAMEN */ + +} /* lsamen_ */ + diff --git a/lapack-netlib/SRC/sbbcsd.c b/lapack-netlib/SRC/sbbcsd.c new file mode 100644 index 000000000..970451df5 --- /dev/null +++ b/lapack-netlib/SRC/sbbcsd.c @@ -0,0 +1,1677 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SBBCSD */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SBBCSD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SBBCSD( JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, */ +/* THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, */ +/* V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, */ +/* B22D, B22E, WORK, LWORK, INFO ) */ + +/* CHARACTER JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS */ +/* INTEGER INFO, LDU1, LDU2, LDV1T, LDV2T, LWORK, M, P, Q */ +/* REAL B11D( * ), B11E( * ), B12D( * ), B12E( * ), */ +/* $ B21D( * ), B21E( * ), B22D( * ), B22E( * ), */ +/* $ PHI( * ), THETA( * ), WORK( * ) */ +/* REAL U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ), */ +/* $ V2T( LDV2T, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SBBCSD computes the CS decomposition of an orthogonal matrix in */ +/* > bidiagonal-block form, */ +/* > */ +/* > */ +/* > [ B11 | B12 0 0 ] */ +/* > [ 0 | 0 -I 0 ] */ +/* > X = [----------------] */ +/* > [ B21 | B22 0 0 ] */ +/* > [ 0 | 0 0 I ] */ +/* > */ +/* > [ C | -S 0 0 ] */ +/* > [ U1 | ] [ 0 | 0 -I 0 ] [ V1 | ]**T */ +/* > = [---------] [---------------] [---------] . */ +/* > [ | U2 ] [ S | C 0 0 ] [ | V2 ] */ +/* > [ 0 | 0 0 I ] */ +/* > */ +/* > X is M-by-M, its top-left block is P-by-Q, and Q must be no larger */ +/* > than P, M-P, or M-Q. (If Q is not the smallest index, then X must be */ +/* > transposed and/or permuted. This can be done in constant time using */ +/* > the TRANS and SIGNS options. See SORCSD for details.) */ +/* > */ +/* > The bidiagonal matrices B11, B12, B21, and B22 are represented */ +/* > implicitly by angles THETA(1:Q) and PHI(1:Q-1). */ +/* > */ +/* > The orthogonal matrices U1, U2, V1T, and V2T are input/output. */ +/* > The input matrices are pre- or post-multiplied by the appropriate */ +/* > singular vector matrices. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBU1 */ +/* > \verbatim */ +/* > JOBU1 is CHARACTER */ +/* > = 'Y': U1 is updated; */ +/* > otherwise: U1 is not updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBU2 */ +/* > \verbatim */ +/* > JOBU2 is CHARACTER */ +/* > = 'Y': U2 is updated; */ +/* > otherwise: U2 is not updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBV1T */ +/* > \verbatim */ +/* > JOBV1T is CHARACTER */ +/* > = 'Y': V1T is updated; */ +/* > otherwise: V1T is not updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBV2T */ +/* > \verbatim */ +/* > JOBV2T is CHARACTER */ +/* > = 'Y': V2T is updated; */ +/* > otherwise: V2T is not updated. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER */ +/* > = 'T': X, U1, U2, V1T, and V2T are stored in row-major */ +/* > order; */ +/* > otherwise: X, U1, U2, V1T, and V2T are stored in column- */ +/* > major order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows and columns in X, the orthogonal matrix in */ +/* > bidiagonal-block form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] P */ +/* > \verbatim */ +/* > P is INTEGER */ +/* > The number of rows in the top-left block of X. 0 <= P <= M. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Q */ +/* > \verbatim */ +/* > Q is INTEGER */ +/* > The number of columns in the top-left block of X. */ +/* > 0 <= Q <= MIN(P,M-P,M-Q). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] THETA */ +/* > \verbatim */ +/* > THETA is REAL array, dimension (Q) */ +/* > On entry, the angles THETA(1),...,THETA(Q) that, along with */ +/* > PHI(1), ...,PHI(Q-1), define the matrix in bidiagonal-block */ +/* > form. On exit, the angles whose cosines and sines define the */ +/* > diagonal blocks in the CS decomposition. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] PHI */ +/* > \verbatim */ +/* > PHI is REAL array, dimension (Q-1) */ +/* > The angles PHI(1),...,PHI(Q-1) that, along with THETA(1),..., */ +/* > THETA(Q), define the matrix in bidiagonal-block form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] U1 */ +/* > \verbatim */ +/* > U1 is REAL array, dimension (LDU1,P) */ +/* > On entry, a P-by-P matrix. On exit, U1 is postmultiplied */ +/* > by the left singular vector matrix common to [ B11 ; 0 ] and */ +/* > [ B12 0 0 ; 0 -I 0 0 ]. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU1 */ +/* > \verbatim */ +/* > LDU1 is INTEGER */ +/* > The leading dimension of the array U1, LDU1 >= MAX(1,P). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] U2 */ +/* > \verbatim */ +/* > U2 is REAL array, dimension (LDU2,M-P) */ +/* > On entry, an (M-P)-by-(M-P) matrix. On exit, U2 is */ +/* > postmultiplied by the left singular vector matrix common to */ +/* > [ B21 ; 0 ] and [ B22 0 0 ; 0 0 I ]. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU2 */ +/* > \verbatim */ +/* > LDU2 is INTEGER */ +/* > The leading dimension of the array U2, LDU2 >= MAX(1,M-P). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] V1T */ +/* > \verbatim */ +/* > V1T is REAL array, dimension (LDV1T,Q) */ +/* > On entry, a Q-by-Q matrix. On exit, V1T is premultiplied */ +/* > by the transpose of the right singular vector */ +/* > matrix common to [ B11 ; 0 ] and [ B21 ; 0 ]. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV1T */ +/* > \verbatim */ +/* > LDV1T is INTEGER */ +/* > The leading dimension of the array V1T, LDV1T >= MAX(1,Q). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] V2T */ +/* > \verbatim */ +/* > V2T is REAL array, dimension (LDV2T,M-Q) */ +/* > On entry, an (M-Q)-by-(M-Q) matrix. On exit, V2T is */ +/* > premultiplied by the transpose of the right */ +/* > singular vector matrix common to [ B12 0 0 ; 0 -I 0 ] and */ +/* > [ B22 0 0 ; 0 0 I ]. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDV2T */ +/* > \verbatim */ +/* > LDV2T is INTEGER */ +/* > The leading dimension of the array V2T, LDV2T >= MAX(1,M-Q). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B11D */ +/* > \verbatim */ +/* > B11D is REAL array, dimension (Q) */ +/* > When SBBCSD converges, B11D contains the cosines of THETA(1), */ +/* > ..., THETA(Q). If SBBCSD fails to converge, then B11D */ +/* > contains the diagonal of the partially reduced top-left */ +/* > block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B11E */ +/* > \verbatim */ +/* > B11E is REAL array, dimension (Q-1) */ +/* > When SBBCSD converges, B11E contains zeros. If SBBCSD fails */ +/* > to converge, then B11E contains the superdiagonal of the */ +/* > partially reduced top-left block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B12D */ +/* > \verbatim */ +/* > B12D is REAL array, dimension (Q) */ +/* > When SBBCSD converges, B12D contains the negative sines of */ +/* > THETA(1), ..., THETA(Q). If SBBCSD fails to converge, then */ +/* > B12D contains the diagonal of the partially reduced top-right */ +/* > block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B12E */ +/* > \verbatim */ +/* > B12E is REAL array, dimension (Q-1) */ +/* > When SBBCSD converges, B12E contains zeros. If SBBCSD fails */ +/* > to converge, then B12E contains the subdiagonal of the */ +/* > partially reduced top-right block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B21D */ +/* > \verbatim */ +/* > B21D is REAL array, dimension (Q) */ +/* > When SBBCSD converges, B21D contains the negative sines of */ +/* > THETA(1), ..., THETA(Q). If SBBCSD fails to converge, then */ +/* > B21D contains the diagonal of the partially reduced bottom-left */ +/* > block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B21E */ +/* > \verbatim */ +/* > B21E is REAL array, dimension (Q-1) */ +/* > When SBBCSD converges, B21E contains zeros. If SBBCSD fails */ +/* > to converge, then B21E contains the subdiagonal of the */ +/* > partially reduced bottom-left block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B22D */ +/* > \verbatim */ +/* > B22D is REAL array, dimension (Q) */ +/* > When SBBCSD converges, B22D contains the negative sines of */ +/* > THETA(1), ..., THETA(Q). If SBBCSD fails to converge, then */ +/* > B22D contains the diagonal of the partially reduced bottom-right */ +/* > block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] B22E */ +/* > \verbatim */ +/* > B22E is REAL array, dimension (Q-1) */ +/* > When SBBCSD converges, B22E contains zeros. If SBBCSD fails */ +/* > to converge, then B22E contains the subdiagonal of the */ +/* > partially reduced bottom-right block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= MAX(1,8*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. */ +/* > > 0: if SBBCSD did not converge, INFO specifies the number */ +/* > of nonzero entries in PHI, and B11D, B11E, etc., */ +/* > contain the partially reduced matrix. */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > TOLMUL REAL, default = MAX(10,MIN(100,EPS**(-1/8))) */ +/* > TOLMUL controls the convergence criterion of the QR loop. */ +/* > Angles THETA(i), PHI(i) are rounded to 0 or PI/2 when they */ +/* > are within TOLMUL*EPS of either bound. */ +/* > \endverbatim */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > [1] Brian D. Sutton. Computing the complete CS decomposition. Numer. */ +/* > Algorithms, 50(1):33-65, 2009. */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup realOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int sbbcsd_(char *jobu1, char *jobu2, char *jobv1t, char * + jobv2t, char *trans, integer *m, integer *p, integer *q, real *theta, + real *phi, real *u1, integer *ldu1, real *u2, integer *ldu2, real * + v1t, integer *ldv1t, real *v2t, integer *ldv2t, real *b11d, real * + b11e, real *b12d, real *b12e, real *b21d, real *b21e, real *b22d, + real *b22e, real *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer u1_dim1, u1_offset, u2_dim1, u2_offset, v1t_dim1, v1t_offset, + v2t_dim1, v2t_offset, i__1, i__2; + real r__1, r__2, r__3, r__4; + doublereal d__1; + + /* Local variables */ + integer imin, mini, imax, iter; + real unfl, temp; + logical colmajor; + real thetamin, thetamax; + logical restart11, restart12, restart21, restart22; + integer lworkmin, iu1cs, iu2cs; + extern /* Subroutine */ int slas2_(real *, real *, real *, real *, real *) + ; + integer iu1sn, iu2sn, lworkopt, i__, j; + real r__; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + integer maxit; + extern /* Subroutine */ int slasr_(char *, char *, char *, integer *, + integer *, real *, real *, real *, integer *); + real dummy; + extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, + integer *); + real x1, x2, y1, y2; + integer iv1tcs, iv2tcs; + logical wantu1, wantu2; + integer iv1tsn, iv2tsn; + real mu, nu, sigma11, sigma21; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real thresh, tolmul; + extern /* Subroutine */ int mecago_(); + logical lquery; + real b11bulge; + logical wantv1t, wantv2t; + real b12bulge, b21bulge, b22bulge, eps, tol; + extern /* Subroutine */ int slartgp_(real *, real *, real *, real *, real + *), slartgs_(real *, real *, real *, real *, real *); + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* =================================================================== */ + + + +/* Test input arguments */ + + /* Parameter adjustments */ + --theta; + --phi; + u1_dim1 = *ldu1; + u1_offset = 1 + u1_dim1 * 1; + u1 -= u1_offset; + u2_dim1 = *ldu2; + u2_offset = 1 + u2_dim1 * 1; + u2 -= u2_offset; + v1t_dim1 = *ldv1t; + v1t_offset = 1 + v1t_dim1 * 1; + v1t -= v1t_offset; + v2t_dim1 = *ldv2t; + v2t_offset = 1 + v2t_dim1 * 1; + v2t -= v2t_offset; + --b11d; + --b11e; + --b12d; + --b12e; + --b21d; + --b21e; + --b22d; + --b22e; + --work; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1; + wantu1 = lsame_(jobu1, "Y"); + wantu2 = lsame_(jobu2, "Y"); + wantv1t = lsame_(jobv1t, "Y"); + wantv2t = lsame_(jobv2t, "Y"); + colmajor = ! lsame_(trans, "T"); + + if (*m < 0) { + *info = -6; + } else if (*p < 0 || *p > *m) { + *info = -7; + } else if (*q < 0 || *q > *m) { + *info = -8; + } else if (*q > *p || *q > *m - *p || *q > *m - *q) { + *info = -8; + } else if (wantu1 && *ldu1 < *p) { + *info = -12; + } else if (wantu2 && *ldu2 < *m - *p) { + *info = -14; + } else if (wantv1t && *ldv1t < *q) { + *info = -16; + } else if (wantv2t && *ldv2t < *m - *q) { + *info = -18; + } + +/* Quick return if Q = 0 */ + + if (*info == 0 && *q == 0) { + lworkmin = 1; + work[1] = (real) lworkmin; + return 0; + } + +/* Compute workspace */ + + if (*info == 0) { + iu1cs = 1; + iu1sn = iu1cs + *q; + iu2cs = iu1sn + *q; + iu2sn = iu2cs + *q; + iv1tcs = iu2sn + *q; + iv1tsn = iv1tcs + *q; + iv2tcs = iv1tsn + *q; + iv2tsn = iv2tcs + *q; + lworkopt = iv2tsn + *q - 1; + lworkmin = lworkopt; + work[1] = (real) lworkopt; + if (*lwork < lworkmin && ! lquery) { + *info = -28; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("SBBCSD", &i__1,(ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Get machine constants */ + + eps = slamch_("Epsilon"); + unfl = slamch_("Safe minimum"); +/* Computing MAX */ +/* Computing MIN */ + d__1 = (doublereal) eps; + r__3 = 100.f, r__4 = pow_dd(&d__1, &c_b10); + r__1 = 10.f, r__2 = f2cmin(r__3,r__4); + tolmul = f2cmax(r__1,r__2); + tol = tolmul * eps; +/* Computing MAX */ + r__1 = tol, r__2 = *q * 6 * *q * unfl; + thresh = f2cmax(r__1,r__2); + +/* Test for negligible sines or cosines */ + + i__1 = *q; + for (i__ = 1; i__ <= i__1; ++i__) { + if (theta[i__] < thresh) { + theta[i__] = 0.f; + } else if (theta[i__] > 1.57079632679489662f - thresh) { + theta[i__] = 1.57079632679489662f; + } + } + i__1 = *q - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + if (phi[i__] < thresh) { + phi[i__] = 0.f; + } else if (phi[i__] > 1.57079632679489662f - thresh) { + phi[i__] = 1.57079632679489662f; + } + } + +/* Initial deflation */ + + imax = *q; + while(imax > 1) { + if (phi[imax - 1] != 0.f) { + myexit_(); + } + --imax; + } + imin = imax - 1; + if (imin > 1) { + while(phi[imin - 1] != 0.f) { + --imin; + if (imin <= 1) { + myexit_(); + } + } + } + +/* Initialize iteration counter */ + + maxit = *q * 6 * *q; + iter = 0; + +/* Begin main iteration loop */ + + while(imax > 1) { + +/* Compute the matrix entries */ + + b11d[imin] = cos(theta[imin]); + b21d[imin] = -sin(theta[imin]); + i__1 = imax - 1; + for (i__ = imin; i__ <= i__1; ++i__) { + b11e[i__] = -sin(theta[i__]) * sin(phi[i__]); + b11d[i__ + 1] = cos(theta[i__ + 1]) * cos(phi[i__]); + b12d[i__] = sin(theta[i__]) * cos(phi[i__]); + b12e[i__] = cos(theta[i__ + 1]) * sin(phi[i__]); + b21e[i__] = -cos(theta[i__]) * sin(phi[i__]); + b21d[i__ + 1] = -sin(theta[i__ + 1]) * cos(phi[i__]); + b22d[i__] = cos(theta[i__]) * cos(phi[i__]); + b22e[i__] = -sin(theta[i__ + 1]) * sin(phi[i__]); + } + b12d[imax] = sin(theta[imax]); + b22d[imax] = cos(theta[imax]); + +/* Abort if not converging; otherwise, increment ITER */ + + if (iter > maxit) { + *info = 0; + i__1 = *q; + for (i__ = 1; i__ <= i__1; ++i__) { + if (phi[i__] != 0.f) { + ++(*info); + } + } + return 0; + } + + iter = iter + imax - imin; + +/* Compute shifts */ + + thetamax = theta[imin]; + thetamin = theta[imin]; + i__1 = imax; + for (i__ = imin + 1; i__ <= i__1; ++i__) { + if (theta[i__] > thetamax) { + thetamax = theta[i__]; + } + if (theta[i__] < thetamin) { + thetamin = theta[i__]; + } + } + + if (thetamax > 1.57079632679489662f - thresh) { + +/* Zero on diagonals of B11 and B22; induce deflation with a */ +/* zero shift */ + + mu = 0.f; + nu = 1.f; + + } else if (thetamin < thresh) { + +/* Zero on diagonals of B12 and B22; induce deflation with a */ +/* zero shift */ + + mu = 1.f; + nu = 0.f; + + } else { + +/* Compute shifts for B11 and B21 and use the lesser */ + + slas2_(&b11d[imax - 1], &b11e[imax - 1], &b11d[imax], &sigma11, & + dummy); + slas2_(&b21d[imax - 1], &b21e[imax - 1], &b21d[imax], &sigma21, & + dummy); + + if (sigma11 <= sigma21) { + mu = sigma11; +/* Computing 2nd power */ + r__1 = mu; + nu = sqrt(1.f - r__1 * r__1); + if (mu < thresh) { + mu = 0.f; + nu = 1.f; + } + } else { + nu = sigma21; +/* Computing 2nd power */ + r__1 = nu; + mu = sqrt(1.f - r__1 * r__1); + if (nu < thresh) { + mu = 1.f; + nu = 0.f; + } + } + } + +/* Rotate to produce bulges in B11 and B21 */ + + if (mu <= nu) { + slartgs_(&b11d[imin], &b11e[imin], &mu, &work[iv1tcs + imin - 1], + &work[iv1tsn + imin - 1]); + } else { + slartgs_(&b21d[imin], &b21e[imin], &nu, &work[iv1tcs + imin - 1], + &work[iv1tsn + imin - 1]); + } + + temp = work[iv1tcs + imin - 1] * b11d[imin] + work[iv1tsn + imin - 1] + * b11e[imin]; + b11e[imin] = work[iv1tcs + imin - 1] * b11e[imin] - work[iv1tsn + + imin - 1] * b11d[imin]; + b11d[imin] = temp; + b11bulge = work[iv1tsn + imin - 1] * b11d[imin + 1]; + b11d[imin + 1] = work[iv1tcs + imin - 1] * b11d[imin + 1]; + temp = work[iv1tcs + imin - 1] * b21d[imin] + work[iv1tsn + imin - 1] + * b21e[imin]; + b21e[imin] = work[iv1tcs + imin - 1] * b21e[imin] - work[iv1tsn + + imin - 1] * b21d[imin]; + b21d[imin] = temp; + b21bulge = work[iv1tsn + imin - 1] * b21d[imin + 1]; + b21d[imin + 1] = work[iv1tcs + imin - 1] * b21d[imin + 1]; + +/* Compute THETA(IMIN) */ + +/* Computing 2nd power */ + r__1 = b21d[imin]; +/* Computing 2nd power */ + r__2 = b21bulge; +/* Computing 2nd power */ + r__3 = b11d[imin]; +/* Computing 2nd power */ + r__4 = b11bulge; + theta[imin] = atan2(sqrt(r__1 * r__1 + r__2 * r__2), sqrt(r__3 * r__3 + + r__4 * r__4)); + +/* Chase the bulges in B11(IMIN+1,IMIN) and B21(IMIN+1,IMIN) */ + +/* Computing 2nd power */ + r__1 = b11d[imin]; +/* Computing 2nd power */ + r__2 = b11bulge; +/* Computing 2nd power */ + r__3 = thresh; + if (r__1 * r__1 + r__2 * r__2 > r__3 * r__3) { + slartgp_(&b11bulge, &b11d[imin], &work[iu1sn + imin - 1], &work[ + iu1cs + imin - 1], &r__); + } else if (mu <= nu) { + slartgs_(&b11e[imin], &b11d[imin + 1], &mu, &work[iu1cs + imin - + 1], &work[iu1sn + imin - 1]); + } else { + slartgs_(&b12d[imin], &b12e[imin], &nu, &work[iu1cs + imin - 1], & + work[iu1sn + imin - 1]); + } +/* Computing 2nd power */ + r__1 = b21d[imin]; +/* Computing 2nd power */ + r__2 = b21bulge; +/* Computing 2nd power */ + r__3 = thresh; + if (r__1 * r__1 + r__2 * r__2 > r__3 * r__3) { + slartgp_(&b21bulge, &b21d[imin], &work[iu2sn + imin - 1], &work[ + iu2cs + imin - 1], &r__); + } else if (nu < mu) { + slartgs_(&b21e[imin], &b21d[imin + 1], &nu, &work[iu2cs + imin - + 1], &work[iu2sn + imin - 1]); + } else { + slartgs_(&b22d[imin], &b22e[imin], &mu, &work[iu2cs + imin - 1], & + work[iu2sn + imin - 1]); + } + work[iu2cs + imin - 1] = -work[iu2cs + imin - 1]; + work[iu2sn + imin - 1] = -work[iu2sn + imin - 1]; + + temp = work[iu1cs + imin - 1] * b11e[imin] + work[iu1sn + imin - 1] * + b11d[imin + 1]; + b11d[imin + 1] = work[iu1cs + imin - 1] * b11d[imin + 1] - work[iu1sn + + imin - 1] * b11e[imin]; + b11e[imin] = temp; + if (imax > imin + 1) { + b11bulge = work[iu1sn + imin - 1] * b11e[imin + 1]; + b11e[imin + 1] = work[iu1cs + imin - 1] * b11e[imin + 1]; + } + temp = work[iu1cs + imin - 1] * b12d[imin] + work[iu1sn + imin - 1] * + b12e[imin]; + b12e[imin] = work[iu1cs + imin - 1] * b12e[imin] - work[iu1sn + imin + - 1] * b12d[imin]; + b12d[imin] = temp; + b12bulge = work[iu1sn + imin - 1] * b12d[imin + 1]; + b12d[imin + 1] = work[iu1cs + imin - 1] * b12d[imin + 1]; + temp = work[iu2cs + imin - 1] * b21e[imin] + work[iu2sn + imin - 1] * + b21d[imin + 1]; + b21d[imin + 1] = work[iu2cs + imin - 1] * b21d[imin + 1] - work[iu2sn + + imin - 1] * b21e[imin]; + b21e[imin] = temp; + if (imax > imin + 1) { + b21bulge = work[iu2sn + imin - 1] * b21e[imin + 1]; + b21e[imin + 1] = work[iu2cs + imin - 1] * b21e[imin + 1]; + } + temp = work[iu2cs + imin - 1] * b22d[imin] + work[iu2sn + imin - 1] * + b22e[imin]; + b22e[imin] = work[iu2cs + imin - 1] * b22e[imin] - work[iu2sn + imin + - 1] * b22d[imin]; + b22d[imin] = temp; + b22bulge = work[iu2sn + imin - 1] * b22d[imin + 1]; + b22d[imin + 1] = work[iu2cs + imin - 1] * b22d[imin + 1]; + +/* Inner loop: chase bulges from B11(IMIN,IMIN+2), */ +/* B12(IMIN,IMIN+1), B21(IMIN,IMIN+2), and B22(IMIN,IMIN+1) to */ +/* bottom-right */ + + i__1 = imax - 1; + for (i__ = imin + 1; i__ <= i__1; ++i__) { + +/* Compute PHI(I-1) */ + + x1 = sin(theta[i__ - 1]) * b11e[i__ - 1] + cos(theta[i__ - 1]) * + b21e[i__ - 1]; + x2 = sin(theta[i__ - 1]) * b11bulge + cos(theta[i__ - 1]) * + b21bulge; + y1 = sin(theta[i__ - 1]) * b12d[i__ - 1] + cos(theta[i__ - 1]) * + b22d[i__ - 1]; + y2 = sin(theta[i__ - 1]) * b12bulge + cos(theta[i__ - 1]) * + b22bulge; + +/* Computing 2nd power */ + r__1 = x1; +/* Computing 2nd power */ + r__2 = x2; +/* Computing 2nd power */ + r__3 = y1; +/* Computing 2nd power */ + r__4 = y2; + phi[i__ - 1] = atan2(sqrt(r__1 * r__1 + r__2 * r__2), sqrt(r__3 * + r__3 + r__4 * r__4)); + +/* Determine if there are bulges to chase or if a new direct */ +/* summand has been reached */ + +/* Computing 2nd power */ + r__1 = b11e[i__ - 1]; +/* Computing 2nd power */ + r__2 = b11bulge; +/* Computing 2nd power */ + r__3 = thresh; + restart11 = r__1 * r__1 + r__2 * r__2 <= r__3 * r__3; +/* Computing 2nd power */ + r__1 = b21e[i__ - 1]; +/* Computing 2nd power */ + r__2 = b21bulge; +/* Computing 2nd power */ + r__3 = thresh; + restart21 = r__1 * r__1 + r__2 * r__2 <= r__3 * r__3; +/* Computing 2nd power */ + r__1 = b12d[i__ - 1]; +/* Computing 2nd power */ + r__2 = b12bulge; +/* Computing 2nd power */ + r__3 = thresh; + restart12 = r__1 * r__1 + r__2 * r__2 <= r__3 * r__3; +/* Computing 2nd power */ + r__1 = b22d[i__ - 1]; +/* Computing 2nd power */ + r__2 = b22bulge; +/* Computing 2nd power */ + r__3 = thresh; + restart22 = r__1 * r__1 + r__2 * r__2 <= r__3 * r__3; + +/* If possible, chase bulges from B11(I-1,I+1), B12(I-1,I), */ +/* B21(I-1,I+1), and B22(I-1,I). If necessary, restart bulge- */ +/* chasing by applying the original shift again. */ + + if (! restart11 && ! restart21) { + slartgp_(&x2, &x1, &work[iv1tsn + i__ - 1], &work[iv1tcs + + i__ - 1], &r__); + } else if (! restart11 && restart21) { + slartgp_(&b11bulge, &b11e[i__ - 1], &work[iv1tsn + i__ - 1], & + work[iv1tcs + i__ - 1], &r__); + } else if (restart11 && ! restart21) { + slartgp_(&b21bulge, &b21e[i__ - 1], &work[iv1tsn + i__ - 1], & + work[iv1tcs + i__ - 1], &r__); + } else if (mu <= nu) { + slartgs_(&b11d[i__], &b11e[i__], &mu, &work[iv1tcs + i__ - 1], + &work[iv1tsn + i__ - 1]); + } else { + slartgs_(&b21d[i__], &b21e[i__], &nu, &work[iv1tcs + i__ - 1], + &work[iv1tsn + i__ - 1]); + } + work[iv1tcs + i__ - 1] = -work[iv1tcs + i__ - 1]; + work[iv1tsn + i__ - 1] = -work[iv1tsn + i__ - 1]; + if (! restart12 && ! restart22) { + slartgp_(&y2, &y1, &work[iv2tsn + i__ - 2], &work[iv2tcs + + i__ - 2], &r__); + } else if (! restart12 && restart22) { + slartgp_(&b12bulge, &b12d[i__ - 1], &work[iv2tsn + i__ - 2], & + work[iv2tcs + i__ - 2], &r__); + } else if (restart12 && ! restart22) { + slartgp_(&b22bulge, &b22d[i__ - 1], &work[iv2tsn + i__ - 2], & + work[iv2tcs + i__ - 2], &r__); + } else if (nu < mu) { + slartgs_(&b12e[i__ - 1], &b12d[i__], &nu, &work[iv2tcs + i__ + - 2], &work[iv2tsn + i__ - 2]); + } else { + slartgs_(&b22e[i__ - 1], &b22d[i__], &mu, &work[iv2tcs + i__ + - 2], &work[iv2tsn + i__ - 2]); + } + + temp = work[iv1tcs + i__ - 1] * b11d[i__] + work[iv1tsn + i__ - 1] + * b11e[i__]; + b11e[i__] = work[iv1tcs + i__ - 1] * b11e[i__] - work[iv1tsn + + i__ - 1] * b11d[i__]; + b11d[i__] = temp; + b11bulge = work[iv1tsn + i__ - 1] * b11d[i__ + 1]; + b11d[i__ + 1] = work[iv1tcs + i__ - 1] * b11d[i__ + 1]; + temp = work[iv1tcs + i__ - 1] * b21d[i__] + work[iv1tsn + i__ - 1] + * b21e[i__]; + b21e[i__] = work[iv1tcs + i__ - 1] * b21e[i__] - work[iv1tsn + + i__ - 1] * b21d[i__]; + b21d[i__] = temp; + b21bulge = work[iv1tsn + i__ - 1] * b21d[i__ + 1]; + b21d[i__ + 1] = work[iv1tcs + i__ - 1] * b21d[i__ + 1]; + temp = work[iv2tcs + i__ - 2] * b12e[i__ - 1] + work[iv2tsn + i__ + - 2] * b12d[i__]; + b12d[i__] = work[iv2tcs + i__ - 2] * b12d[i__] - work[iv2tsn + + i__ - 2] * b12e[i__ - 1]; + b12e[i__ - 1] = temp; + b12bulge = work[iv2tsn + i__ - 2] * b12e[i__]; + b12e[i__] = work[iv2tcs + i__ - 2] * b12e[i__]; + temp = work[iv2tcs + i__ - 2] * b22e[i__ - 1] + work[iv2tsn + i__ + - 2] * b22d[i__]; + b22d[i__] = work[iv2tcs + i__ - 2] * b22d[i__] - work[iv2tsn + + i__ - 2] * b22e[i__ - 1]; + b22e[i__ - 1] = temp; + b22bulge = work[iv2tsn + i__ - 2] * b22e[i__]; + b22e[i__] = work[iv2tcs + i__ - 2] * b22e[i__]; + +/* Compute THETA(I) */ + + x1 = cos(phi[i__ - 1]) * b11d[i__] + sin(phi[i__ - 1]) * b12e[i__ + - 1]; + x2 = cos(phi[i__ - 1]) * b11bulge + sin(phi[i__ - 1]) * b12bulge; + y1 = cos(phi[i__ - 1]) * b21d[i__] + sin(phi[i__ - 1]) * b22e[i__ + - 1]; + y2 = cos(phi[i__ - 1]) * b21bulge + sin(phi[i__ - 1]) * b22bulge; + +/* Computing 2nd power */ + r__1 = y1; +/* Computing 2nd power */ + r__2 = y2; +/* Computing 2nd power */ + r__3 = x1; +/* Computing 2nd power */ + r__4 = x2; + theta[i__] = atan2(sqrt(r__1 * r__1 + r__2 * r__2), sqrt(r__3 * + r__3 + r__4 * r__4)); + +/* Determine if there are bulges to chase or if a new direct */ +/* summand has been reached */ + +/* Computing 2nd power */ + r__1 = b11d[i__]; +/* Computing 2nd power */ + r__2 = b11bulge; +/* Computing 2nd power */ + r__3 = thresh; + restart11 = r__1 * r__1 + r__2 * r__2 <= r__3 * r__3; +/* Computing 2nd power */ + r__1 = b12e[i__ - 1]; +/* Computing 2nd power */ + r__2 = b12bulge; +/* Computing 2nd power */ + r__3 = thresh; + restart12 = r__1 * r__1 + r__2 * r__2 <= r__3 * r__3; +/* Computing 2nd power */ + r__1 = b21d[i__]; +/* Computing 2nd power */ + r__2 = b21bulge; +/* Computing 2nd power */ + r__3 = thresh; + restart21 = r__1 * r__1 + r__2 * r__2 <= r__3 * r__3; +/* Computing 2nd power */ + r__1 = b22e[i__ - 1]; +/* Computing 2nd power */ + r__2 = b22bulge; +/* Computing 2nd power */ + r__3 = thresh; + restart22 = r__1 * r__1 + r__2 * r__2 <= r__3 * r__3; + +/* If possible, chase bulges from B11(I+1,I), B12(I+1,I-1), */ +/* B21(I+1,I), and B22(I+1,I-1). If necessary, restart bulge- */ +/* chasing by applying the original shift again. */ + + if (! restart11 && ! restart12) { + slartgp_(&x2, &x1, &work[iu1sn + i__ - 1], &work[iu1cs + i__ + - 1], &r__); + } else if (! restart11 && restart12) { + slartgp_(&b11bulge, &b11d[i__], &work[iu1sn + i__ - 1], &work[ + iu1cs + i__ - 1], &r__); + } else if (restart11 && ! restart12) { + slartgp_(&b12bulge, &b12e[i__ - 1], &work[iu1sn + i__ - 1], & + work[iu1cs + i__ - 1], &r__); + } else if (mu <= nu) { + slartgs_(&b11e[i__], &b11d[i__ + 1], &mu, &work[iu1cs + i__ - + 1], &work[iu1sn + i__ - 1]); + } else { + slartgs_(&b12d[i__], &b12e[i__], &nu, &work[iu1cs + i__ - 1], + &work[iu1sn + i__ - 1]); + } + if (! restart21 && ! restart22) { + slartgp_(&y2, &y1, &work[iu2sn + i__ - 1], &work[iu2cs + i__ + - 1], &r__); + } else if (! restart21 && restart22) { + slartgp_(&b21bulge, &b21d[i__], &work[iu2sn + i__ - 1], &work[ + iu2cs + i__ - 1], &r__); + } else if (restart21 && ! restart22) { + slartgp_(&b22bulge, &b22e[i__ - 1], &work[iu2sn + i__ - 1], & + work[iu2cs + i__ - 1], &r__); + } else if (nu < mu) { + slartgs_(&b21e[i__], &b21e[i__ + 1], &nu, &work[iu2cs + i__ - + 1], &work[iu2sn + i__ - 1]); + } else { + slartgs_(&b22d[i__], &b22e[i__], &mu, &work[iu2cs + i__ - 1], + &work[iu2sn + i__ - 1]); + } + work[iu2cs + i__ - 1] = -work[iu2cs + i__ - 1]; + work[iu2sn + i__ - 1] = -work[iu2sn + i__ - 1]; + + temp = work[iu1cs + i__ - 1] * b11e[i__] + work[iu1sn + i__ - 1] * + b11d[i__ + 1]; + b11d[i__ + 1] = work[iu1cs + i__ - 1] * b11d[i__ + 1] - work[ + iu1sn + i__ - 1] * b11e[i__]; + b11e[i__] = temp; + if (i__ < imax - 1) { + b11bulge = work[iu1sn + i__ - 1] * b11e[i__ + 1]; + b11e[i__ + 1] = work[iu1cs + i__ - 1] * b11e[i__ + 1]; + } + temp = work[iu2cs + i__ - 1] * b21e[i__] + work[iu2sn + i__ - 1] * + b21d[i__ + 1]; + b21d[i__ + 1] = work[iu2cs + i__ - 1] * b21d[i__ + 1] - work[ + iu2sn + i__ - 1] * b21e[i__]; + b21e[i__] = temp; + if (i__ < imax - 1) { + b21bulge = work[iu2sn + i__ - 1] * b21e[i__ + 1]; + b21e[i__ + 1] = work[iu2cs + i__ - 1] * b21e[i__ + 1]; + } + temp = work[iu1cs + i__ - 1] * b12d[i__] + work[iu1sn + i__ - 1] * + b12e[i__]; + b12e[i__] = work[iu1cs + i__ - 1] * b12e[i__] - work[iu1sn + i__ + - 1] * b12d[i__]; + b12d[i__] = temp; + b12bulge = work[iu1sn + i__ - 1] * b12d[i__ + 1]; + b12d[i__ + 1] = work[iu1cs + i__ - 1] * b12d[i__ + 1]; + temp = work[iu2cs + i__ - 1] * b22d[i__] + work[iu2sn + i__ - 1] * + b22e[i__]; + b22e[i__] = work[iu2cs + i__ - 1] * b22e[i__] - work[iu2sn + i__ + - 1] * b22d[i__]; + b22d[i__] = temp; + b22bulge = work[iu2sn + i__ - 1] * b22d[i__ + 1]; + b22d[i__ + 1] = work[iu2cs + i__ - 1] * b22d[i__ + 1]; + + } + +/* Compute PHI(IMAX-1) */ + + x1 = sin(theta[imax - 1]) * b11e[imax - 1] + cos(theta[imax - 1]) * + b21e[imax - 1]; + y1 = sin(theta[imax - 1]) * b12d[imax - 1] + cos(theta[imax - 1]) * + b22d[imax - 1]; + y2 = sin(theta[imax - 1]) * b12bulge + cos(theta[imax - 1]) * + b22bulge; + +/* Computing 2nd power */ + r__1 = y1; +/* Computing 2nd power */ + r__2 = y2; + phi[imax - 1] = atan2((abs(x1)), sqrt(r__1 * r__1 + r__2 * r__2)); + +/* Chase bulges from B12(IMAX-1,IMAX) and B22(IMAX-1,IMAX) */ + +/* Computing 2nd power */ + r__1 = b12d[imax - 1]; +/* Computing 2nd power */ + r__2 = b12bulge; +/* Computing 2nd power */ + r__3 = thresh; + restart12 = r__1 * r__1 + r__2 * r__2 <= r__3 * r__3; +/* Computing 2nd power */ + r__1 = b22d[imax - 1]; +/* Computing 2nd power */ + r__2 = b22bulge; +/* Computing 2nd power */ + r__3 = thresh; + restart22 = r__1 * r__1 + r__2 * r__2 <= r__3 * r__3; + + if (! restart12 && ! restart22) { + slartgp_(&y2, &y1, &work[iv2tsn + imax - 2], &work[iv2tcs + imax + - 2], &r__); + } else if (! restart12 && restart22) { + slartgp_(&b12bulge, &b12d[imax - 1], &work[iv2tsn + imax - 2], & + work[iv2tcs + imax - 2], &r__); + } else if (restart12 && ! restart22) { + slartgp_(&b22bulge, &b22d[imax - 1], &work[iv2tsn + imax - 2], & + work[iv2tcs + imax - 2], &r__); + } else if (nu < mu) { + slartgs_(&b12e[imax - 1], &b12d[imax], &nu, &work[iv2tcs + imax - + 2], &work[iv2tsn + imax - 2]); + } else { + slartgs_(&b22e[imax - 1], &b22d[imax], &mu, &work[iv2tcs + imax - + 2], &work[iv2tsn + imax - 2]); + } + + temp = work[iv2tcs + imax - 2] * b12e[imax - 1] + work[iv2tsn + imax + - 2] * b12d[imax]; + b12d[imax] = work[iv2tcs + imax - 2] * b12d[imax] - work[iv2tsn + + imax - 2] * b12e[imax - 1]; + b12e[imax - 1] = temp; + temp = work[iv2tcs + imax - 2] * b22e[imax - 1] + work[iv2tsn + imax + - 2] * b22d[imax]; + b22d[imax] = work[iv2tcs + imax - 2] * b22d[imax] - work[iv2tsn + + imax - 2] * b22e[imax - 1]; + b22e[imax - 1] = temp; + +/* Update singular vectors */ + + if (wantu1) { + if (colmajor) { + i__1 = imax - imin + 1; + slasr_("R", "V", "F", p, &i__1, &work[iu1cs + imin - 1], & + work[iu1sn + imin - 1], &u1[imin * u1_dim1 + 1], ldu1); + } else { + i__1 = imax - imin + 1; + slasr_("L", "V", "F", &i__1, p, &work[iu1cs + imin - 1], & + work[iu1sn + imin - 1], &u1[imin + u1_dim1], ldu1); + } + } + if (wantu2) { + if (colmajor) { + i__1 = *m - *p; + i__2 = imax - imin + 1; + slasr_("R", "V", "F", &i__1, &i__2, &work[iu2cs + imin - 1], & + work[iu2sn + imin - 1], &u2[imin * u2_dim1 + 1], ldu2); + } else { + i__1 = imax - imin + 1; + i__2 = *m - *p; + slasr_("L", "V", "F", &i__1, &i__2, &work[iu2cs + imin - 1], & + work[iu2sn + imin - 1], &u2[imin + u2_dim1], ldu2); + } + } + if (wantv1t) { + if (colmajor) { + i__1 = imax - imin + 1; + slasr_("L", "V", "F", &i__1, q, &work[iv1tcs + imin - 1], & + work[iv1tsn + imin - 1], &v1t[imin + v1t_dim1], ldv1t); + } else { + i__1 = imax - imin + 1; + slasr_("R", "V", "F", q, &i__1, &work[iv1tcs + imin - 1], & + work[iv1tsn + imin - 1], &v1t[imin * v1t_dim1 + 1], + ldv1t); + } + } + if (wantv2t) { + if (colmajor) { + i__1 = imax - imin + 1; + i__2 = *m - *q; + slasr_("L", "V", "F", &i__1, &i__2, &work[iv2tcs + imin - 1], + &work[iv2tsn + imin - 1], &v2t[imin + v2t_dim1], + ldv2t); + } else { + i__1 = *m - *q; + i__2 = imax - imin + 1; + slasr_("R", "V", "F", &i__1, &i__2, &work[iv2tcs + imin - 1], + &work[iv2tsn + imin - 1], &v2t[imin * v2t_dim1 + 1], + ldv2t); + } + } + +/* Fix signs on B11(IMAX-1,IMAX) and B21(IMAX-1,IMAX) */ + + if (b11e[imax - 1] + b21e[imax - 1] > 0.f) { + b11d[imax] = -b11d[imax]; + b21d[imax] = -b21d[imax]; + if (wantv1t) { + if (colmajor) { + sscal_(q, &c_b35, &v1t[imax + v1t_dim1], ldv1t); + } else { + sscal_(q, &c_b35, &v1t[imax * v1t_dim1 + 1], &c__1); + } + } + } + +/* Compute THETA(IMAX) */ + + x1 = cos(phi[imax - 1]) * b11d[imax] + sin(phi[imax - 1]) * b12e[imax + - 1]; + y1 = cos(phi[imax - 1]) * b21d[imax] + sin(phi[imax - 1]) * b22e[imax + - 1]; + + theta[imax] = atan2((abs(y1)), (abs(x1))); + +/* Fix signs on B11(IMAX,IMAX), B12(IMAX,IMAX-1), B21(IMAX,IMAX), */ +/* and B22(IMAX,IMAX-1) */ + + if (b11d[imax] + b12e[imax - 1] < 0.f) { + b12d[imax] = -b12d[imax]; + if (wantu1) { + if (colmajor) { + sscal_(p, &c_b35, &u1[imax * u1_dim1 + 1], &c__1); + } else { + sscal_(p, &c_b35, &u1[imax + u1_dim1], ldu1); + } + } + } + if (b21d[imax] + b22e[imax - 1] > 0.f) { + b22d[imax] = -b22d[imax]; + if (wantu2) { + if (colmajor) { + i__1 = *m - *p; + sscal_(&i__1, &c_b35, &u2[imax * u2_dim1 + 1], &c__1); + } else { + i__1 = *m - *p; + sscal_(&i__1, &c_b35, &u2[imax + u2_dim1], ldu2); + } + } + } + +/* Fix signs on B12(IMAX,IMAX) and B22(IMAX,IMAX) */ + + if (b12d[imax] + b22d[imax] < 0.f) { + if (wantv2t) { + if (colmajor) { + i__1 = *m - *q; + sscal_(&i__1, &c_b35, &v2t[imax + v2t_dim1], ldv2t); + } else { + i__1 = *m - *q; + sscal_(&i__1, &c_b35, &v2t[imax * v2t_dim1 + 1], &c__1); + } + } + } + +/* Test for negligible sines or cosines */ + + i__1 = imax; + for (i__ = imin; i__ <= i__1; ++i__) { + if (theta[i__] < thresh) { + theta[i__] = 0.f; + } else if (theta[i__] > 1.57079632679489662f - thresh) { + theta[i__] = 1.57079632679489662f; + } + } + i__1 = imax - 1; + for (i__ = imin; i__ <= i__1; ++i__) { + if (phi[i__] < thresh) { + phi[i__] = 0.f; + } else if (phi[i__] > 1.57079632679489662f - thresh) { + phi[i__] = 1.57079632679489662f; + } + } + +/* Deflate */ + + if (imax > 1) { + while(phi[imax - 1] == 0.f) { + --imax; + if (imax <= 1) { + myexit_(); + } + } + } + if (imin > imax - 1) { + imin = imax - 1; + } + if (imin > 1) { + while(phi[imin - 1] != 0.f) { + --imin; + if (imin <= 1) { + myexit_(); + } + } + } + +/* Repeat main iteration loop */ + + } + +/* Postprocessing: order THETA from least to greatest */ + + i__1 = *q; + for (i__ = 1; i__ <= i__1; ++i__) { + + mini = i__; + thetamin = theta[i__]; + i__2 = *q; + for (j = i__ + 1; j <= i__2; ++j) { + if (theta[j] < thetamin) { + mini = j; + thetamin = theta[j]; + } + } + + if (mini != i__) { + theta[mini] = theta[i__]; + theta[i__] = thetamin; + if (colmajor) { + if (wantu1) { + sswap_(p, &u1[i__ * u1_dim1 + 1], &c__1, &u1[mini * + u1_dim1 + 1], &c__1); + } + if (wantu2) { + i__2 = *m - *p; + sswap_(&i__2, &u2[i__ * u2_dim1 + 1], &c__1, &u2[mini * + u2_dim1 + 1], &c__1); + } + if (wantv1t) { + sswap_(q, &v1t[i__ + v1t_dim1], ldv1t, &v1t[mini + + v1t_dim1], ldv1t); + } + if (wantv2t) { + i__2 = *m - *q; + sswap_(&i__2, &v2t[i__ + v2t_dim1], ldv2t, &v2t[mini + + v2t_dim1], ldv2t); + } + } else { + if (wantu1) { + sswap_(p, &u1[i__ + u1_dim1], ldu1, &u1[mini + u1_dim1], + ldu1); + } + if (wantu2) { + i__2 = *m - *p; + sswap_(&i__2, &u2[i__ + u2_dim1], ldu2, &u2[mini + + u2_dim1], ldu2); + } + if (wantv1t) { + sswap_(q, &v1t[i__ * v1t_dim1 + 1], &c__1, &v1t[mini * + v1t_dim1 + 1], &c__1); + } + if (wantv2t) { + i__2 = *m - *q; + sswap_(&i__2, &v2t[i__ * v2t_dim1 + 1], &c__1, &v2t[mini * + v2t_dim1 + 1], &c__1); + } + } + } + + } + + return 0; + +/* End of SBBCSD */ + +} /* sbbcsd_ */ + diff --git a/lapack-netlib/SRC/sbdsdc.c b/lapack-netlib/SRC/sbdsdc.c new file mode 100644 index 000000000..b3730f19e --- /dev/null +++ b/lapack-netlib/SRC/sbdsdc.c @@ -0,0 +1,965 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SBDSDC */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SBDSDC + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ, */ +/* WORK, IWORK, INFO ) */ + +/* CHARACTER COMPQ, UPLO */ +/* INTEGER INFO, LDU, LDVT, N */ +/* INTEGER IQ( * ), IWORK( * ) */ +/* REAL D( * ), E( * ), Q( * ), U( LDU, * ), */ +/* $ VT( LDVT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SBDSDC computes the singular value decomposition (SVD) of a real */ +/* > N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT, */ +/* > using a divide and conquer method, where S is a diagonal matrix */ +/* > with non-negative diagonal elements (the singular values of B), and */ +/* > U and VT are orthogonal matrices of left and right singular vectors, */ +/* > respectively. SBDSDC can be used to compute all singular values, */ +/* > and optionally, singular vectors or singular vectors in compact form. */ +/* > */ +/* > This code makes very mild assumptions about floating point */ +/* > arithmetic. It will work on machines with a guard digit in */ +/* > add/subtract, or on those binary machines without guard digits */ +/* > which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2. */ +/* > It could conceivably fail on hexadecimal or decimal machines */ +/* > without guard digits, but we know of none. See SLASD3 for details. */ +/* > */ +/* > The code currently calls SLASDQ if singular values only are desired. */ +/* > However, it can be slightly modified to compute singular values */ +/* > using the divide and conquer method. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': B is upper bidiagonal. */ +/* > = 'L': B is lower bidiagonal. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COMPQ */ +/* > \verbatim */ +/* > COMPQ is CHARACTER*1 */ +/* > Specifies whether singular vectors are to be computed */ +/* > as follows: */ +/* > = 'N': Compute singular values only; */ +/* > = 'P': Compute singular values and compute singular */ +/* > vectors in compact form; */ +/* > = 'I': Compute singular values and singular vectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry, the n diagonal elements of the bidiagonal matrix B. */ +/* > On exit, if INFO=0, the singular values of B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (N-1) */ +/* > On entry, the elements of E contain the offdiagonal */ +/* > elements of the bidiagonal matrix whose SVD is desired. */ +/* > On exit, E has been destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] U */ +/* > \verbatim */ +/* > U is REAL array, dimension (LDU,N) */ +/* > If COMPQ = 'I', then: */ +/* > On exit, if INFO = 0, U contains the left singular vectors */ +/* > of the bidiagonal matrix. */ +/* > For other values of COMPQ, U is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > The leading dimension of the array U. LDU >= 1. */ +/* > If singular vectors are desired, then LDU >= f2cmax( 1, N ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] VT */ +/* > \verbatim */ +/* > VT is REAL array, dimension (LDVT,N) */ +/* > If COMPQ = 'I', then: */ +/* > On exit, if INFO = 0, VT**T contains the right singular */ +/* > vectors of the bidiagonal matrix. */ +/* > For other values of COMPQ, VT is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVT */ +/* > \verbatim */ +/* > LDVT is INTEGER */ +/* > The leading dimension of the array VT. LDVT >= 1. */ +/* > If singular vectors are desired, then LDVT >= f2cmax( 1, N ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is REAL array, dimension (LDQ) */ +/* > If COMPQ = 'P', then: */ +/* > On exit, if INFO = 0, Q and IQ contain the left */ +/* > and right singular vectors in a compact form, */ +/* > requiring O(N log N) space instead of 2*N**2. */ +/* > In particular, Q contains all the REAL data in */ +/* > LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1)))) */ +/* > words of memory, where SMLSIZ is returned by ILAENV and */ +/* > is equal to the maximum size of the subproblems at the */ +/* > bottom of the computation tree (usually about 25). */ +/* > For other values of COMPQ, Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IQ */ +/* > \verbatim */ +/* > IQ is INTEGER array, dimension (LDIQ) */ +/* > If COMPQ = 'P', then: */ +/* > On exit, if INFO = 0, Q and IQ contain the left */ +/* > and right singular vectors in a compact form, */ +/* > requiring O(N log N) space instead of 2*N**2. */ +/* > In particular, IQ contains all INTEGER data in */ +/* > LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1)))) */ +/* > words of memory, where SMLSIZ is returned by ILAENV and */ +/* > is equal to the maximum size of the subproblems at the */ +/* > bottom of the computation tree (usually about 25). */ +/* > For other values of COMPQ, IQ is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MAX(1,LWORK)) */ +/* > If COMPQ = 'N' then LWORK >= (4 * N). */ +/* > If COMPQ = 'P' then LWORK >= (6 * N). */ +/* > If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (8*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: The algorithm failed to compute a singular value. */ +/* > The update process of divide and conquer failed. */ +/* > \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 Contributors: */ +/* ================== */ +/* > */ +/* > Ming Gu and Huan Ren, Computer Science Division, University of */ +/* > California at Berkeley, USA */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int sbdsdc_(char *uplo, char *compq, integer *n, real *d__, + real *e, real *u, integer *ldu, real *vt, integer *ldvt, real *q, + integer *iq, real *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer u_dim1, u_offset, vt_dim1, vt_offset, i__1, i__2; + real r__1; + + /* Local variables */ + integer difl, difr, ierr, perm, mlvl, sqre, i__, j, k; + real p, r__; + integer z__; + extern logical lsame_(char *, char *); + integer poles; + extern /* Subroutine */ int slasr_(char *, char *, char *, integer *, + integer *, real *, real *, real *, integer *); + integer iuplo, nsize, start; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *), sswap_(integer *, real *, integer *, real *, integer * + ), slasd0_(integer *, integer *, real *, real *, real *, integer * + , real *, integer *, integer *, integer *, real *, integer *); + integer ic, ii, kk; + real cs; + integer is, iu; + real sn; + extern real slamch_(char *); + extern /* Subroutine */ int slasda_(integer *, integer *, integer *, + integer *, real *, real *, real *, integer *, real *, integer *, + real *, real *, real *, real *, integer *, integer *, integer *, + integer *, real *, real *, real *, real *, integer *, integer *), + xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *, + real *, integer *, integer *, real *, integer *, integer *); + integer givcol; + extern /* Subroutine */ int slasdq_(char *, integer *, integer *, integer + *, integer *, integer *, real *, real *, real *, integer *, real * + , integer *, real *, integer *, real *, integer *); + integer icompq; + extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *, + real *, real *, integer *), slartg_(real *, real *, real * + , real *, real *); + real orgnrm; + integer givnum; + extern real slanst_(char *, integer *, real *, real *); + integer givptr, nm1, qstart, smlsiz, wstart, smlszp; + real eps; + integer ivt; + + +/* -- 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 */ + + +/* ===================================================================== */ +/* Changed dimension statement in comment describing E from (N) to */ +/* (N-1). Sven, 17 Feb 05. */ +/* ===================================================================== */ + + +/* 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; + --q; + --iq; + --work; + --iwork; + + /* Function Body */ + *info = 0; + + iuplo = 0; + if (lsame_(uplo, "U")) { + iuplo = 1; + } + if (lsame_(uplo, "L")) { + iuplo = 2; + } + if (lsame_(compq, "N")) { + icompq = 0; + } else if (lsame_(compq, "P")) { + icompq = 1; + } else if (lsame_(compq, "I")) { + icompq = 2; + } else { + icompq = -1; + } + if (iuplo == 0) { + *info = -1; + } else if (icompq < 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ldu < 1 || icompq == 2 && *ldu < *n) { + *info = -7; + } else if (*ldvt < 1 || icompq == 2 && *ldvt < *n) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SBDSDC", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + smlsiz = ilaenv_(&c__9, "SBDSDC", " ", &c__0, &c__0, &c__0, &c__0, ( + ftnlen)6, (ftnlen)1); + if (*n == 1) { + if (icompq == 1) { + q[1] = r_sign(&c_b15, &d__[1]); + q[smlsiz * *n + 1] = 1.f; + } else if (icompq == 2) { + u[u_dim1 + 1] = r_sign(&c_b15, &d__[1]); + vt[vt_dim1 + 1] = 1.f; + } + d__[1] = abs(d__[1]); + return 0; + } + nm1 = *n - 1; + +/* If matrix lower bidiagonal, rotate to be upper bidiagonal */ +/* by applying Givens rotations on the left */ + + wstart = 1; + qstart = 3; + if (icompq == 1) { + scopy_(n, &d__[1], &c__1, &q[1], &c__1); + i__1 = *n - 1; + scopy_(&i__1, &e[1], &c__1, &q[*n + 1], &c__1); + } + if (iuplo == 2) { + qstart = 5; + if (icompq == 2) { + wstart = (*n << 1) - 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 (icompq == 1) { + q[i__ + (*n << 1)] = cs; + q[i__ + *n * 3] = sn; + } else if (icompq == 2) { + work[i__] = cs; + work[nm1 + i__] = -sn; + } +/* L10: */ + } + } + +/* If ICOMPQ = 0, use SLASDQ to compute the singular values. */ + + if (icompq == 0) { +/* Ignore WSTART, instead using WORK( 1 ), since the two vectors */ +/* for CS and -SN above are added only if ICOMPQ == 2, */ +/* and adding them exceeds documented WORK size of 4*n. */ + slasdq_("U", &c__0, n, &c__0, &c__0, &c__0, &d__[1], &e[1], &vt[ + vt_offset], ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[ + 1], info); + goto L40; + } + +/* If N is smaller than the minimum divide size SMLSIZ, then solve */ +/* the problem with another solver. */ + + if (*n <= smlsiz) { + if (icompq == 2) { + slaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu); + slaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt); + slasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &vt[vt_offset] + , ldvt, &u[u_offset], ldu, &u[u_offset], ldu, &work[ + wstart], info); + } else if (icompq == 1) { + iu = 1; + ivt = iu + *n; + slaset_("A", n, n, &c_b29, &c_b15, &q[iu + (qstart - 1) * *n], n); + slaset_("A", n, n, &c_b29, &c_b15, &q[ivt + (qstart - 1) * *n], n); + slasdq_("U", &c__0, n, n, n, &c__0, &d__[1], &e[1], &q[ivt + ( + qstart - 1) * *n], n, &q[iu + (qstart - 1) * *n], n, &q[ + iu + (qstart - 1) * *n], n, &work[wstart], info); + } + goto L40; + } + + if (icompq == 2) { + slaset_("A", n, n, &c_b29, &c_b15, &u[u_offset], ldu); + slaset_("A", n, n, &c_b29, &c_b15, &vt[vt_offset], ldvt); + } + +/* Scale. */ + + orgnrm = slanst_("M", n, &d__[1], &e[1]); + if (orgnrm == 0.f) { + return 0; + } + slascl_("G", &c__0, &c__0, &orgnrm, &c_b15, n, &c__1, &d__[1], n, &ierr); + slascl_("G", &c__0, &c__0, &orgnrm, &c_b15, &nm1, &c__1, &e[1], &nm1, & + ierr); + + eps = slamch_("Epsilon"); + + mlvl = (integer) (log((real) (*n) / (real) (smlsiz + 1)) / log(2.f)) + 1; + smlszp = smlsiz + 1; + + if (icompq == 1) { + iu = 1; + ivt = smlsiz + 1; + difl = ivt + smlszp; + difr = difl + mlvl; + z__ = difr + (mlvl << 1); + ic = z__ + mlvl; + is = ic + 1; + poles = is + 1; + givnum = poles + (mlvl << 1); + + k = 1; + givptr = 2; + perm = 3; + givcol = perm + mlvl; + } + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((r__1 = d__[i__], abs(r__1)) < eps) { + d__[i__] = r_sign(&eps, &d__[i__]); + } +/* L20: */ + } + + start = 1; + sqre = 0; + + i__1 = nm1; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((r__1 = e[i__], abs(r__1)) < eps || i__ == nm1) { + +/* Subproblem found. First determine its size and then */ +/* apply divide and conquer on it. */ + + if (i__ < nm1) { + +/* A subproblem with E(I) small for I < NM1. */ + + nsize = i__ - start + 1; + } else if ((r__1 = e[i__], abs(r__1)) >= eps) { + +/* A subproblem with E(NM1) not too small but I = NM1. */ + + nsize = *n - start + 1; + } else { + +/* A subproblem with E(NM1) small. This implies an */ +/* 1-by-1 subproblem at D(N). Solve this 1-by-1 problem */ +/* first. */ + + nsize = i__ - start + 1; + if (icompq == 2) { + u[*n + *n * u_dim1] = r_sign(&c_b15, &d__[*n]); + vt[*n + *n * vt_dim1] = 1.f; + } else if (icompq == 1) { + q[*n + (qstart - 1) * *n] = r_sign(&c_b15, &d__[*n]); + q[*n + (smlsiz + qstart - 1) * *n] = 1.f; + } + d__[*n] = (r__1 = d__[*n], abs(r__1)); + } + if (icompq == 2) { + slasd0_(&nsize, &sqre, &d__[start], &e[start], &u[start + + start * u_dim1], ldu, &vt[start + start * vt_dim1], + ldvt, &smlsiz, &iwork[1], &work[wstart], info); + } else { + slasda_(&icompq, &smlsiz, &nsize, &sqre, &d__[start], &e[ + start], &q[start + (iu + qstart - 2) * *n], n, &q[ + start + (ivt + qstart - 2) * *n], &iq[start + k * *n], + &q[start + (difl + qstart - 2) * *n], &q[start + ( + difr + qstart - 2) * *n], &q[start + (z__ + qstart - + 2) * *n], &q[start + (poles + qstart - 2) * *n], &iq[ + start + givptr * *n], &iq[start + givcol * *n], n, & + iq[start + perm * *n], &q[start + (givnum + qstart - + 2) * *n], &q[start + (ic + qstart - 2) * *n], &q[ + start + (is + qstart - 2) * *n], &work[wstart], & + iwork[1], info); + } + if (*info != 0) { + return 0; + } + start = i__ + 1; + } +/* L30: */ + } + +/* Unscale */ + + slascl_("G", &c__0, &c__0, &c_b15, &orgnrm, n, &c__1, &d__[1], n, &ierr); +L40: + +/* Use Selection Sort to minimize swaps of singular vectors */ + + i__1 = *n; + for (ii = 2; ii <= i__1; ++ii) { + i__ = ii - 1; + kk = i__; + p = d__[i__]; + i__2 = *n; + for (j = ii; j <= i__2; ++j) { + if (d__[j] > p) { + kk = j; + p = d__[j]; + } +/* L50: */ + } + if (kk != i__) { + d__[kk] = d__[i__]; + d__[i__] = p; + if (icompq == 1) { + iq[i__] = kk; + } else if (icompq == 2) { + sswap_(n, &u[i__ * u_dim1 + 1], &c__1, &u[kk * u_dim1 + 1], & + c__1); + sswap_(n, &vt[i__ + vt_dim1], ldvt, &vt[kk + vt_dim1], ldvt); + } + } else if (icompq == 1) { + iq[i__] = i__; + } +/* L60: */ + } + +/* If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO */ + + if (icompq == 1) { + if (iuplo == 1) { + iq[*n] = 1; + } else { + iq[*n] = 0; + } + } + +/* If B is lower bidiagonal, update U by those Givens rotations */ +/* which rotated B to be upper bidiagonal */ + + if (iuplo == 2 && icompq == 2) { + slasr_("L", "V", "B", n, n, &work[1], &work[*n], &u[u_offset], ldu); + } + + return 0; + +/* End of SBDSDC */ + +} /* sbdsdc_ */ + diff --git a/lapack-netlib/SRC/sbdsqr.c b/lapack-netlib/SRC/sbdsqr.c new file mode 100644 index 000000000..a503150ad --- /dev/null +++ b/lapack-netlib/SRC/sbdsqr.c @@ -0,0 +1,1396 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SBDSQR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SBDSQR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SBDSQR( UPLO, 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 */ +/* REAL C( LDC, * ), D( * ), E( * ), U( LDU, * ), */ +/* $ VT( LDVT, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SBDSQR computes the singular values and, optionally, the right and/or */ +/* > left singular vectors from the singular value decomposition (SVD) of */ +/* > a real N-by-N (upper or lower) bidiagonal matrix B using the implicit */ +/* > zero-shift QR algorithm. The SVD of B has the form */ +/* > */ +/* > B = Q * S * P**T */ +/* > */ +/* > where S is the diagonal matrix of singular values, Q is an orthogonal */ +/* > matrix of left singular vectors, and P is an orthogonal matrix of */ +/* > right singular vectors. If left singular vectors are requested, this */ +/* > subroutine actually returns U*Q instead of Q, and, if right singular */ +/* > vectors are requested, this subroutine returns P**T*VT instead of */ +/* > P**T, for given real input matrices U and VT. When U and VT are the */ +/* > orthogonal matrices that reduce a general matrix A to bidiagonal */ +/* > form: A = U*B*VT, as computed by SGEBRD, then */ +/* > */ +/* > A = (U*Q) * S * (P**T*VT) */ +/* > */ +/* > is the SVD of A. Optionally, the subroutine may also compute Q**T*C */ +/* > for a given real input matrix C. */ +/* > */ +/* > See "Computing Small Singular Values of Bidiagonal Matrices With */ +/* > Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan, */ +/* > LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11, */ +/* > no. 5, pp. 873-912, Sept 1990) and */ +/* > "Accurate singular values and differential qd algorithms," by */ +/* > B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics */ +/* > Department, University of California at Berkeley, July 1992 */ +/* > for a detailed description of the algorithm. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': B is upper bidiagonal; */ +/* > = 'L': B is lower bidiagonal. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NCVT */ +/* > \verbatim */ +/* > NCVT is INTEGER */ +/* > The number of columns of the matrix VT. NCVT >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRU */ +/* > \verbatim */ +/* > NRU is INTEGER */ +/* > The number of rows of the matrix U. NRU >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NCC */ +/* > \verbatim */ +/* > NCC is INTEGER */ +/* > The number of columns of the matrix C. NCC >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry, the n diagonal elements of the bidiagonal matrix B. */ +/* > On exit, if INFO=0, the singular values of B in decreasing */ +/* > order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (N-1) */ +/* > On entry, the N-1 offdiagonal elements of the bidiagonal */ +/* > matrix B. */ +/* > On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E */ +/* > will contain the diagonal and superdiagonal elements of a */ +/* > bidiagonal matrix orthogonally equivalent to the one given */ +/* > as input. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VT */ +/* > \verbatim */ +/* > VT is REAL array, dimension (LDVT, NCVT) */ +/* > On entry, an N-by-NCVT matrix VT. */ +/* > On exit, VT is overwritten by P**T * VT. */ +/* > Not referenced if NCVT = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVT */ +/* > \verbatim */ +/* > LDVT is INTEGER */ +/* > The leading dimension of the array VT. */ +/* > LDVT >= f2cmax(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] U */ +/* > \verbatim */ +/* > U is REAL array, dimension (LDU, N) */ +/* > On entry, an NRU-by-N matrix U. */ +/* > On exit, U is overwritten by U * Q. */ +/* > Not referenced if NRU = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDU */ +/* > \verbatim */ +/* > LDU is INTEGER */ +/* > The leading dimension of the array U. LDU >= f2cmax(1,NRU). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (LDC, NCC) */ +/* > On entry, an N-by-NCC matrix C. */ +/* > On exit, C is overwritten by Q**T * C. */ +/* > Not referenced if NCC = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. */ +/* > LDC >= f2cmax(1,N) if NCC > 0; LDC >=1 if NCC = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] 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: */ +/* > if NCVT = NRU = NCC = 0, */ +/* > = 1, a split was marked by a positive value in E */ +/* > = 2, current block of Z not diagonalized after 30*N */ +/* > iterations (in inner while loop) */ +/* > = 3, termination criterion of outer while loop not met */ +/* > (program created more than N unreduced blocks) */ +/* > else NCVT = NRU = NCC = 0, */ +/* > the algorithm did not converge; D and E contain the */ +/* > elements of a bidiagonal matrix which is orthogonally */ +/* > similar to the input matrix B; if INFO = i, i */ +/* > elements of E have not converged to zero. */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > TOLMUL REAL, default = f2cmax(10,f2cmin(100,EPS**(-1/8))) */ +/* > TOLMUL controls the convergence criterion of the QR loop. */ +/* > If it is positive, TOLMUL*EPS is the desired relative */ +/* > precision in the computed singular values. */ +/* > If it is negative, abs(TOLMUL*EPS*sigma_max) is the */ +/* > desired absolute accuracy in the computed singular */ +/* > values (corresponds to relative accuracy */ +/* > abs(TOLMUL*EPS) in the largest singular value. */ +/* > abs(TOLMUL) should be between 1 and 1/EPS, and preferably */ +/* > between 10 (for fast convergence) and .1/EPS */ +/* > (for there to be some accuracy in the results). */ +/* > Default is to lose at either one eighth or 2 of the */ +/* > available decimal digits in each computed singular value */ +/* > (whichever is smaller). */ +/* > */ +/* > MAXITR INTEGER, default = 6 */ +/* > MAXITR controls the maximum number of passes of the */ +/* > algorithm through its inner loop. The algorithms stops */ +/* > (and so fails to converge) if the number of passes */ +/* > through the inner loop exceeds MAXITR*N**2. */ +/* > \endverbatim */ + +/* > \par Note: */ +/* =========== */ +/* > */ +/* > \verbatim */ +/* > Bug report from Cezary Dendek. */ +/* > On March 23rd 2017, the INTEGER variable MAXIT = MAXITR*N**2 is */ +/* > removed since it can overflow pretty easily (for N larger or equal */ +/* > than 18,919). We instead use MAXITDIVN = MAXITR*N. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup auxOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int sbdsqr_(char *uplo, 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; + real r__1, r__2, r__3, r__4; + doublereal d__1; + + /* Local variables */ + real abse; + integer idir; + real abss; + integer oldm; + real cosl; + integer isub, iter; + real unfl, sinl, cosr, smin, smax, sinr; + extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, + integer *, real *, real *); + integer iterdivn; + extern /* Subroutine */ int slas2_(real *, real *, real *, real *, real *) + ; + real f, g, h__; + integer i__, j, m; + real r__; + extern logical lsame_(char *, char *); + real oldcs; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + integer oldll; + real shift, sigmn, oldsn, sminl; + extern /* Subroutine */ int slasr_(char *, char *, char *, integer *, + integer *, real *, real *, real *, integer *); + real sigmx; + logical lower; + extern /* Subroutine */ int sswap_(integer *, real *, integer *, real *, + integer *); + integer maxitdivn; + extern /* Subroutine */ int slasq1_(integer *, real *, real *, real *, + integer *), slasv2_(real *, real *, real *, real *, real *, real * + , real *, real *, real *); + real cs; + integer ll; + real sn, mu; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real sminoa; + extern /* Subroutine */ int slartg_(real *, real *, real *, real *, real * + ); + real thresh; + logical rotate; + integer nm1; + real tolmul; + integer nm12, nm13, lll; + real eps, sll, tol; + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + 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; + lower = lsame_(uplo, "L"); + if (! lsame_(uplo, "U") && ! lower) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*ncvt < 0) { + *info = -3; + } else if (*nru < 0) { + *info = -4; + } else if (*ncc < 0) { + *info = -5; + } else if (*ncvt == 0 && *ldvt < 1 || *ncvt > 0 && *ldvt < f2cmax(1,*n)) { + *info = -9; + } else if (*ldu < f2cmax(1,*nru)) { + *info = -11; + } else if (*ncc == 0 && *ldc < 1 || *ncc > 0 && *ldc < f2cmax(1,*n)) { + *info = -13; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SBDSQR", &i__1, (ftnlen)6); + return 0; + } + if (*n == 0) { + return 0; + } + if (*n == 1) { + goto L160; + } + +/* ROTATE is true if any singular vectors desired, false otherwise */ + + rotate = *ncvt > 0 || *nru > 0 || *ncc > 0; + +/* If no singular vectors desired, use qd algorithm */ + + if (! rotate) { + slasq1_(n, &d__[1], &e[1], &work[1], info); + +/* If INFO equals 2, dqds didn't finish, try to finish */ + + if (*info != 2) { + return 0; + } + *info = 0; + } + + nm1 = *n - 1; + nm12 = nm1 + nm1; + nm13 = nm12 + nm1; + idir = 0; + +/* Get machine constants */ + + eps = slamch_("Epsilon"); + unfl = slamch_("Safe minimum"); + +/* If matrix lower bidiagonal, rotate to be upper bidiagonal */ +/* by applying Givens rotations on the left */ + + if (lower) { + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + slartg_(&d__[i__], &e[i__], &cs, &sn, &r__); + d__[i__] = r__; + e[i__] = sn * d__[i__ + 1]; + d__[i__ + 1] = cs * d__[i__ + 1]; + work[i__] = cs; + work[nm1 + i__] = sn; +/* L10: */ + } + +/* Update singular vectors if desired */ + + if (*nru > 0) { + slasr_("R", "V", "F", nru, n, &work[1], &work[*n], &u[u_offset], + ldu); + } + if (*ncc > 0) { + slasr_("L", "V", "F", n, ncc, &work[1], &work[*n], &c__[c_offset], + ldc); + } + } + +/* Compute singular values to relative accuracy TOL */ +/* (By setting TOL to be negative, algorithm will compute */ +/* singular values to absolute accuracy ABS(TOL)*norm(input matrix)) */ + +/* Computing MAX */ +/* Computing MIN */ + d__1 = (doublereal) eps; + r__3 = 100.f, r__4 = pow_dd(&d__1, &c_b15); + r__1 = 10.f, r__2 = f2cmin(r__3,r__4); + tolmul = f2cmax(r__1,r__2); + tol = tolmul * eps; + +/* Compute approximate maximum, minimum singular values */ + + smax = 0.f; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + r__2 = smax, r__3 = (r__1 = d__[i__], abs(r__1)); + smax = f2cmax(r__2,r__3); +/* L20: */ + } + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + r__2 = smax, r__3 = (r__1 = e[i__], abs(r__1)); + smax = f2cmax(r__2,r__3); +/* L30: */ + } + sminl = 0.f; + if (tol >= 0.f) { + +/* Relative accuracy desired */ + + sminoa = abs(d__[1]); + if (sminoa == 0.f) { + goto L50; + } + mu = sminoa; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + mu = (r__2 = d__[i__], abs(r__2)) * (mu / (mu + (r__1 = e[i__ - 1] + , abs(r__1)))); + sminoa = f2cmin(sminoa,mu); + if (sminoa == 0.f) { + goto L50; + } +/* L40: */ + } +L50: + sminoa /= sqrt((real) (*n)); +/* Computing MAX */ + r__1 = tol * sminoa, r__2 = *n * (*n * unfl) * 6; + thresh = f2cmax(r__1,r__2); + } else { + +/* Absolute accuracy desired */ + +/* Computing MAX */ + r__1 = abs(tol) * smax, r__2 = *n * (*n * unfl) * 6; + thresh = f2cmax(r__1,r__2); + } + +/* Prepare for main iteration loop for the singular values */ +/* (MAXIT is the maximum number of passes through the inner */ +/* loop permitted before nonconvergence signalled.) */ + + maxitdivn = *n * 6; + iterdivn = 0; + iter = -1; + oldll = -1; + oldm = -1; + +/* M points to last element of unconverged part of matrix */ + + m = *n; + +/* Begin main iteration loop */ + +L60: + +/* Check for convergence or exceeding iteration count */ + + if (m <= 1) { + goto L160; + } + + if (iter >= *n) { + iter -= *n; + ++iterdivn; + if (iterdivn >= maxitdivn) { + goto L200; + } + } + +/* Find diagonal block of matrix to work on */ + + if (tol < 0.f && (r__1 = d__[m], abs(r__1)) <= thresh) { + d__[m] = 0.f; + } + smax = (r__1 = d__[m], abs(r__1)); + smin = smax; + i__1 = m - 1; + for (lll = 1; lll <= i__1; ++lll) { + ll = m - lll; + abss = (r__1 = d__[ll], abs(r__1)); + abse = (r__1 = e[ll], abs(r__1)); + if (tol < 0.f && abss <= thresh) { + d__[ll] = 0.f; + } + if (abse <= thresh) { + goto L80; + } + smin = f2cmin(smin,abss); +/* Computing MAX */ + r__1 = f2cmax(smax,abss); + smax = f2cmax(r__1,abse); +/* L70: */ + } + ll = 0; + goto L90; +L80: + e[ll] = 0.f; + +/* Matrix splits since E(LL) = 0 */ + + if (ll == m - 1) { + +/* Convergence of bottom singular value, return to top of loop */ + + --m; + goto L60; + } +L90: + ++ll; + +/* E(LL) through E(M-1) are nonzero, E(LL-1) is zero */ + + if (ll == m - 1) { + +/* 2 by 2 block, handle separately */ + + slasv2_(&d__[m - 1], &e[m - 1], &d__[m], &sigmn, &sigmx, &sinr, &cosr, + &sinl, &cosl); + d__[m - 1] = sigmx; + e[m - 1] = 0.f; + d__[m] = sigmn; + +/* Compute singular vectors, if desired */ + + if (*ncvt > 0) { + srot_(ncvt, &vt[m - 1 + vt_dim1], ldvt, &vt[m + vt_dim1], ldvt, & + cosr, &sinr); + } + if (*nru > 0) { + srot_(nru, &u[(m - 1) * u_dim1 + 1], &c__1, &u[m * u_dim1 + 1], & + c__1, &cosl, &sinl); + } + if (*ncc > 0) { + srot_(ncc, &c__[m - 1 + c_dim1], ldc, &c__[m + c_dim1], ldc, & + cosl, &sinl); + } + m += -2; + goto L60; + } + +/* If working on new submatrix, choose shift direction */ +/* (from larger end diagonal element towards smaller) */ + + if (ll > oldm || m < oldll) { + if ((r__1 = d__[ll], abs(r__1)) >= (r__2 = d__[m], abs(r__2))) { + +/* Chase bulge from top (big end) to bottom (small end) */ + + idir = 1; + } else { + +/* Chase bulge from bottom (big end) to top (small end) */ + + idir = 2; + } + } + +/* Apply convergence tests */ + + if (idir == 1) { + +/* Run convergence test in forward direction */ +/* First apply standard test to bottom of matrix */ + + if ((r__2 = e[m - 1], abs(r__2)) <= abs(tol) * (r__1 = d__[m], abs( + r__1)) || tol < 0.f && (r__3 = e[m - 1], abs(r__3)) <= thresh) + { + e[m - 1] = 0.f; + goto L60; + } + + if (tol >= 0.f) { + +/* If relative accuracy desired, */ +/* apply convergence criterion forward */ + + mu = (r__1 = d__[ll], abs(r__1)); + sminl = mu; + i__1 = m - 1; + for (lll = ll; lll <= i__1; ++lll) { + if ((r__1 = e[lll], abs(r__1)) <= tol * mu) { + e[lll] = 0.f; + goto L60; + } + mu = (r__2 = d__[lll + 1], abs(r__2)) * (mu / (mu + (r__1 = e[ + lll], abs(r__1)))); + sminl = f2cmin(sminl,mu); +/* L100: */ + } + } + + } else { + +/* Run convergence test in backward direction */ +/* First apply standard test to top of matrix */ + + if ((r__2 = e[ll], abs(r__2)) <= abs(tol) * (r__1 = d__[ll], abs(r__1) + ) || tol < 0.f && (r__3 = e[ll], abs(r__3)) <= thresh) { + e[ll] = 0.f; + goto L60; + } + + if (tol >= 0.f) { + +/* If relative accuracy desired, */ +/* apply convergence criterion backward */ + + mu = (r__1 = d__[m], abs(r__1)); + sminl = mu; + i__1 = ll; + for (lll = m - 1; lll >= i__1; --lll) { + if ((r__1 = e[lll], abs(r__1)) <= tol * mu) { + e[lll] = 0.f; + goto L60; + } + mu = (r__2 = d__[lll], abs(r__2)) * (mu / (mu + (r__1 = e[lll] + , abs(r__1)))); + sminl = f2cmin(sminl,mu); +/* L110: */ + } + } + } + oldll = ll; + oldm = m; + +/* Compute shift. First, test if shifting would ruin relative */ +/* accuracy, and if so set the shift to zero. */ + +/* Computing MAX */ + r__1 = eps, r__2 = tol * .01f; + if (tol >= 0.f && *n * tol * (sminl / smax) <= f2cmax(r__1,r__2)) { + +/* Use a zero shift to avoid loss of relative accuracy */ + + shift = 0.f; + } else { + +/* Compute the shift from 2-by-2 block at end of matrix */ + + if (idir == 1) { + sll = (r__1 = d__[ll], abs(r__1)); + slas2_(&d__[m - 1], &e[m - 1], &d__[m], &shift, &r__); + } else { + sll = (r__1 = d__[m], abs(r__1)); + slas2_(&d__[ll], &e[ll], &d__[ll + 1], &shift, &r__); + } + +/* Test if shift negligible, and if so set to zero */ + + if (sll > 0.f) { +/* Computing 2nd power */ + r__1 = shift / sll; + if (r__1 * r__1 < eps) { + shift = 0.f; + } + } + } + +/* Increment iteration count */ + + iter = iter + m - ll; + +/* If SHIFT = 0, do simplified QR iteration */ + + if (shift == 0.f) { + if (idir == 1) { + +/* Chase bulge from top to bottom */ +/* Save cosines and sines for later singular vector updates */ + + cs = 1.f; + oldcs = 1.f; + i__1 = m - 1; + for (i__ = ll; i__ <= i__1; ++i__) { + r__1 = d__[i__] * cs; + slartg_(&r__1, &e[i__], &cs, &sn, &r__); + if (i__ > ll) { + e[i__ - 1] = oldsn * r__; + } + r__1 = oldcs * r__; + r__2 = d__[i__ + 1] * sn; + slartg_(&r__1, &r__2, &oldcs, &oldsn, &d__[i__]); + work[i__ - ll + 1] = cs; + work[i__ - ll + 1 + nm1] = sn; + work[i__ - ll + 1 + nm12] = oldcs; + work[i__ - ll + 1 + nm13] = oldsn; +/* L120: */ + } + h__ = d__[m] * cs; + d__[m] = h__ * oldcs; + e[m - 1] = h__ * oldsn; + +/* Update singular vectors */ + + if (*ncvt > 0) { + i__1 = m - ll + 1; + slasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[ + ll + vt_dim1], ldvt); + } + if (*nru > 0) { + i__1 = m - ll + 1; + slasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13 + + 1], &u[ll * u_dim1 + 1], ldu); + } + if (*ncc > 0) { + i__1 = m - ll + 1; + slasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13 + + 1], &c__[ll + c_dim1], ldc); + } + +/* Test convergence */ + + if ((r__1 = e[m - 1], abs(r__1)) <= thresh) { + e[m - 1] = 0.f; + } + + } else { + +/* Chase bulge from bottom to top */ +/* Save cosines and sines for later singular vector updates */ + + cs = 1.f; + oldcs = 1.f; + i__1 = ll + 1; + for (i__ = m; i__ >= i__1; --i__) { + r__1 = d__[i__] * cs; + slartg_(&r__1, &e[i__ - 1], &cs, &sn, &r__); + if (i__ < m) { + e[i__] = oldsn * r__; + } + r__1 = oldcs * r__; + r__2 = d__[i__ - 1] * sn; + slartg_(&r__1, &r__2, &oldcs, &oldsn, &d__[i__]); + work[i__ - ll] = cs; + work[i__ - ll + nm1] = -sn; + work[i__ - ll + nm12] = oldcs; + work[i__ - ll + nm13] = -oldsn; +/* L130: */ + } + h__ = d__[ll] * cs; + d__[ll] = h__ * oldcs; + e[ll] = h__ * oldsn; + +/* Update singular vectors */ + + if (*ncvt > 0) { + i__1 = m - ll + 1; + slasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[ + nm13 + 1], &vt[ll + vt_dim1], ldvt); + } + if (*nru > 0) { + i__1 = m - ll + 1; + slasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll * + u_dim1 + 1], ldu); + } + if (*ncc > 0) { + i__1 = m - ll + 1; + slasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &c__[ + ll + c_dim1], ldc); + } + +/* Test convergence */ + + if ((r__1 = e[ll], abs(r__1)) <= thresh) { + e[ll] = 0.f; + } + } + } else { + +/* Use nonzero shift */ + + if (idir == 1) { + +/* Chase bulge from top to bottom */ +/* Save cosines and sines for later singular vector updates */ + + f = ((r__1 = d__[ll], abs(r__1)) - shift) * (r_sign(&c_b49, &d__[ + ll]) + shift / d__[ll]); + g = e[ll]; + i__1 = m - 1; + for (i__ = ll; i__ <= i__1; ++i__) { + slartg_(&f, &g, &cosr, &sinr, &r__); + if (i__ > ll) { + e[i__ - 1] = r__; + } + f = cosr * d__[i__] + sinr * e[i__]; + e[i__] = cosr * e[i__] - sinr * d__[i__]; + g = sinr * d__[i__ + 1]; + d__[i__ + 1] = cosr * d__[i__ + 1]; + slartg_(&f, &g, &cosl, &sinl, &r__); + d__[i__] = r__; + f = cosl * e[i__] + sinl * d__[i__ + 1]; + d__[i__ + 1] = cosl * d__[i__ + 1] - sinl * e[i__]; + if (i__ < m - 1) { + g = sinl * e[i__ + 1]; + e[i__ + 1] = cosl * e[i__ + 1]; + } + work[i__ - ll + 1] = cosr; + work[i__ - ll + 1 + nm1] = sinr; + work[i__ - ll + 1 + nm12] = cosl; + work[i__ - ll + 1 + nm13] = sinl; +/* L140: */ + } + e[m - 1] = f; + +/* Update singular vectors */ + + if (*ncvt > 0) { + i__1 = m - ll + 1; + slasr_("L", "V", "F", &i__1, ncvt, &work[1], &work[*n], &vt[ + ll + vt_dim1], ldvt); + } + if (*nru > 0) { + i__1 = m - ll + 1; + slasr_("R", "V", "F", nru, &i__1, &work[nm12 + 1], &work[nm13 + + 1], &u[ll * u_dim1 + 1], ldu); + } + if (*ncc > 0) { + i__1 = m - ll + 1; + slasr_("L", "V", "F", &i__1, ncc, &work[nm12 + 1], &work[nm13 + + 1], &c__[ll + c_dim1], ldc); + } + +/* Test convergence */ + + if ((r__1 = e[m - 1], abs(r__1)) <= thresh) { + e[m - 1] = 0.f; + } + + } else { + +/* Chase bulge from bottom to top */ +/* Save cosines and sines for later singular vector updates */ + + f = ((r__1 = d__[m], abs(r__1)) - shift) * (r_sign(&c_b49, &d__[m] + ) + shift / d__[m]); + g = e[m - 1]; + i__1 = ll + 1; + for (i__ = m; i__ >= i__1; --i__) { + slartg_(&f, &g, &cosr, &sinr, &r__); + if (i__ < m) { + e[i__] = r__; + } + f = cosr * d__[i__] + sinr * e[i__ - 1]; + e[i__ - 1] = cosr * e[i__ - 1] - sinr * d__[i__]; + g = sinr * d__[i__ - 1]; + d__[i__ - 1] = cosr * d__[i__ - 1]; + slartg_(&f, &g, &cosl, &sinl, &r__); + d__[i__] = r__; + f = cosl * e[i__ - 1] + sinl * d__[i__ - 1]; + d__[i__ - 1] = cosl * d__[i__ - 1] - sinl * e[i__ - 1]; + if (i__ > ll + 1) { + g = sinl * e[i__ - 2]; + e[i__ - 2] = cosl * e[i__ - 2]; + } + work[i__ - ll] = cosr; + work[i__ - ll + nm1] = -sinr; + work[i__ - ll + nm12] = cosl; + work[i__ - ll + nm13] = -sinl; +/* L150: */ + } + e[ll] = f; + +/* Test convergence */ + + if ((r__1 = e[ll], abs(r__1)) <= thresh) { + e[ll] = 0.f; + } + +/* Update singular vectors if desired */ + + if (*ncvt > 0) { + i__1 = m - ll + 1; + slasr_("L", "V", "B", &i__1, ncvt, &work[nm12 + 1], &work[ + nm13 + 1], &vt[ll + vt_dim1], ldvt); + } + if (*nru > 0) { + i__1 = m - ll + 1; + slasr_("R", "V", "B", nru, &i__1, &work[1], &work[*n], &u[ll * + u_dim1 + 1], ldu); + } + if (*ncc > 0) { + i__1 = m - ll + 1; + slasr_("L", "V", "B", &i__1, ncc, &work[1], &work[*n], &c__[ + ll + c_dim1], ldc); + } + } + } + +/* QR iteration finished, go back and check convergence */ + + goto L60; + +/* All singular values converged, so make them positive */ + +L160: + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (d__[i__] < 0.f) { + d__[i__] = -d__[i__]; + +/* Change sign of singular vectors, if desired */ + + if (*ncvt > 0) { + sscal_(ncvt, &c_b72, &vt[i__ + vt_dim1], ldvt); + } + } +/* L170: */ + } + +/* Sort the singular values into decreasing order (insertion sort on */ +/* singular values, but only one transposition per singular vector) */ + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Scan for smallest D(I) */ + + isub = 1; + smin = d__[1]; + i__2 = *n + 1 - i__; + for (j = 2; j <= i__2; ++j) { + if (d__[j] <= smin) { + isub = j; + smin = d__[j]; + } +/* L180: */ + } + if (isub != *n + 1 - i__) { + +/* Swap singular values and vectors */ + + d__[isub] = d__[*n + 1 - i__]; + d__[*n + 1 - i__] = smin; + if (*ncvt > 0) { + sswap_(ncvt, &vt[isub + vt_dim1], ldvt, &vt[*n + 1 - i__ + + vt_dim1], ldvt); + } + if (*nru > 0) { + sswap_(nru, &u[isub * u_dim1 + 1], &c__1, &u[(*n + 1 - i__) * + u_dim1 + 1], &c__1); + } + if (*ncc > 0) { + sswap_(ncc, &c__[isub + c_dim1], ldc, &c__[*n + 1 - i__ + + c_dim1], ldc); + } + } +/* L190: */ + } + goto L220; + +/* Maximum number of iterations exceeded, failure to converge */ + +L200: + *info = 0; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + if (e[i__] != 0.f) { + ++(*info); + } +/* L210: */ + } +L220: + return 0; + +/* End of SBDSQR */ + +} /* sbdsqr_ */ + diff --git a/lapack-netlib/SRC/sbdsvdx.c b/lapack-netlib/SRC/sbdsvdx.c new file mode 100644 index 000000000..abee27b43 --- /dev/null +++ b/lapack-netlib/SRC/sbdsvdx.c @@ -0,0 +1,1348 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle_() continue; +#define myceiling_(w) ceil(w) +#define myhuge_(w) HUGE_VAL +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc_(w,s,e,n) dmaxloc_(w,*(s),*(e),n) + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SBDSVDX */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SBDSVDX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SBDSVDX( UPLO, JOBZ, RANGE, N, D, E, VL, VU, IL, IU, */ +/* $ NS, S, Z, LDZ, WORK, IWORK, INFO ) */ + +/* CHARACTER JOBZ, RANGE, UPLO */ +/* INTEGER IL, INFO, IU, LDZ, N, NS */ +/* REAL VL, VU */ +/* INTEGER IWORK( * ) */ +/* REAL D( * ), E( * ), S( * ), WORK( * ), */ +/* Z( LDZ, * ) */ + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SBDSVDX computes the singular value decomposition (SVD) of a real */ +/* > N-by-N (upper or lower) bidiagonal matrix B, B = U * S * VT, */ +/* > where S is a diagonal matrix with non-negative diagonal elements */ +/* > (the singular values of B), and U and VT are orthogonal matrices */ +/* > of left and right singular vectors, respectively. */ +/* > */ +/* > Given an upper bidiagonal B with diagonal D = [ d_1 d_2 ... d_N ] */ +/* > and superdiagonal E = [ e_1 e_2 ... e_N-1 ], SBDSVDX computes the */ +/* > singular value decompositon of B through the eigenvalues and */ +/* > eigenvectors of the N*2-by-N*2 tridiagonal matrix */ +/* > */ +/* > | 0 d_1 | */ +/* > | d_1 0 e_1 | */ +/* > TGK = | e_1 0 d_2 | */ +/* > | d_2 . . | */ +/* > | . . . | */ +/* > */ +/* > If (s,u,v) is a singular triplet of B with ||u|| = ||v|| = 1, then */ +/* > (+/-s,q), ||q|| = 1, are eigenpairs of TGK, with q = P * ( u' +/-v' ) / */ +/* > sqrt(2) = ( v_1 u_1 v_2 u_2 ... v_n u_n ) / sqrt(2), and */ +/* > P = [ e_{n+1} e_{1} e_{n+2} e_{2} ... ]. */ +/* > */ +/* > Given a TGK matrix, one can either a) compute -s,-v and change signs */ +/* > so that the singular values (and corresponding vectors) are already in */ +/* > descending order (as in SGESVD/SGESDD) or b) compute s,v and reorder */ +/* > the values (and corresponding vectors). SBDSVDX implements a) by */ +/* > calling SSTEVX (bisection plus inverse iteration, to be replaced */ +/* > with a version of the Multiple Relative Robust Representation */ +/* > algorithm. (See P. Willems and B. Lang, A framework for the MR^3 */ +/* > algorithm: theory and implementation, SIAM J. Sci. Comput., */ +/* > 35:740-766, 2013.) */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': B is upper bidiagonal; */ +/* > = 'L': B is lower bidiagonal. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBZ */ +/* > \verbatim */ +/* > JOBZ is CHARACTER*1 */ +/* > = 'N': Compute singular values only; */ +/* > = 'V': Compute singular values and singular vectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RANGE */ +/* > \verbatim */ +/* > RANGE is CHARACTER*1 */ +/* > = 'A': all singular values will be found. */ +/* > = 'V': all singular values in the half-open interval [VL,VU) */ +/* > will be found. */ +/* > = 'I': the IL-th through IU-th singular values will be found. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the bidiagonal matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > The n diagonal elements of the bidiagonal matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (f2cmax(1,N-1)) */ +/* > The (n-1) superdiagonal elements of the bidiagonal matrix */ +/* > B in elements 1 to N-1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VL */ +/* > \verbatim */ +/* > VL is REAL */ +/* > If RANGE='V', the lower bound of the interval to */ +/* > be searched for singular values. VU > VL. */ +/* > 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 singular values. VU > VL. */ +/* > Not referenced if RANGE = 'A' or 'I'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IL */ +/* > \verbatim */ +/* > IL is INTEGER */ +/* > If RANGE='I', the index of the */ +/* > smallest singular value to be returned. */ +/* > 1 <= IL <= IU <= f2cmin(M,N), if f2cmin(M,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 singular value to be returned. */ +/* > 1 <= IL <= IU <= f2cmin(M,N), if f2cmin(M,N) > 0. */ +/* > Not referenced if RANGE = 'A' or 'V'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] NS */ +/* > \verbatim */ +/* > NS is INTEGER */ +/* > The total number of singular values found. 0 <= NS <= N. */ +/* > If RANGE = 'A', NS = N, and if RANGE = 'I', NS = IU-IL+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] S */ +/* > \verbatim */ +/* > S is REAL array, dimension (N) */ +/* > The first NS elements contain the selected singular values in */ +/* > ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is REAL array, dimension (2*N,K) */ +/* > If JOBZ = 'V', then if INFO = 0 the first NS columns of Z */ +/* > contain the singular vectors of the matrix B corresponding to */ +/* > the selected singular values, with U in rows 1 to N and V */ +/* > in rows N+1 to N*2, i.e. */ +/* > Z = [ U ] */ +/* > [ V ] */ +/* > If JOBZ = 'N', then Z is not referenced. */ +/* > Note: The user must ensure that at least K = NS+1 columns are */ +/* > supplied in the array Z; if RANGE = 'V', the exact value of */ +/* > NS is not known in advance and an upper bound must be used. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1, and if */ +/* > JOBZ = 'V', LDZ >= f2cmax(2,N*2). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (14*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (12*N) */ +/* > If JOBZ = 'V', then if INFO = 0, the first NS elements of */ +/* > IWORK are zero. If INFO > 0, then IWORK contains the indices */ +/* > of the eigenvectors that failed to converge in DSTEVX. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, then i eigenvectors failed to converge */ +/* > in SSTEVX. The indices of the eigenvectors */ +/* > (as returned by SSTEVX) are stored in the */ +/* > array IWORK. */ +/* > if INFO = N*2 + 1, an internal error occurred. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup realOTHEReigen */ + +/* ===================================================================== */ +/* Subroutine */ int sbdsvdx_(char *uplo, char *jobz, char *range, integer *n, + real *d__, real *e, real *vl, real *vu, integer *il, integer *iu, + integer *ns, real *s, real *z__, integer *ldz, 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, r__3, r__4; + doublereal d__1; + + /* Local variables */ + real emin; + integer ntgk; + real smin, smax; + extern real sdot_(integer *, real *, integer *, real *, integer *); + real nrmu, nrmv; + logical sveq0; + extern real snrm2_(integer *, real *, integer *); + integer i__, idbeg, j, k; + real sqrt2; + integer idend, isbeg; + extern logical lsame_(char *, char *); + integer idtgk, ietgk; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); + integer iltgk, itemp, icolz; + logical allsv; + integer idptr; + logical indsv; + integer ieptr, iutgk; + real vltgk; + logical lower; + real zjtji; + logical split, valsv; + integer isplt; + real ortol, vutgk; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *), sswap_(integer *, real *, integer *, real *, integer * + ); + logical wantz; + char rngvx[1]; + integer irowu, irowv; + extern /* Subroutine */ int saxpy_(integer *, real *, real *, integer *, + real *, integer *); + integer irowz, iifail; + real mu; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer isamax_(integer *, real *, integer *); + real abstol; + extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *, + real *, real *, integer *); + real thresh; + integer iiwork; + extern /* Subroutine */ int mecago_(), sstevx_(char *, char *, + integer *, real *, real *, real *, real *, integer *, integer *, + real *, integer *, real *, real *, integer *, real *, integer *, + integer *, integer *); + real eps; + integer nsl; + real tol, ulp; + integer nru, nrv; + + +/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --d__; + --e; + --s; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --iwork; + + /* Function Body */ + allsv = lsame_(range, "A"); + valsv = lsame_(range, "V"); + indsv = lsame_(range, "I"); + wantz = lsame_(jobz, "V"); + lower = lsame_(uplo, "L"); + + *info = 0; + if (! lsame_(uplo, "U") && ! lower) { + *info = -1; + } else if (! (wantz || lsame_(jobz, "N"))) { + *info = -2; + } else if (! (allsv || valsv || indsv)) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*n > 0) { + if (valsv) { + if (*vl < 0.f) { + *info = -7; + } else if (*vu <= *vl) { + *info = -8; + } + } else if (indsv) { + if (*il < 1 || *il > f2cmax(1,*n)) { + *info = -9; + } else if (*iu < f2cmin(*n,*il) || *iu > *n) { + *info = -10; + } + } + } + if (*info == 0) { + if (*ldz < 1 || wantz && *ldz < *n << 1) { + *info = -14; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("SBDSVDX", &i__1, (ftnlen)7); + return 0; + } + +/* Quick return if possible (N.LE.1) */ + + *ns = 0; + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (allsv || indsv) { + *ns = 1; + s[1] = abs(d__[1]); + } else { + if (*vl < abs(d__[1]) && *vu >= abs(d__[1])) { + *ns = 1; + s[1] = abs(d__[1]); + } + } + if (wantz) { + z__[z_dim1 + 1] = r_sign(&c_b10, &d__[1]); + z__[z_dim1 + 2] = 1.f; + } + return 0; + } + + abstol = slamch_("Safe Minimum") * 2; + ulp = slamch_("Precision"); + eps = slamch_("Epsilon"); + sqrt2 = sqrt(2.f); + ortol = sqrt(ulp); + +/* Criterion for splitting is taken from SBDSQR when singular */ +/* values are computed to relative accuracy TOL. (See J. Demmel and */ +/* W. Kahan, Accurate singular values of bidiagonal matrices, SIAM */ +/* J. Sci. and Stat. Comput., 11:873–912, 1990.) */ + +/* Computing MAX */ +/* Computing MIN */ + d__1 = (doublereal) eps; + r__3 = 100.f, r__4 = pow_dd(&d__1, &c_b14); + r__1 = 10.f, r__2 = f2cmin(r__3,r__4); + tol = f2cmax(r__1,r__2) * eps; + +/* Compute approximate maximum, minimum singular values. */ + + i__ = isamax_(n, &d__[1], &c__1); + smax = (r__1 = d__[i__], abs(r__1)); + i__1 = *n - 1; + i__ = isamax_(&i__1, &e[1], &c__1); +/* Computing MAX */ + r__2 = smax, r__3 = (r__1 = e[i__], abs(r__1)); + smax = f2cmax(r__2,r__3); + +/* Compute threshold for neglecting D's and E's. */ + + smin = abs(d__[1]); + if (smin != 0.f) { + mu = smin; + i__1 = *n; + for (i__ = 2; i__ <= i__1; ++i__) { + mu = (r__2 = d__[i__], abs(r__2)) * (mu / (mu + (r__1 = e[i__ - 1] + , abs(r__1)))); + smin = f2cmin(smin,mu); + if (smin == 0.f) { + myexit_(); + } + } + } + smin /= sqrt((real) (*n)); + thresh = tol * smin; + +/* Check for zeros in D and E (splits), i.e. submatrices. */ + + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + if ((r__1 = d__[i__], abs(r__1)) <= thresh) { + d__[i__] = 0.f; + } + if ((r__1 = e[i__], abs(r__1)) <= thresh) { + e[i__] = 0.f; + } + } + if ((r__1 = d__[*n], abs(r__1)) <= thresh) { + d__[*n] = 0.f; + } + +/* Pointers for arrays used by SSTEVX. */ + + idtgk = 1; + ietgk = idtgk + (*n << 1); + itemp = ietgk + (*n << 1); + iifail = 1; + iiwork = iifail + (*n << 1); + +/* Set RNGVX, which corresponds to RANGE for SSTEVX in TGK mode. */ +/* VL,VU or IL,IU are redefined to conform to implementation a) */ +/* described in the leading comments. */ + + iltgk = 0; + iutgk = 0; + vltgk = 0.f; + vutgk = 0.f; + + if (allsv) { + +/* All singular values will be found. We aim at -s (see */ +/* leading comments) with RNGVX = 'I'. IL and IU are set */ +/* later (as ILTGK and IUTGK) according to the dimension */ +/* of the active submatrix. */ + + *(unsigned char *)rngvx = 'I'; + if (wantz) { + i__1 = *n << 1; + i__2 = *n + 1; + slaset_("F", &i__1, &i__2, &c_b19, &c_b19, &z__[z_offset], ldz); + } + } else if (valsv) { + +/* Find singular values in a half-open interval. We aim */ +/* at -s (see leading comments) and we swap VL and VU */ +/* (as VUTGK and VLTGK), changing their signs. */ + + *(unsigned char *)rngvx = 'V'; + vltgk = -(*vu); + vutgk = -(*vl); + i__1 = idtgk + (*n << 1) - 1; + for (i__ = idtgk; i__ <= i__1; ++i__) { + work[i__] = 0.f; + } +/* WORK( IDTGK:IDTGK+2*N-1 ) = ZERO */ + scopy_(n, &d__[1], &c__1, &work[ietgk], &c__2); + i__1 = *n - 1; + scopy_(&i__1, &e[1], &c__1, &work[ietgk + 1], &c__2); + i__1 = *n << 1; + sstevx_("N", "V", &i__1, &work[idtgk], &work[ietgk], &vltgk, &vutgk, & + iltgk, &iltgk, &abstol, ns, &s[1], &z__[z_offset], ldz, &work[ + itemp], &iwork[iiwork], &iwork[iifail], info); + if (*ns == 0) { + return 0; + } else { + if (wantz) { + i__1 = *n << 1; + slaset_("F", &i__1, ns, &c_b19, &c_b19, &z__[z_offset], ldz); + } + } + } else if (indsv) { + +/* Find the IL-th through the IU-th singular values. We aim */ +/* at -s (see leading comments) and indices are mapped into */ +/* values, therefore mimicking SSTEBZ, where */ + +/* GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN */ +/* GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN */ + + iltgk = *il; + iutgk = *iu; + *(unsigned char *)rngvx = 'V'; + i__1 = idtgk + (*n << 1) - 1; + for (i__ = idtgk; i__ <= i__1; ++i__) { + work[i__] = 0.f; + } +/* WORK( IDTGK:IDTGK+2*N-1 ) = ZERO */ + scopy_(n, &d__[1], &c__1, &work[ietgk], &c__2); + i__1 = *n - 1; + scopy_(&i__1, &e[1], &c__1, &work[ietgk + 1], &c__2); + i__1 = *n << 1; + sstevx_("N", "I", &i__1, &work[idtgk], &work[ietgk], &vltgk, &vltgk, & + iltgk, &iltgk, &abstol, ns, &s[1], &z__[z_offset], ldz, &work[ + itemp], &iwork[iiwork], &iwork[iifail], info); + vltgk = s[1] - smax * 2.f * ulp * *n; + i__1 = idtgk + (*n << 1) - 1; + for (i__ = idtgk; i__ <= i__1; ++i__) { + work[i__] = 0.f; + } +/* WORK( IDTGK:IDTGK+2*N-1 ) = ZERO */ + scopy_(n, &d__[1], &c__1, &work[ietgk], &c__2); + i__1 = *n - 1; + scopy_(&i__1, &e[1], &c__1, &work[ietgk + 1], &c__2); + i__1 = *n << 1; + sstevx_("N", "I", &i__1, &work[idtgk], &work[ietgk], &vutgk, &vutgk, & + iutgk, &iutgk, &abstol, ns, &s[1], &z__[z_offset], ldz, &work[ + itemp], &iwork[iiwork], &iwork[iifail], info); + vutgk = s[1] + smax * 2.f * ulp * *n; + vutgk = f2cmin(vutgk,0.f); + +/* If VLTGK=VUTGK, SSTEVX returns an error message, */ +/* so if needed we change VUTGK slightly. */ + + if (vltgk == vutgk) { + vltgk -= tol; + } + + if (wantz) { + i__1 = *n << 1; + i__2 = *iu - *il + 1; + slaset_("F", &i__1, &i__2, &c_b19, &c_b19, &z__[z_offset], ldz); + } + } + +/* Initialize variables and pointers for S, Z, and WORK. */ + +/* NRU, NRV: number of rows in U and V for the active submatrix */ +/* IDBEG, ISBEG: offsets for the entries of D and S */ +/* IROWZ, ICOLZ: offsets for the rows and columns of Z */ +/* IROWU, IROWV: offsets for the rows of U and V */ + + *ns = 0; + nru = 0; + nrv = 0; + idbeg = 1; + isbeg = 1; + irowz = 1; + icolz = 1; + irowu = 2; + irowv = 1; + split = FALSE_; + sveq0 = FALSE_; + +/* Form the tridiagonal TGK matrix. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + s[i__] = 0.f; + } +/* S( 1:N ) = ZERO */ + work[ietgk + (*n << 1) - 1] = 0.f; + i__1 = idtgk + (*n << 1) - 1; + for (i__ = idtgk; i__ <= i__1; ++i__) { + work[i__] = 0.f; + } +/* WORK( IDTGK:IDTGK+2*N-1 ) = ZERO */ + scopy_(n, &d__[1], &c__1, &work[ietgk], &c__2); + i__1 = *n - 1; + scopy_(&i__1, &e[1], &c__1, &work[ietgk + 1], &c__2); + + +/* Check for splits in two levels, outer level */ +/* in E and inner level in D. */ + + i__1 = *n << 1; + for (ieptr = 2; ieptr <= i__1; ieptr += 2) { + if (work[ietgk + ieptr - 1] == 0.f) { + +/* Split in E (this piece of B is square) or bottom */ +/* of the (input bidiagonal) matrix. */ + + isplt = idbeg; + idend = ieptr - 1; + i__2 = idend; + for (idptr = idbeg; idptr <= i__2; idptr += 2) { + if (work[ietgk + idptr - 1] == 0.f) { + +/* Split in D (rectangular submatrix). Set the number */ +/* of rows in U and V (NRU and NRV) accordingly. */ + + if (idptr == idbeg) { + +/* D=0 at the top. */ + + sveq0 = TRUE_; + if (idbeg == idend) { + nru = 1; + nrv = 1; + } + } else if (idptr == idend) { + +/* D=0 at the bottom. */ + + sveq0 = TRUE_; + nru = (idend - isplt) / 2 + 1; + nrv = nru; + if (isplt != idbeg) { + ++nru; + } + } else { + if (isplt == idbeg) { + +/* Split: top rectangular submatrix. */ + + nru = (idptr - idbeg) / 2; + nrv = nru + 1; + } else { + +/* Split: middle square submatrix. */ + + nru = (idptr - isplt) / 2 + 1; + nrv = nru; + } + } + } else if (idptr == idend) { + +/* Last entry of D in the active submatrix. */ + + if (isplt == idbeg) { + +/* No split (trivial case). */ + + nru = (idend - idbeg) / 2 + 1; + nrv = nru; + } else { + +/* Split: bottom rectangular submatrix. */ + + nrv = (idend - isplt) / 2 + 1; + nru = nrv + 1; + } + } + + ntgk = nru + nrv; + + if (ntgk > 0) { + +/* Compute eigenvalues/vectors of the active */ +/* submatrix according to RANGE: */ +/* if RANGE='A' (ALLSV) then RNGVX = 'I' */ +/* if RANGE='V' (VALSV) then RNGVX = 'V' */ +/* if RANGE='I' (INDSV) then RNGVX = 'V' */ + + iltgk = 1; + iutgk = ntgk / 2; + if (allsv || vutgk == 0.f) { + if (sveq0 || smin < eps || ntgk % 2 > 0) { +/* Special case: eigenvalue equal to zero or very */ +/* small, additional eigenvector is needed. */ + ++iutgk; + } + } + +/* Workspace needed by SSTEVX: */ +/* WORK( ITEMP: ): 2*5*NTGK */ +/* IWORK( 1: ): 2*6*NTGK */ + + sstevx_(jobz, rngvx, &ntgk, &work[idtgk + isplt - 1], & + work[ietgk + isplt - 1], &vltgk, &vutgk, &iltgk, & + iutgk, &abstol, &nsl, &s[isbeg], &z__[irowz + + icolz * z_dim1], ldz, &work[itemp], &iwork[iiwork] + , &iwork[iifail], info); + if (*info != 0) { +/* Exit with the error code from SSTEVX. */ + return 0; + } + emin = (r__1 = s[isbeg], abs(r__1)); + i__3 = isbeg + nsl - 1; + for (i__ = isbeg; i__ <= i__3; ++i__) { + if ((r__1 = s[i__], abs(r__1)) > emin) { + emin = s[i__]; + } + } +/* EMIN = ABS( MAXVAL( S( ISBEG:ISBEG+NSL-1 ) ) ) */ + + if (nsl > 0 && wantz) { + +/* Normalize u=Z([2,4,...],:) and v=Z([1,3,...],:), */ +/* changing the sign of v as discussed in the leading */ +/* comments. The norms of u and v may be (slightly) */ +/* different from 1/sqrt(2) if the corresponding */ +/* eigenvalues are very small or too close. We check */ +/* those norms and, if needed, reorthogonalize the */ +/* vectors. */ + + if (nsl > 1 && vutgk == 0.f && ntgk % 2 == 0 && emin + == 0.f && ! split) { + +/* D=0 at the top or bottom of the active submatrix: */ +/* one eigenvalue is equal to zero; concatenate the */ +/* eigenvectors corresponding to the two smallest */ +/* eigenvalues. */ + + i__3 = irowz + ntgk - 1; + for (i__ = irowz; i__ <= i__3; ++i__) { + z__[i__ + (icolz + nsl - 2) * z_dim1] += z__[ + i__ + (icolz + nsl - 1) * z_dim1]; + z__[i__ + (icolz + nsl - 1) * z_dim1] = 0.f; + } +/* Z( IROWZ:IROWZ+NTGK-1,ICOLZ+NSL-2 ) = */ +/* $ Z( IROWZ:IROWZ+NTGK-1,ICOLZ+NSL-2 ) + */ +/* $ Z( IROWZ:IROWZ+NTGK-1,ICOLZ+NSL-1 ) */ +/* Z( IROWZ:IROWZ+NTGK-1,ICOLZ+NSL-1 ) = */ +/* $ ZERO */ +/* IF( IUTGK*2.GT.NTGK ) THEN */ +/* Eigenvalue equal to zero or very small. */ +/* NSL = NSL - 1 */ +/* END IF */ + } + +/* Computing MIN */ + i__4 = nsl - 1, i__5 = nru - 1; + i__3 = f2cmin(i__4,i__5); + for (i__ = 0; i__ <= i__3; ++i__) { + nrmu = snrm2_(&nru, &z__[irowu + (icolz + i__) * + z_dim1], &c__2); + if (nrmu == 0.f) { + *info = (*n << 1) + 1; + return 0; + } + r__1 = 1.f / nrmu; + sscal_(&nru, &r__1, &z__[irowu + (icolz + i__) * + z_dim1], &c__2); + if (nrmu != 1.f && (r__1 = nrmu - ortol, abs(r__1) + ) * sqrt2 > 1.f) { + i__4 = i__ - 1; + for (j = 0; j <= i__4; ++j) { + zjtji = -sdot_(&nru, &z__[irowu + (icolz + + j) * z_dim1], &c__2, &z__[irowu + + (icolz + i__) * z_dim1], &c__2); + saxpy_(&nru, &zjtji, &z__[irowu + (icolz + + j) * z_dim1], &c__2, &z__[irowu + + (icolz + i__) * z_dim1], &c__2); + } + nrmu = snrm2_(&nru, &z__[irowu + (icolz + i__) + * z_dim1], &c__2); + r__1 = 1.f / nrmu; + sscal_(&nru, &r__1, &z__[irowu + (icolz + i__) + * z_dim1], &c__2); + } + } +/* Computing MIN */ + i__4 = nsl - 1, i__5 = nrv - 1; + i__3 = f2cmin(i__4,i__5); + for (i__ = 0; i__ <= i__3; ++i__) { + nrmv = snrm2_(&nrv, &z__[irowv + (icolz + i__) * + z_dim1], &c__2); + if (nrmv == 0.f) { + *info = (*n << 1) + 1; + return 0; + } + r__1 = -1.f / nrmv; + sscal_(&nrv, &r__1, &z__[irowv + (icolz + i__) * + z_dim1], &c__2); + if (nrmv != 1.f && (r__1 = nrmv - ortol, abs(r__1) + ) * sqrt2 > 1.f) { + i__4 = i__ - 1; + for (j = 0; j <= i__4; ++j) { + zjtji = -sdot_(&nrv, &z__[irowv + (icolz + + j) * z_dim1], &c__2, &z__[irowv + + (icolz + i__) * z_dim1], &c__2); + saxpy_(&nru, &zjtji, &z__[irowv + (icolz + + j) * z_dim1], &c__2, &z__[irowv + + (icolz + i__) * z_dim1], &c__2); + } + nrmv = snrm2_(&nrv, &z__[irowv + (icolz + i__) + * z_dim1], &c__2); + r__1 = 1.f / nrmv; + sscal_(&nrv, &r__1, &z__[irowv + (icolz + i__) + * z_dim1], &c__2); + } + } + if (vutgk == 0.f && idptr < idend && ntgk % 2 > 0) { + +/* D=0 in the middle of the active submatrix (one */ +/* eigenvalue is equal to zero): save the corresponding */ +/* eigenvector for later use (when bottom of the */ +/* active submatrix is reached). */ + + split = TRUE_; + i__3 = irowz + ntgk - 1; + for (i__ = irowz; i__ <= i__3; ++i__) { + z__[i__ + (*n + 1) * z_dim1] = z__[i__ + (*ns + + nsl) * z_dim1]; + z__[i__ + (*ns + nsl) * z_dim1] = 0.f; + } +/* Z( IROWZ:IROWZ+NTGK-1,N+1 ) = */ +/* $ Z( IROWZ:IROWZ+NTGK-1,NS+NSL ) */ +/* Z( IROWZ:IROWZ+NTGK-1,NS+NSL ) = */ +/* $ ZERO */ + } + } + +/* ** WANTZ **! */ + nsl = f2cmin(nsl,nru); + sveq0 = FALSE_; + +/* Absolute values of the eigenvalues of TGK. */ + + i__3 = nsl - 1; + for (i__ = 0; i__ <= i__3; ++i__) { + s[isbeg + i__] = (r__1 = s[isbeg + i__], abs(r__1)); + } + +/* Update pointers for TGK, S and Z. */ + + isbeg += nsl; + irowz += ntgk; + icolz += nsl; + irowu = irowz; + irowv = irowz + 1; + isplt = idptr + 1; + *ns += nsl; + nru = 0; + nrv = 0; + } +/* ** NTGK.GT.0 **! */ + if (irowz < *n << 1 && wantz) { + i__3 = irowz - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + z__[i__ + icolz * z_dim1] = 0.f; + } +/* Z( 1:IROWZ-1, ICOLZ ) = ZERO */ + } + } +/* ** IDPTR loop **! */ + if (split && wantz) { + +/* Bring back eigenvector corresponding */ +/* to eigenvalue equal to zero. */ + + i__2 = idend - ntgk + 1; + for (i__ = idbeg; i__ <= i__2; ++i__) { + z__[i__ + (isbeg - 1) * z_dim1] += z__[i__ + (*n + 1) * + z_dim1]; + z__[i__ + (*n + 1) * z_dim1] = 0.f; + } +/* Z( IDBEG:IDEND-NTGK+1,ISBEG-1 ) = */ +/* $ Z( IDBEG:IDEND-NTGK+1,ISBEG-1 ) + */ +/* $ Z( IDBEG:IDEND-NTGK+1,N+1 ) */ +/* Z( IDBEG:IDEND-NTGK+1,N+1 ) = 0 */ + } + --irowv; + ++irowu; + idbeg = ieptr + 1; + sveq0 = FALSE_; + split = FALSE_; + } +/* ** Check for split in E **! */ + } + +/* Sort the singular values into decreasing order (insertion sort on */ +/* singular values, but only one transposition per singular vector) */ + +/* ** IEPTR loop **! */ + i__1 = *ns - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + k = 1; + smin = s[1]; + i__2 = *ns + 1 - i__; + for (j = 2; j <= i__2; ++j) { + if (s[j] <= smin) { + k = j; + smin = s[j]; + } + } + if (k != *ns + 1 - i__) { + s[k] = s[*ns + 1 - i__]; + s[*ns + 1 - i__] = smin; + if (wantz) { + i__2 = *n << 1; + sswap_(&i__2, &z__[k * z_dim1 + 1], &c__1, &z__[(*ns + 1 - + i__) * z_dim1 + 1], &c__1); + } + } + } + +/* If RANGE=I, check for singular values/vectors to be discarded. */ + + if (indsv) { + k = *iu - *il + 1; + if (k < *ns) { + i__1 = *ns; + for (i__ = k + 1; i__ <= i__1; ++i__) { + s[i__] = 0.f; + } +/* S( K+1:NS ) = ZERO */ + if (wantz) { + i__1 = *n << 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *ns; + for (j = k + 1; j <= i__2; ++j) { + z__[i__ + j * z_dim1] = 0.f; + } + } +/* Z( 1:N*2,K+1:NS ) = ZERO */ + } + *ns = k; + } + } + +/* Reorder Z: U = Z( 1:N,1:NS ), V = Z( N+1:N*2,1:NS ). */ +/* If B is a lower diagonal, swap U and V. */ + + if (wantz) { + i__1 = *ns; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = *n << 1; + scopy_(&i__2, &z__[i__ * z_dim1 + 1], &c__1, &work[1], &c__1); + if (lower) { + scopy_(n, &work[2], &c__2, &z__[*n + 1 + i__ * z_dim1], &c__1) + ; + scopy_(n, &work[1], &c__2, &z__[i__ * z_dim1 + 1], &c__1); + } else { + scopy_(n, &work[2], &c__2, &z__[i__ * z_dim1 + 1], &c__1); + scopy_(n, &work[1], &c__2, &z__[*n + 1 + i__ * z_dim1], &c__1) + ; + } + } + } + + return 0; + +/* End of SBDSVDX */ + +} /* sbdsvdx_ */ + diff --git a/lapack-netlib/SRC/scombssq.c b/lapack-netlib/SRC/scombssq.c new file mode 100644 index 000000000..298503144 --- /dev/null +++ b/lapack-netlib/SRC/scombssq.c @@ -0,0 +1,486 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SCOMBSSQ adds two scaled sum of squares quantities */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SCOMBSSQ( V1, V2 ) */ + +/* REAL V1( 2 ), V2( 2 ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SCOMBSSQ adds two scaled sum of squares quantities, V1 := V1 + V2. */ +/* > That is, */ +/* > */ +/* > V1_scale**2 * V1_sumsq := V1_scale**2 * V1_sumsq */ +/* > + V2_scale**2 * V2_sumsq */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in,out] V1 */ +/* > \verbatim */ +/* > V1 is REAL array, dimension (2). */ +/* > The first scaled sum. */ +/* > V1(1) = V1_scale, V1(2) = V1_sumsq. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] V2 */ +/* > \verbatim */ +/* > V2 is REAL array, dimension (2). */ +/* > The second scaled sum. */ +/* > V2(1) = V2_scale, V2(2) = V2_sumsq. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2018 */ + +/* > \ingroup OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int scombssq_(real *v1, real *v2) +{ + /* System generated locals */ + real r__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..-- */ +/* November 2018 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --v2; + --v1; + + /* Function Body */ + if (v1[1] >= v2[1]) { + if (v1[1] != 0.f) { +/* Computing 2nd power */ + r__1 = v2[1] / v1[1]; + v1[2] += r__1 * r__1 * v2[2]; + } else { + v1[2] += v2[2]; + } + } else { +/* Computing 2nd power */ + r__1 = v1[1] / v2[1]; + v1[2] = v2[2] + r__1 * r__1 * v1[2]; + v1[1] = v2[1]; + } + return 0; + +/* End of SCOMBSSQ */ + +} /* scombssq_ */ + diff --git a/lapack-netlib/SRC/scsum1.c b/lapack-netlib/SRC/scsum1.c new file mode 100644 index 000000000..0b41d36a0 --- /dev/null +++ b/lapack-netlib/SRC/scsum1.c @@ -0,0 +1,534 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SCSUM1 forms the 1-norm of the complex vector using the true absolute value. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SCSUM1 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* REAL FUNCTION SCSUM1( N, CX, INCX ) */ + +/* INTEGER INCX, N */ +/* COMPLEX CX( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SCSUM1 takes the sum of the absolute values of a complex */ +/* > vector and returns a single precision result. */ +/* > */ +/* > Based on SCASUM from the Level 1 BLAS. */ +/* > The change is to use the 'genuine' absolute value. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of elements in the vector CX. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CX */ +/* > \verbatim */ +/* > CX is COMPLEX array, dimension (N) */ +/* > The vector whose elements will be summed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The spacing between successive values of CX. INCX > 0. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complexOTHERauxiliary */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Nick Higham for use with CLACON. */ + +/* ===================================================================== */ +real scsum1_(integer *n, complex *cx, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2; + real ret_val; + + /* Local variables */ + integer i__, nincx; + real stemp; + + +/* -- 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 */ + --cx; + + /* Function Body */ + ret_val = 0.f; + stemp = 0.f; + if (*n <= 0) { + return ret_val; + } + if (*incx == 1) { + goto L20; + } + +/* CODE FOR INCREMENT NOT EQUAL TO 1 */ + + nincx = *n * *incx; + i__1 = nincx; + i__2 = *incx; + for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) { + +/* NEXT LINE MODIFIED. */ + + stemp += c_abs(&cx[i__]); +/* L10: */ + } + ret_val = stemp; + return ret_val; + +/* CODE FOR INCREMENT EQUAL TO 1 */ + +L20: + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + +/* NEXT LINE MODIFIED. */ + + stemp += c_abs(&cx[i__]); +/* L30: */ + } + ret_val = stemp; + return ret_val; + +/* End of SCSUM1 */ + +} /* scsum1_ */ + diff --git a/lapack-netlib/SRC/sdisna.c b/lapack-netlib/SRC/sdisna.c new file mode 100644 index 000000000..722bf55ae --- /dev/null +++ b/lapack-netlib/SRC/sdisna.c @@ -0,0 +1,652 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SDISNA */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SDISNA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SDISNA( JOB, M, N, D, SEP, INFO ) */ + +/* CHARACTER JOB */ +/* INTEGER INFO, M, N */ +/* REAL D( * ), SEP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SDISNA computes the reciprocal condition numbers for the eigenvectors */ +/* > of a real symmetric or complex Hermitian matrix or for the left or */ +/* > right singular vectors of a general m-by-n matrix. The reciprocal */ +/* > condition number is the 'gap' between the corresponding eigenvalue or */ +/* > singular value and the nearest other one. */ +/* > */ +/* > The bound on the error, measured by angle in radians, in the I-th */ +/* > computed vector is given by */ +/* > */ +/* > SLAMCH( 'E' ) * ( ANORM / SEP( I ) ) */ +/* > */ +/* > where ANORM = 2-norm(A) = f2cmax( abs( D(j) ) ). SEP(I) is not allowed */ +/* > to be smaller than SLAMCH( 'E' )*ANORM in order to limit the size of */ +/* > the error bound. */ +/* > */ +/* > SDISNA may also be used to compute error bounds for eigenvectors of */ +/* > the generalized symmetric definite eigenproblem. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOB */ +/* > \verbatim */ +/* > JOB is CHARACTER*1 */ +/* > Specifies for which problem the reciprocal condition numbers */ +/* > should be computed: */ +/* > = 'E': the eigenvectors of a symmetric/Hermitian matrix; */ +/* > = 'L': the left singular vectors of a general matrix; */ +/* > = 'R': the right singular vectors of a general matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > If JOB = 'L' or 'R', the number of columns of the matrix, */ +/* > in which case N >= 0. Ignored if JOB = 'E'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (M) if JOB = 'E' */ +/* > dimension (f2cmin(M,N)) if JOB = 'L' or 'R' */ +/* > The eigenvalues (if JOB = 'E') or singular values (if JOB = */ +/* > 'L' or 'R') of the matrix, in either increasing or decreasing */ +/* > order. If singular values, they must be non-negative. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] SEP */ +/* > \verbatim */ +/* > SEP is REAL array, dimension (M) if JOB = 'E' */ +/* > dimension (f2cmin(M,N)) if JOB = 'L' or 'R' */ +/* > The reciprocal condition numbers of the vectors. */ +/* > \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 auxOTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int sdisna_(char *job, integer *m, integer *n, real *d__, + real *sep, integer *info) +{ + /* System generated locals */ + integer i__1; + real r__1, r__2, r__3; + + /* Local variables */ + logical decr, left, incr, sing; + integer i__, k; + logical eigen; + extern logical lsame_(char *, char *); + real anorm; + logical right; + real oldgap; + extern real slamch_(char *); + real safmin; + extern /* Subroutine */ int xerbla_(char *, integer *,ftnlen); + real newgap, thresh, eps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input arguments */ + + /* Parameter adjustments */ + --sep; + --d__; + + /* Function Body */ + *info = 0; + eigen = lsame_(job, "E"); + left = lsame_(job, "L"); + right = lsame_(job, "R"); + sing = left || right; + if (eigen) { + k = *m; + } else if (sing) { + k = f2cmin(*m,*n); + } + if (! eigen && ! sing) { + *info = -1; + } else if (*m < 0) { + *info = -2; + } else if (k < 0) { + *info = -3; + } else { + incr = TRUE_; + decr = TRUE_; + i__1 = k - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + if (incr) { + incr = incr && d__[i__] <= d__[i__ + 1]; + } + if (decr) { + decr = decr && d__[i__] >= d__[i__ + 1]; + } +/* L10: */ + } + if (sing && k > 0) { + if (incr) { + incr = incr && 0.f <= d__[1]; + } + if (decr) { + decr = decr && d__[k] >= 0.f; + } + } + if (! (incr || decr)) { + *info = -4; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SDISNA", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (k == 0) { + return 0; + } + +/* Compute reciprocal condition numbers */ + + if (k == 1) { + sep[1] = slamch_("O"); + } else { + oldgap = (r__1 = d__[2] - d__[1], abs(r__1)); + sep[1] = oldgap; + i__1 = k - 1; + for (i__ = 2; i__ <= i__1; ++i__) { + newgap = (r__1 = d__[i__ + 1] - d__[i__], abs(r__1)); + sep[i__] = f2cmin(oldgap,newgap); + oldgap = newgap; +/* L20: */ + } + sep[k] = oldgap; + } + if (sing) { + if (left && *m > *n || right && *m < *n) { + if (incr) { + sep[1] = f2cmin(sep[1],d__[1]); + } + if (decr) { +/* Computing MIN */ + r__1 = sep[k], r__2 = d__[k]; + sep[k] = f2cmin(r__1,r__2); + } + } + } + +/* Ensure that reciprocal condition numbers are not less than */ +/* threshold, in order to limit the size of the error bound */ + + eps = slamch_("E"); + safmin = slamch_("S"); +/* Computing MAX */ + r__2 = abs(d__[1]), r__3 = (r__1 = d__[k], abs(r__1)); + anorm = f2cmax(r__2,r__3); + if (anorm == 0.f) { + thresh = eps; + } else { +/* Computing MAX */ + r__1 = eps * anorm; + thresh = f2cmax(r__1,safmin); + } + i__1 = k; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + r__1 = sep[i__]; + sep[i__] = f2cmax(r__1,thresh); +/* L30: */ + } + + return 0; + +/* End of SDISNA */ + +} /* sdisna_ */ + diff --git a/lapack-netlib/SRC/sgbbrd.c b/lapack-netlib/SRC/sgbbrd.c new file mode 100644 index 000000000..94deab824 --- /dev/null +++ b/lapack-netlib/SRC/sgbbrd.c @@ -0,0 +1,1029 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SGBBRD */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SGBBRD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q, */ +/* LDQ, PT, LDPT, C, LDC, WORK, INFO ) */ + +/* CHARACTER VECT */ +/* INTEGER INFO, KL, KU, LDAB, LDC, LDPT, LDQ, M, N, NCC */ +/* REAL AB( LDAB, * ), C( LDC, * ), D( * ), E( * ), */ +/* $ PT( LDPT, * ), Q( LDQ, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SGBBRD reduces a real general m-by-n band matrix A to upper */ +/* > bidiagonal form B by an orthogonal transformation: Q**T * A * P = B. */ +/* > */ +/* > The routine computes B, and optionally forms Q or P**T, or computes */ +/* > Q**T*C for a given matrix C. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] VECT */ +/* > \verbatim */ +/* > VECT is CHARACTER*1 */ +/* > Specifies whether or not the matrices Q and P**T are to be */ +/* > formed. */ +/* > = 'N': do not form Q or P**T; */ +/* > = 'Q': form Q only; */ +/* > = 'P': form P**T only; */ +/* > = 'B': form both. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NCC */ +/* > \verbatim */ +/* > NCC is INTEGER */ +/* > The number of columns of the matrix C. NCC >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of subdiagonals of the matrix A. KL >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of superdiagonals of the matrix A. KU >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is REAL array, dimension (LDAB,N) */ +/* > On entry, the m-by-n band matrix A, stored in rows 1 to */ +/* > KL+KU+1. The j-th column of A is stored in the j-th column of */ +/* > the array AB as follows: */ +/* > AB(ku+1+i-j,j) = A(i,j) for f2cmax(1,j-ku)<=i<=f2cmin(m,j+kl). */ +/* > On exit, A is overwritten by values generated during the */ +/* > reduction. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array A. LDAB >= KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (f2cmin(M,N)) */ +/* > The diagonal elements of the bidiagonal matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (f2cmin(M,N)-1) */ +/* > The superdiagonal elements of the bidiagonal matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Q */ +/* > \verbatim */ +/* > Q is REAL array, dimension (LDQ,M) */ +/* > If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q. */ +/* > If VECT = 'N' or 'P', the array Q is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. */ +/* > LDQ >= f2cmax(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] PT */ +/* > \verbatim */ +/* > PT is REAL array, dimension (LDPT,N) */ +/* > If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'. */ +/* > If VECT = 'N' or 'Q', the array PT is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDPT */ +/* > \verbatim */ +/* > LDPT is INTEGER */ +/* > The leading dimension of the array PT. */ +/* > LDPT >= f2cmax(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (LDC,NCC) */ +/* > On entry, an m-by-ncc matrix C. */ +/* > On exit, C is overwritten by Q**T*C. */ +/* > C is not referenced if NCC = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDC */ +/* > \verbatim */ +/* > LDC is INTEGER */ +/* > The leading dimension of the array C. */ +/* > LDC >= f2cmax(1,M) if NCC > 0; LDC >= 1 if NCC = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (2*f2cmax(M,N)) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realGBcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int sgbbrd_(char *vect, integer *m, integer *n, integer *ncc, + integer *kl, integer *ku, real *ab, integer *ldab, real *d__, real * + e, real *q, integer *ldq, real *pt, integer *ldpt, real *c__, integer + *ldc, real *work, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, c_dim1, c_offset, pt_dim1, pt_offset, q_dim1, + q_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; + + /* Local variables */ + integer inca; + extern /* Subroutine */ int srot_(integer *, real *, integer *, real *, + integer *, real *, real *); + integer i__, j, l; + extern logical lsame_(char *, char *); + logical wantb, wantc; + integer minmn; + logical wantq; + integer j1, j2, kb; + real ra, rb, rc; + integer kk, ml, mn, nr, mu; + real rs; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), slaset_( + char *, integer *, integer *, real *, real *, real *, integer *), slartg_(real *, real *, real *, real *, real *); + integer kb1; + extern /* Subroutine */ int slargv_(integer *, real *, integer *, real *, + integer *, real *, integer *); + integer ml0; + extern /* Subroutine */ int slartv_(integer *, real *, integer *, real *, + integer *, real *, real *, integer *); + logical wantpt; + integer mu0, klm, kun, nrt, klu1; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --d__; + --e; + q_dim1 = *ldq; + q_offset = 1 + q_dim1 * 1; + q -= q_offset; + pt_dim1 = *ldpt; + pt_offset = 1 + pt_dim1 * 1; + pt -= pt_offset; + c_dim1 = *ldc; + c_offset = 1 + c_dim1 * 1; + c__ -= c_offset; + --work; + + /* Function Body */ + wantb = lsame_(vect, "B"); + wantq = lsame_(vect, "Q") || wantb; + wantpt = lsame_(vect, "P") || wantb; + wantc = *ncc > 0; + klu1 = *kl + *ku + 1; + *info = 0; + if (! wantq && ! wantpt && ! lsame_(vect, "N")) { + *info = -1; + } else if (*m < 0) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ncc < 0) { + *info = -4; + } else if (*kl < 0) { + *info = -5; + } else if (*ku < 0) { + *info = -6; + } else if (*ldab < klu1) { + *info = -8; + } else if (*ldq < 1 || wantq && *ldq < f2cmax(1,*m)) { + *info = -12; + } else if (*ldpt < 1 || wantpt && *ldpt < f2cmax(1,*n)) { + *info = -14; + } else if (*ldc < 1 || wantc && *ldc < f2cmax(1,*m)) { + *info = -16; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SGBBRD", &i__1, (ftnlen)6); + return 0; + } + +/* Initialize Q and P**T to the unit matrix, if needed */ + + if (wantq) { + slaset_("Full", m, m, &c_b8, &c_b9, &q[q_offset], ldq); + } + if (wantpt) { + slaset_("Full", n, n, &c_b8, &c_b9, &pt[pt_offset], ldpt); + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0) { + return 0; + } + + minmn = f2cmin(*m,*n); + + if (*kl + *ku > 1) { + +/* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce */ +/* first to lower bidiagonal form and then transform to upper */ +/* bidiagonal */ + + if (*ku > 0) { + ml0 = 1; + mu0 = 2; + } else { + ml0 = 2; + mu0 = 1; + } + +/* Wherever possible, plane rotations are generated and applied in */ +/* vector operations of length NR over the index set J1:J2:KLU1. */ + +/* The sines of the plane rotations are stored in WORK(1:f2cmax(m,n)) */ +/* and the cosines in WORK(f2cmax(m,n)+1:2*f2cmax(m,n)). */ + + mn = f2cmax(*m,*n); +/* Computing MIN */ + i__1 = *m - 1; + klm = f2cmin(i__1,*kl); +/* Computing MIN */ + i__1 = *n - 1; + kun = f2cmin(i__1,*ku); + kb = klm + kun; + kb1 = kb + 1; + inca = kb1 * *ldab; + nr = 0; + j1 = klm + 2; + j2 = 1 - kun; + + i__1 = minmn; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Reduce i-th column and i-th row of matrix to bidiagonal form */ + + ml = klm + 1; + mu = kun + 1; + i__2 = kb; + for (kk = 1; kk <= i__2; ++kk) { + j1 += kb; + j2 += kb; + +/* generate plane rotations to annihilate nonzero elements */ +/* which have been created below the band */ + + if (nr > 0) { + slargv_(&nr, &ab[klu1 + (j1 - klm - 1) * ab_dim1], &inca, + &work[j1], &kb1, &work[mn + j1], &kb1); + } + +/* apply plane rotations from the left */ + + i__3 = kb; + for (l = 1; l <= i__3; ++l) { + if (j2 - klm + l - 1 > *n) { + nrt = nr - 1; + } else { + nrt = nr; + } + if (nrt > 0) { + slartv_(&nrt, &ab[klu1 - l + (j1 - klm + l - 1) * + ab_dim1], &inca, &ab[klu1 - l + 1 + (j1 - klm + + l - 1) * ab_dim1], &inca, &work[mn + j1], & + work[j1], &kb1); + } +/* L10: */ + } + + if (ml > ml0) { + if (ml <= *m - i__ + 1) { + +/* generate plane rotation to annihilate a(i+ml-1,i) */ +/* within the band, and apply rotation from the left */ + + slartg_(&ab[*ku + ml - 1 + i__ * ab_dim1], &ab[*ku + + ml + i__ * ab_dim1], &work[mn + i__ + ml - 1], + &work[i__ + ml - 1], &ra); + ab[*ku + ml - 1 + i__ * ab_dim1] = ra; + if (i__ < *n) { +/* Computing MIN */ + i__4 = *ku + ml - 2, i__5 = *n - i__; + i__3 = f2cmin(i__4,i__5); + i__6 = *ldab - 1; + i__7 = *ldab - 1; + srot_(&i__3, &ab[*ku + ml - 2 + (i__ + 1) * + ab_dim1], &i__6, &ab[*ku + ml - 1 + (i__ + + 1) * ab_dim1], &i__7, &work[mn + i__ + + ml - 1], &work[i__ + ml - 1]); + } + } + ++nr; + j1 -= kb1; + } + + if (wantq) { + +/* accumulate product of plane rotations in Q */ + + i__3 = j2; + i__4 = kb1; + for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) + { + srot_(m, &q[(j - 1) * q_dim1 + 1], &c__1, &q[j * + q_dim1 + 1], &c__1, &work[mn + j], &work[j]); +/* L20: */ + } + } + + if (wantc) { + +/* apply plane rotations to C */ + + i__4 = j2; + i__3 = kb1; + for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) + { + srot_(ncc, &c__[j - 1 + c_dim1], ldc, &c__[j + c_dim1] + , ldc, &work[mn + j], &work[j]); +/* L30: */ + } + } + + if (j2 + kun > *n) { + +/* adjust J2 to keep within the bounds of the matrix */ + + --nr; + j2 -= kb1; + } + + i__3 = j2; + i__4 = kb1; + for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { + +/* create nonzero element a(j-1,j+ku) above the band */ +/* and store it in WORK(n+1:2*n) */ + + work[j + kun] = work[j] * ab[(j + kun) * ab_dim1 + 1]; + ab[(j + kun) * ab_dim1 + 1] = work[mn + j] * ab[(j + kun) + * ab_dim1 + 1]; +/* L40: */ + } + +/* generate plane rotations to annihilate nonzero elements */ +/* which have been generated above the band */ + + if (nr > 0) { + slargv_(&nr, &ab[(j1 + kun - 1) * ab_dim1 + 1], &inca, & + work[j1 + kun], &kb1, &work[mn + j1 + kun], &kb1); + } + +/* apply plane rotations from the right */ + + i__4 = kb; + for (l = 1; l <= i__4; ++l) { + if (j2 + l - 1 > *m) { + nrt = nr - 1; + } else { + nrt = nr; + } + if (nrt > 0) { + slartv_(&nrt, &ab[l + 1 + (j1 + kun - 1) * ab_dim1], & + inca, &ab[l + (j1 + kun) * ab_dim1], &inca, & + work[mn + j1 + kun], &work[j1 + kun], &kb1); + } +/* L50: */ + } + + if (ml == ml0 && mu > mu0) { + if (mu <= *n - i__ + 1) { + +/* generate plane rotation to annihilate a(i,i+mu-1) */ +/* within the band, and apply rotation from the right */ + + slartg_(&ab[*ku - mu + 3 + (i__ + mu - 2) * ab_dim1], + &ab[*ku - mu + 2 + (i__ + mu - 1) * ab_dim1], + &work[mn + i__ + mu - 1], &work[i__ + mu - 1], + &ra); + ab[*ku - mu + 3 + (i__ + mu - 2) * ab_dim1] = ra; +/* Computing MIN */ + i__3 = *kl + mu - 2, i__5 = *m - i__; + i__4 = f2cmin(i__3,i__5); + srot_(&i__4, &ab[*ku - mu + 4 + (i__ + mu - 2) * + ab_dim1], &c__1, &ab[*ku - mu + 3 + (i__ + mu + - 1) * ab_dim1], &c__1, &work[mn + i__ + mu - + 1], &work[i__ + mu - 1]); + } + ++nr; + j1 -= kb1; + } + + if (wantpt) { + +/* accumulate product of plane rotations in P**T */ + + i__4 = j2; + i__3 = kb1; + for (j = j1; i__3 < 0 ? j >= i__4 : j <= i__4; j += i__3) + { + srot_(n, &pt[j + kun - 1 + pt_dim1], ldpt, &pt[j + + kun + pt_dim1], ldpt, &work[mn + j + kun], & + work[j + kun]); +/* L60: */ + } + } + + if (j2 + kb > *m) { + +/* adjust J2 to keep within the bounds of the matrix */ + + --nr; + j2 -= kb1; + } + + i__3 = j2; + i__4 = kb1; + for (j = j1; i__4 < 0 ? j >= i__3 : j <= i__3; j += i__4) { + +/* create nonzero element a(j+kl+ku,j+ku-1) below the */ +/* band and store it in WORK(1:n) */ + + work[j + kb] = work[j + kun] * ab[klu1 + (j + kun) * + ab_dim1]; + ab[klu1 + (j + kun) * ab_dim1] = work[mn + j + kun] * ab[ + klu1 + (j + kun) * ab_dim1]; +/* L70: */ + } + + if (ml > ml0) { + --ml; + } else { + --mu; + } +/* L80: */ + } +/* L90: */ + } + } + + if (*ku == 0 && *kl > 0) { + +/* A has been reduced to lower bidiagonal form */ + +/* Transform lower bidiagonal form to upper bidiagonal by applying */ +/* plane rotations from the left, storing diagonal elements in D */ +/* and off-diagonal elements in E */ + +/* Computing MIN */ + i__2 = *m - 1; + i__1 = f2cmin(i__2,*n); + for (i__ = 1; i__ <= i__1; ++i__) { + slartg_(&ab[i__ * ab_dim1 + 1], &ab[i__ * ab_dim1 + 2], &rc, &rs, + &ra); + d__[i__] = ra; + if (i__ < *n) { + e[i__] = rs * ab[(i__ + 1) * ab_dim1 + 1]; + ab[(i__ + 1) * ab_dim1 + 1] = rc * ab[(i__ + 1) * ab_dim1 + 1] + ; + } + if (wantq) { + srot_(m, &q[i__ * q_dim1 + 1], &c__1, &q[(i__ + 1) * q_dim1 + + 1], &c__1, &rc, &rs); + } + if (wantc) { + srot_(ncc, &c__[i__ + c_dim1], ldc, &c__[i__ + 1 + c_dim1], + ldc, &rc, &rs); + } +/* L100: */ + } + if (*m <= *n) { + d__[*m] = ab[*m * ab_dim1 + 1]; + } + } else if (*ku > 0) { + +/* A has been reduced to upper bidiagonal form */ + + if (*m < *n) { + +/* Annihilate a(m,m+1) by applying plane rotations from the */ +/* right, storing diagonal elements in D and off-diagonal */ +/* elements in E */ + + rb = ab[*ku + (*m + 1) * ab_dim1]; + for (i__ = *m; i__ >= 1; --i__) { + slartg_(&ab[*ku + 1 + i__ * ab_dim1], &rb, &rc, &rs, &ra); + d__[i__] = ra; + if (i__ > 1) { + rb = -rs * ab[*ku + i__ * ab_dim1]; + e[i__ - 1] = rc * ab[*ku + i__ * ab_dim1]; + } + if (wantpt) { + srot_(n, &pt[i__ + pt_dim1], ldpt, &pt[*m + 1 + pt_dim1], + ldpt, &rc, &rs); + } +/* L110: */ + } + } else { + +/* Copy off-diagonal elements to E and diagonal elements to D */ + + i__1 = minmn - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + e[i__] = ab[*ku + (i__ + 1) * ab_dim1]; +/* L120: */ + } + i__1 = minmn; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = ab[*ku + 1 + i__ * ab_dim1]; +/* L130: */ + } + } + } else { + +/* A is diagonal. Set elements of E to zero and copy diagonal */ +/* elements to D. */ + + i__1 = minmn - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + e[i__] = 0.f; +/* L140: */ + } + i__1 = minmn; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = ab[i__ * ab_dim1 + 1]; +/* L150: */ + } + } + return 0; + +/* End of SGBBRD */ + +} /* sgbbrd_ */ + diff --git a/lapack-netlib/SRC/sgbcon.c b/lapack-netlib/SRC/sgbcon.c new file mode 100644 index 000000000..b68d2913b --- /dev/null +++ b/lapack-netlib/SRC/sgbcon.c @@ -0,0 +1,722 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SGBCON */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SGBCON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, */ +/* WORK, IWORK, INFO ) */ + +/* CHARACTER NORM */ +/* INTEGER INFO, KL, KU, LDAB, N */ +/* REAL ANORM, RCOND */ +/* INTEGER IPIV( * ), IWORK( * ) */ +/* REAL AB( LDAB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SGBCON estimates the reciprocal of the condition number of a real */ +/* > general band matrix A, in either the 1-norm or the infinity-norm, */ +/* > using the LU factorization computed by SGBTRF. */ +/* > */ +/* > An estimate is obtained for norm(inv(A)), and the reciprocal of the */ +/* > condition number is computed as */ +/* > RCOND = 1 / ( norm(A) * norm(inv(A)) ). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] NORM */ +/* > \verbatim */ +/* > NORM is CHARACTER*1 */ +/* > Specifies whether the 1-norm condition number or the */ +/* > infinity-norm condition number is required: */ +/* > = '1' or 'O': 1-norm; */ +/* > = 'I': Infinity-norm. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of subdiagonals within the band of A. KL >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of superdiagonals within the band of A. KU >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is REAL array, dimension (LDAB,N) */ +/* > Details of the LU factorization of the band matrix A, as */ +/* > computed by SGBTRF. U is stored as an upper triangular band */ +/* > matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */ +/* > the multipliers used during the factorization are stored in */ +/* > rows KL+KU+2 to 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices; for 1 <= i <= N, row i of the matrix was */ +/* > interchanged with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ANORM */ +/* > \verbatim */ +/* > ANORM is REAL */ +/* > If NORM = '1' or 'O', the 1-norm of the original matrix A. */ +/* > If NORM = 'I', the infinity-norm of the original matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > The reciprocal of the condition number of the matrix A, */ +/* > computed as RCOND = 1/(norm(A) * norm(inv(A))). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realGBcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int sgbcon_(char *norm, integer *n, integer *kl, integer *ku, + real *ab, integer *ldab, integer *ipiv, real *anorm, real *rcond, + real *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3; + real r__1; + + /* Local variables */ + integer kase; + extern real sdot_(integer *, real *, integer *, real *, integer *); + integer kase1, j; + real t, scale; + extern logical lsame_(char *, char *); + integer isave[3]; + logical lnoti; + extern /* Subroutine */ int srscl_(integer *, real *, real *, integer *), + saxpy_(integer *, real *, real *, integer *, real *, integer *), + slacn2_(integer *, real *, real *, integer *, real *, integer *, + integer *); + integer kd, lm, jp, ix; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer isamax_(integer *, real *, integer *); + real ainvnm; + extern /* Subroutine */ int slatbs_(char *, char *, char *, char *, + integer *, integer *, real *, integer *, real *, real *, real *, + integer *); + logical onenrm; + char normin[1]; + real smlnum; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --ipiv; + --work; + --iwork; + + /* Function Body */ + *info = 0; + onenrm = *(unsigned char *)norm == '1' || lsame_(norm, "O"); + if (! onenrm && ! lsame_(norm, "I")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0) { + *info = -3; + } else if (*ku < 0) { + *info = -4; + } else if (*ldab < (*kl << 1) + *ku + 1) { + *info = -6; + } else if (*anorm < 0.f) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SGBCON", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + *rcond = 0.f; + if (*n == 0) { + *rcond = 1.f; + return 0; + } else if (*anorm == 0.f) { + return 0; + } + + smlnum = slamch_("Safe minimum"); + +/* Estimate the norm of inv(A). */ + + ainvnm = 0.f; + *(unsigned char *)normin = 'N'; + if (onenrm) { + kase1 = 1; + } else { + kase1 = 2; + } + kd = *kl + *ku + 1; + lnoti = *kl > 0; + kase = 0; +L10: + slacn2_(n, &work[*n + 1], &work[1], &iwork[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == kase1) { + +/* Multiply by inv(L). */ + + if (lnoti) { + i__1 = *n - 1; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + i__2 = *kl, i__3 = *n - j; + lm = f2cmin(i__2,i__3); + jp = ipiv[j]; + t = work[jp]; + if (jp != j) { + work[jp] = work[j]; + work[j] = t; + } + r__1 = -t; + saxpy_(&lm, &r__1, &ab[kd + 1 + j * ab_dim1], &c__1, & + work[j + 1], &c__1); +/* L20: */ + } + } + +/* Multiply by inv(U). */ + + i__1 = *kl + *ku; + slatbs_("Upper", "No transpose", "Non-unit", normin, n, &i__1, & + ab[ab_offset], ldab, &work[1], &scale, &work[(*n << 1) + + 1], info); + } else { + +/* Multiply by inv(U**T). */ + + i__1 = *kl + *ku; + slatbs_("Upper", "Transpose", "Non-unit", normin, n, &i__1, &ab[ + ab_offset], ldab, &work[1], &scale, &work[(*n << 1) + 1], + info); + +/* Multiply by inv(L**T). */ + + if (lnoti) { + for (j = *n - 1; j >= 1; --j) { +/* Computing MIN */ + i__1 = *kl, i__2 = *n - j; + lm = f2cmin(i__1,i__2); + work[j] -= sdot_(&lm, &ab[kd + 1 + j * ab_dim1], &c__1, & + work[j + 1], &c__1); + jp = ipiv[j]; + if (jp != j) { + t = work[jp]; + work[jp] = work[j]; + work[j] = t; + } +/* L30: */ + } + } + } + +/* Divide X by 1/SCALE if doing so will not cause overflow. */ + + *(unsigned char *)normin = 'Y'; + if (scale != 1.f) { + ix = isamax_(n, &work[1], &c__1); + if (scale < (r__1 = work[ix], abs(r__1)) * smlnum || scale == 0.f) + { + goto L40; + } + srscl_(n, &scale, &work[1], &c__1); + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.f) { + *rcond = 1.f / ainvnm / *anorm; + } + +L40: + return 0; + +/* End of SGBCON */ + +} /* sgbcon_ */ + diff --git a/lapack-netlib/SRC/sgbequ.c b/lapack-netlib/SRC/sgbequ.c new file mode 100644 index 000000000..33ee31f93 --- /dev/null +++ b/lapack-netlib/SRC/sgbequ.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 SGBEQU */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SGBEQU + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, */ +/* AMAX, INFO ) */ + +/* INTEGER INFO, KL, KU, LDAB, M, N */ +/* REAL AMAX, COLCND, ROWCND */ +/* REAL AB( LDAB, * ), C( * ), R( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SGBEQU computes row and column scalings intended to equilibrate an */ +/* > M-by-N band matrix A and reduce its condition number. R returns the */ +/* > row scale factors and C the column scale factors, chosen to try to */ +/* > make the largest element in each row and column of the matrix B with */ +/* > elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1. */ +/* > */ +/* > R(i) and C(j) are restricted to be between SMLNUM = smallest safe */ +/* > number and BIGNUM = largest safe number. Use of these scaling */ +/* > factors is not guaranteed to reduce the condition number of A but */ +/* > works well in practice. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of subdiagonals within the band of A. KL >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of superdiagonals within the band of A. KU >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is REAL array, dimension (LDAB,N) */ +/* > The band matrix A, stored in rows 1 to KL+KU+1. The j-th */ +/* > column of A is stored in the j-th column of the array AB as */ +/* > follows: */ +/* > AB(ku+1+i-j,j) = A(i,j) for f2cmax(1,j-ku)<=i<=f2cmin(m,j+kl). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] R */ +/* > \verbatim */ +/* > R is REAL array, dimension (M) */ +/* > If INFO = 0, or INFO > M, R contains the row scale factors */ +/* > for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (N) */ +/* > If INFO = 0, C contains the column scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ROWCND */ +/* > \verbatim */ +/* > ROWCND is REAL */ +/* > If INFO = 0 or INFO > M, ROWCND contains the ratio of the */ +/* > smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */ +/* > AMAX is neither too large nor too small, it is not worth */ +/* > scaling by R. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] COLCND */ +/* > \verbatim */ +/* > COLCND is REAL */ +/* > If INFO = 0, COLCND contains the ratio of the smallest */ +/* > C(i) to the largest C(i). If COLCND >= 0.1, it is not */ +/* > worth scaling by C. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] AMAX */ +/* > \verbatim */ +/* > AMAX is REAL */ +/* > Absolute value of largest matrix element. If AMAX is very */ +/* > close to overflow or very close to underflow, the matrix */ +/* > should be scaled. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, and i is */ +/* > <= M: the i-th row of A is exactly zero */ +/* > > M: the (i-M)-th column of A is exactly zero */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realGBcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int sgbequ_(integer *m, integer *n, integer *kl, integer *ku, + real *ab, integer *ldab, real *r__, real *c__, real *rowcnd, real * + colcnd, real *amax, 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 i__, j; + real rcmin, rcmax; + integer kd; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real bignum, smlnum; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --r__; + --c__; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0) { + *info = -3; + } else if (*ku < 0) { + *info = -4; + } else if (*ldab < *kl + *ku + 1) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SGBEQU", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + *rowcnd = 1.f; + *colcnd = 1.f; + *amax = 0.f; + return 0; + } + +/* Get machine constants. */ + + smlnum = slamch_("S"); + bignum = 1.f / smlnum; + +/* Compute row scale factors. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + r__[i__] = 0.f; +/* L10: */ + } + +/* Find the maximum element in each row. */ + + kd = *ku + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = j - *ku; +/* Computing MIN */ + i__4 = j + *kl; + i__3 = f2cmin(i__4,*m); + for (i__ = f2cmax(i__2,1); i__ <= i__3; ++i__) { +/* Computing MAX */ + r__2 = r__[i__], r__3 = (r__1 = ab[kd + i__ - j + j * ab_dim1], + abs(r__1)); + r__[i__] = f2cmax(r__2,r__3); +/* L20: */ + } +/* L30: */ + } + +/* Find the maximum and minimum scale factors. */ + + rcmin = bignum; + rcmax = 0.f; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + r__1 = rcmax, r__2 = r__[i__]; + rcmax = f2cmax(r__1,r__2); +/* Computing MIN */ + r__1 = rcmin, r__2 = r__[i__]; + rcmin = f2cmin(r__1,r__2); +/* L40: */ + } + *amax = rcmax; + + if (rcmin == 0.f) { + +/* Find the first zero scale factor and return an error code. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (r__[i__] == 0.f) { + *info = i__; + return 0; + } +/* L50: */ + } + } else { + +/* Invert the scale factors. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MIN */ +/* Computing MAX */ + r__2 = r__[i__]; + r__1 = f2cmax(r__2,smlnum); + r__[i__] = 1.f / f2cmin(r__1,bignum); +/* L60: */ + } + +/* Compute ROWCND = f2cmin(R(I)) / f2cmax(R(I)) */ + + *rowcnd = f2cmax(rcmin,smlnum) / f2cmin(rcmax,bignum); + } + +/* Compute column scale factors */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + c__[j] = 0.f; +/* L70: */ + } + +/* Find the maximum element in each column, */ +/* assuming the row scaling computed above. */ + + kd = *ku + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__3 = j - *ku; +/* Computing MIN */ + i__4 = j + *kl; + i__2 = f2cmin(i__4,*m); + for (i__ = f2cmax(i__3,1); i__ <= i__2; ++i__) { +/* Computing MAX */ + r__2 = c__[j], r__3 = (r__1 = ab[kd + i__ - j + j * ab_dim1], abs( + r__1)) * r__[i__]; + c__[j] = f2cmax(r__2,r__3); +/* L80: */ + } +/* L90: */ + } + +/* Find the maximum and minimum scale factors. */ + + rcmin = bignum; + rcmax = 0.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + r__1 = rcmin, r__2 = c__[j]; + rcmin = f2cmin(r__1,r__2); +/* Computing MAX */ + r__1 = rcmax, r__2 = c__[j]; + rcmax = f2cmax(r__1,r__2); +/* L100: */ + } + + if (rcmin == 0.f) { + +/* Find the first zero scale factor and return an error code. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (c__[j] == 0.f) { + *info = *m + j; + return 0; + } +/* L110: */ + } + } else { + +/* Invert the scale factors. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ +/* Computing MAX */ + r__2 = c__[j]; + r__1 = f2cmax(r__2,smlnum); + c__[j] = 1.f / f2cmin(r__1,bignum); +/* L120: */ + } + +/* Compute COLCND = f2cmin(C(J)) / f2cmax(C(J)) */ + + *colcnd = f2cmax(rcmin,smlnum) / f2cmin(rcmax,bignum); + } + + return 0; + +/* End of SGBEQU */ + +} /* sgbequ_ */ + diff --git a/lapack-netlib/SRC/sgbequb.c b/lapack-netlib/SRC/sgbequb.c new file mode 100644 index 000000000..952819e32 --- /dev/null +++ b/lapack-netlib/SRC/sgbequb.c @@ -0,0 +1,782 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SGBEQUB */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SGBEQUB + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SGBEQUB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, */ +/* AMAX, INFO ) */ + +/* INTEGER INFO, KL, KU, LDAB, M, N */ +/* REAL AMAX, COLCND, ROWCND */ +/* REAL AB( LDAB, * ), C( * ), R( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SGBEQUB computes row and column scalings intended to equilibrate an */ +/* > M-by-N matrix A and reduce its condition number. R returns the row */ +/* > scale factors and C the column scale factors, chosen to try to make */ +/* > the largest element in each row and column of the matrix B with */ +/* > elements B(i,j)=R(i)*A(i,j)*C(j) have an absolute value of at most */ +/* > the radix. */ +/* > */ +/* > R(i) and C(j) are restricted to be a power of the radix between */ +/* > SMLNUM = smallest safe number and BIGNUM = largest safe number. Use */ +/* > of these scaling factors is not guaranteed to reduce the condition */ +/* > number of A but works well in practice. */ +/* > */ +/* > This routine differs from SGEEQU by restricting the scaling factors */ +/* > to a power of the radix. Barring over- and underflow, scaling by */ +/* > these factors introduces no additional rounding errors. However, the */ +/* > scaled entries' magnitudes are no longer approximately 1 but lie */ +/* > between sqrt(radix) and 1/sqrt(radix). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of subdiagonals within the band of A. KL >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of superdiagonals within the band of A. KU >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is 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(N,j+kl) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array A. LDAB >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] R */ +/* > \verbatim */ +/* > R is REAL array, dimension (M) */ +/* > If INFO = 0 or INFO > M, R contains the row scale factors */ +/* > for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (N) */ +/* > If INFO = 0, C contains the column scale factors for A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ROWCND */ +/* > \verbatim */ +/* > ROWCND is REAL */ +/* > If INFO = 0 or INFO > M, ROWCND contains the ratio of the */ +/* > smallest R(i) to the largest R(i). If ROWCND >= 0.1 and */ +/* > AMAX is neither too large nor too small, it is not worth */ +/* > scaling by R. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] COLCND */ +/* > \verbatim */ +/* > COLCND is REAL */ +/* > If INFO = 0, COLCND contains the ratio of the smallest */ +/* > C(i) to the largest C(i). If COLCND >= 0.1, it is not */ +/* > worth scaling by C. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] AMAX */ +/* > \verbatim */ +/* > AMAX is REAL */ +/* > Absolute value of largest matrix element. If AMAX is very */ +/* > close to overflow or very close to underflow, the matrix */ +/* > should be scaled. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, and i is */ +/* > <= M: the i-th row of A is exactly zero */ +/* > > M: the (i-M)-th column of A is exactly zero */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup realGBcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int sgbequb_(integer *m, integer *n, integer *kl, integer * + ku, real *ab, integer *ldab, real *r__, real *c__, real *rowcnd, real + *colcnd, real *amax, 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 i__, j; + real radix, rcmin, rcmax; + integer kd; + extern real slamch_(char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real bignum, logrdx, smlnum; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --r__; + --c__; + + /* Function Body */ + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0) { + *info = -3; + } else if (*ku < 0) { + *info = -4; + } else if (*ldab < *kl + *ku + 1) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SGBEQUB", &i__1, (ftnlen)7); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0) { + *rowcnd = 1.f; + *colcnd = 1.f; + *amax = 0.f; + return 0; + } + +/* Get machine constants. Assume SMLNUM is a power of the radix. */ + + smlnum = slamch_("S"); + bignum = 1.f / smlnum; + radix = slamch_("B"); + logrdx = log(radix); + +/* Compute row scale factors. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + r__[i__] = 0.f; +/* L10: */ + } + +/* Find the maximum element in each row. */ + + kd = *ku + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = j - *ku; +/* Computing MIN */ + i__4 = j + *kl; + i__3 = f2cmin(i__4,*m); + for (i__ = f2cmax(i__2,1); i__ <= i__3; ++i__) { +/* Computing MAX */ + r__2 = r__[i__], r__3 = (r__1 = ab[kd + i__ - j + j * ab_dim1], + abs(r__1)); + r__[i__] = f2cmax(r__2,r__3); +/* L20: */ + } +/* L30: */ + } + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (r__[i__] > 0.f) { + i__3 = (integer) (log(r__[i__]) / logrdx); + r__[i__] = pow_ri(&radix, &i__3); + } + } + +/* Find the maximum and minimum scale factors. */ + + rcmin = bignum; + rcmax = 0.f; + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + r__1 = rcmax, r__2 = r__[i__]; + rcmax = f2cmax(r__1,r__2); +/* Computing MIN */ + r__1 = rcmin, r__2 = r__[i__]; + rcmin = f2cmin(r__1,r__2); +/* L40: */ + } + *amax = rcmax; + + if (rcmin == 0.f) { + +/* Find the first zero scale factor and return an error code. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { + if (r__[i__] == 0.f) { + *info = i__; + return 0; + } +/* L50: */ + } + } else { + +/* Invert the scale factors. */ + + i__1 = *m; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MIN */ +/* Computing MAX */ + r__2 = r__[i__]; + r__1 = f2cmax(r__2,smlnum); + r__[i__] = 1.f / f2cmin(r__1,bignum); +/* L60: */ + } + +/* Compute ROWCND = f2cmin(R(I)) / f2cmax(R(I)). */ + + *rowcnd = f2cmax(rcmin,smlnum) / f2cmin(rcmax,bignum); + } + +/* Compute column scale factors. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + c__[j] = 0.f; +/* L70: */ + } + +/* Find the maximum element in each column, */ +/* assuming the row scaling computed above. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__3 = j - *ku; +/* Computing MIN */ + i__4 = j + *kl; + i__2 = f2cmin(i__4,*m); + for (i__ = f2cmax(i__3,1); i__ <= i__2; ++i__) { +/* Computing MAX */ + r__2 = c__[j], r__3 = (r__1 = ab[kd + i__ - j + j * ab_dim1], abs( + r__1)) * r__[i__]; + c__[j] = f2cmax(r__2,r__3); +/* L80: */ + } + if (c__[j] > 0.f) { + i__2 = (integer) (log(c__[j]) / logrdx); + c__[j] = pow_ri(&radix, &i__2); + } +/* L90: */ + } + +/* Find the maximum and minimum scale factors. */ + + rcmin = bignum; + rcmax = 0.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + r__1 = rcmin, r__2 = c__[j]; + rcmin = f2cmin(r__1,r__2); +/* Computing MAX */ + r__1 = rcmax, r__2 = c__[j]; + rcmax = f2cmax(r__1,r__2); +/* L100: */ + } + + if (rcmin == 0.f) { + +/* Find the first zero scale factor and return an error code. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (c__[j] == 0.f) { + *info = *m + j; + return 0; + } +/* L110: */ + } + } else { + +/* Invert the scale factors. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ +/* Computing MAX */ + r__2 = c__[j]; + r__1 = f2cmax(r__2,smlnum); + c__[j] = 1.f / f2cmin(r__1,bignum); +/* L120: */ + } + +/* Compute COLCND = f2cmin(C(J)) / f2cmax(C(J)). */ + + *colcnd = f2cmax(rcmin,smlnum) / f2cmin(rcmax,bignum); + } + + return 0; + +/* End of SGBEQUB */ + +} /* sgbequb_ */ + diff --git a/lapack-netlib/SRC/sgbrfs.c b/lapack-netlib/SRC/sgbrfs.c new file mode 100644 index 000000000..308ce8762 --- /dev/null +++ b/lapack-netlib/SRC/sgbrfs.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 SGBRFS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SGBRFS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, */ +/* IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, */ +/* INFO ) */ + +/* CHARACTER TRANS */ +/* INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS */ +/* INTEGER IPIV( * ), IWORK( * ) */ +/* REAL AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), */ +/* $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SGBRFS improves the computed solution to a system of linear */ +/* > equations when the coefficient matrix is banded, and provides */ +/* > error bounds and backward error estimates for the solution. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of subdiagonals within the band of A. KL >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of superdiagonals within the band of A. KU >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is REAL array, dimension (LDAB,N) */ +/* > The original band matrix A, stored in rows 1 to KL+KU+1. */ +/* > The j-th column of A is stored in the j-th column of the */ +/* > array AB as follows: */ +/* > AB(ku+1+i-j,j) = A(i,j) for f2cmax(1,j-ku)<=i<=f2cmin(n,j+kl). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AFB */ +/* > \verbatim */ +/* > AFB is REAL array, dimension (LDAFB,N) */ +/* > Details of the LU factorization of the band matrix A, as */ +/* > computed by SGBTRF. U is stored as an upper triangular band */ +/* > matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */ +/* > the multipliers used during the factorization are stored in */ +/* > rows KL+KU+2 to 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAFB */ +/* > \verbatim */ +/* > LDAFB is INTEGER */ +/* > The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices from SGBTRF; for 1<=i<=N, row i of the */ +/* > matrix was interchanged with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,NRHS) */ +/* > The right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (LDX,NRHS) */ +/* > On entry, the solution matrix X, as computed by SGBTRS. */ +/* > On exit, the improved solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is REAL array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is REAL array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (3*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > ITMAX is the maximum number of steps of iterative refinement. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realGBcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int sgbrfs_(char *trans, integer *n, integer *kl, integer * + ku, integer *nrhs, real *ab, integer *ldab, real *afb, integer *ldafb, + integer *ipiv, real *b, integer *ldb, real *x, integer *ldx, real * + ferr, real *berr, real *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, + x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5, i__6, i__7; + real r__1, r__2, r__3; + + /* Local variables */ + integer kase; + real safe1, safe2; + integer i__, j, k; + real s; + extern logical lsame_(char *, char *); + integer isave[3]; + extern /* Subroutine */ int sgbmv_(char *, integer *, integer *, integer * + , integer *, real *, real *, integer *, real *, integer *, real *, + real *, integer *); + integer count; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *), saxpy_(integer *, real *, real *, integer *, real *, + integer *), slacn2_(integer *, real *, real *, integer *, real *, + integer *, integer *); + integer kk; + real xk; + extern real slamch_(char *); + integer nz; + real safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical notran; + extern /* Subroutine */ int sgbtrs_(char *, integer *, integer *, integer + *, integer *, real *, integer *, integer *, real *, integer *, + integer *); + char transt[1]; + real lstres, eps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + afb_dim1 = *ldafb; + afb_offset = 1 + afb_dim1 * 1; + afb -= afb_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + notran = lsame_(trans, "N"); + if (! notran && ! lsame_(trans, "T") && ! lsame_( + trans, "C")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0) { + *info = -3; + } else if (*ku < 0) { + *info = -4; + } else if (*nrhs < 0) { + *info = -5; + } else if (*ldab < *kl + *ku + 1) { + *info = -7; + } else if (*ldafb < (*kl << 1) + *ku + 1) { + *info = -9; + } else if (*ldb < f2cmax(1,*n)) { + *info = -12; + } else if (*ldx < f2cmax(1,*n)) { + *info = -14; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SGBRFS", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] = 0.f; + berr[j] = 0.f; +/* L10: */ + } + return 0; + } + + if (notran) { + *(unsigned char *)transt = 'T'; + } else { + *(unsigned char *)transt = 'N'; + } + +/* NZ = maximum number of nonzero elements in each row of A, plus 1 */ + +/* Computing MIN */ + i__1 = *kl + *ku + 2, i__2 = *n + 1; + nz = f2cmin(i__1,i__2); + eps = slamch_("Epsilon"); + safmin = slamch_("Safe minimum"); + safe1 = nz * safmin; + safe2 = safe1 / eps; + +/* Do for each right hand side */ + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + + count = 1; + lstres = 3.f; +L20: + +/* Loop until stopping criterion is satisfied. */ + +/* Compute residual R = B - op(A) * X, */ +/* where op(A) = A, A**T, or A**H, depending on TRANS. */ + + scopy_(n, &b[j * b_dim1 + 1], &c__1, &work[*n + 1], &c__1); + sgbmv_(trans, n, n, kl, ku, &c_b15, &ab[ab_offset], ldab, &x[j * + x_dim1 + 1], &c__1, &c_b17, &work[*n + 1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* f2cmax(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[i__] = (r__1 = b[i__ + j * b_dim1], abs(r__1)); +/* L30: */ + } + +/* Compute abs(op(A))*abs(X) + abs(B). */ + + if (notran) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + kk = *ku + 1 - k; + xk = (r__1 = x[k + j * x_dim1], abs(r__1)); +/* Computing MAX */ + i__3 = 1, i__4 = k - *ku; +/* Computing MIN */ + i__6 = *n, i__7 = k + *kl; + i__5 = f2cmin(i__6,i__7); + for (i__ = f2cmax(i__3,i__4); i__ <= i__5; ++i__) { + work[i__] += (r__1 = ab[kk + i__ + k * ab_dim1], abs(r__1) + ) * xk; +/* L40: */ + } +/* L50: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.f; + kk = *ku + 1 - k; +/* Computing MAX */ + i__5 = 1, i__3 = k - *ku; +/* Computing MIN */ + i__6 = *n, i__7 = k + *kl; + i__4 = f2cmin(i__6,i__7); + for (i__ = f2cmax(i__5,i__3); i__ <= i__4; ++i__) { + s += (r__1 = ab[kk + i__ + k * ab_dim1], abs(r__1)) * ( + r__2 = x[i__ + j * x_dim1], abs(r__2)); +/* L60: */ + } + work[k] += s; +/* L70: */ + } + } + s = 0.f; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { +/* Computing MAX */ + r__2 = s, r__3 = (r__1 = work[*n + i__], abs(r__1)) / work[ + i__]; + s = f2cmax(r__2,r__3); + } else { +/* Computing MAX */ + r__2 = s, r__3 = ((r__1 = work[*n + i__], abs(r__1)) + safe1) + / (work[i__] + safe1); + s = f2cmax(r__2,r__3); + } +/* L80: */ + } + berr[j] = s; + +/* Test stopping criterion. Continue iterating if */ +/* 1) The residual BERR(J) is larger than machine epsilon, and */ +/* 2) BERR(J) decreased by at least a factor of 2 during the */ +/* last iteration, and */ +/* 3) At most ITMAX iterations tried. */ + + if (berr[j] > eps && berr[j] * 2.f <= lstres && count <= 5) { + +/* Update solution and try again. */ + + sgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1] + , &work[*n + 1], n, info); + saxpy_(n, &c_b17, &work[*n + 1], &c__1, &x[j * x_dim1 + 1], &c__1) + ; + lstres = berr[j]; + ++count; + goto L20; + } + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(op(A)))* */ +/* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(op(A)) is the inverse of op(A) */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(op(A))*abs(X) + abs(B) is less than SAFE2. */ + +/* Use SLACN2 to estimate the infinity-norm of the matrix */ +/* inv(op(A)) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (work[i__] > safe2) { + work[i__] = (r__1 = work[*n + i__], abs(r__1)) + nz * eps * + work[i__]; + } else { + work[i__] = (r__1 = work[*n + i__], abs(r__1)) + nz * eps * + work[i__] + safe1; + } +/* L90: */ + } + + kase = 0; +L100: + slacn2_(n, &work[(*n << 1) + 1], &work[*n + 1], &iwork[1], &ferr[j], & + kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(op(A)**T). */ + + sgbtrs_(transt, n, kl, ku, &c__1, &afb[afb_offset], ldafb, & + ipiv[1], &work[*n + 1], n, info); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] *= work[i__]; +/* L110: */ + } + } else { + +/* Multiply by inv(op(A))*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + work[*n + i__] *= work[i__]; +/* L120: */ + } + sgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, & + ipiv[1], &work[*n + 1], n, info); + } + goto L100; + } + +/* Normalize error. */ + + lstres = 0.f; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + r__2 = lstres, r__3 = (r__1 = x[i__ + j * x_dim1], abs(r__1)); + lstres = f2cmax(r__2,r__3); +/* L130: */ + } + if (lstres != 0.f) { + ferr[j] /= lstres; + } + +/* L140: */ + } + + return 0; + +/* End of SGBRFS */ + +} /* sgbrfs_ */ + diff --git a/lapack-netlib/SRC/sgbrfsx.c b/lapack-netlib/SRC/sgbrfsx.c new file mode 100644 index 000000000..238623374 --- /dev/null +++ b/lapack-netlib/SRC/sgbrfsx.c @@ -0,0 +1,1178 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SGBRFSX */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SGBRFSX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SGBRFSX( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB, */ +/* LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND, */ +/* BERR, N_ERR_BNDS, ERR_BNDS_NORM, */ +/* ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, */ +/* INFO ) */ + +/* CHARACTER TRANS, EQUED */ +/* INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, KL, KU, NRHS, */ +/* $ NPARAMS, N_ERR_BNDS */ +/* REAL RCOND */ +/* INTEGER IPIV( * ), IWORK( * ) */ +/* REAL AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), */ +/* $ X( LDX , * ),WORK( * ) */ +/* REAL R( * ), C( * ), PARAMS( * ), BERR( * ), */ +/* $ ERR_BNDS_NORM( NRHS, * ), */ +/* $ ERR_BNDS_COMP( NRHS, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SGBRFSX improves the computed solution to a system of linear */ +/* > equations and provides error bounds and backward error estimates */ +/* > for the solution. In addition to normwise error bound, the code */ +/* > provides maximum componentwise error bound if possible. See */ +/* > comments for ERR_BNDS_NORM and ERR_BNDS_COMP for details of the */ +/* > error bounds. */ +/* > */ +/* > The original system of linear equations may have been equilibrated */ +/* > before calling this routine, as described by arguments EQUED, R */ +/* > and C below. In this case, the solution and error bounds returned */ +/* > are for the original unequilibrated system. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \verbatim */ +/* > Some optional parameters are bundled in the PARAMS array. These */ +/* > settings determine how refinement is performed, but often the */ +/* > defaults are acceptable. If the defaults are acceptable, users */ +/* > can pass NPARAMS = 0 which prevents the source code from accessing */ +/* > the PARAMS argument. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies the form of equilibration that was done to A */ +/* > before calling this routine. This is needed to compute */ +/* > the solution and error bounds correctly. */ +/* > = '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). */ +/* > The right hand side B has been changed accordingly. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of subdiagonals within the band of A. KL >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of superdiagonals within the band of A. KU >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is REAL array, dimension (LDAB,N) */ +/* > The original band matrix A, stored in rows 1 to KL+KU+1. */ +/* > The j-th column of A is stored in the j-th column of the */ +/* > array AB as follows: */ +/* > AB(ku+1+i-j,j) = A(i,j) for f2cmax(1,j-ku)<=i<=f2cmin(n,j+kl). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AFB */ +/* > \verbatim */ +/* > AFB is REAL array, dimension (LDAFB,N) */ +/* > Details of the LU factorization of the band matrix A, as */ +/* > computed by DGBTRF. U is stored as an upper triangular band */ +/* > matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and */ +/* > the multipliers used during the factorization are stored in */ +/* > rows KL+KU+2 to 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAFB */ +/* > \verbatim */ +/* > LDAFB is INTEGER */ +/* > The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices from SGETRF; for 1<=i<=N, row i of the */ +/* > matrix was interchanged with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] R */ +/* > \verbatim */ +/* > R is REAL array, dimension (N) */ +/* > The row scale factors for A. If EQUED = 'R' or 'B', A is */ +/* > multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */ +/* > is not accessed. R is an input argument if FACT = 'F'; */ +/* > otherwise, R is an output argument. If FACT = 'F' and */ +/* > EQUED = 'R' or 'B', each element of R must be positive. */ +/* > If R is output, each element of R is a power of the radix. */ +/* > If R is input, each element of R should be a power of the radix */ +/* > to ensure a reliable solution and error estimates. Scaling by */ +/* > powers of the radix does not cause rounding errors unless the */ +/* > result underflows or overflows. Rounding errors during scaling */ +/* > lead to refining with a matrix that is not equivalent to the */ +/* > input matrix, producing error estimates that may not be */ +/* > reliable. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (N) */ +/* > The column scale factors for A. If EQUED = 'C' or 'B', A is */ +/* > multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */ +/* > is not accessed. C is an input argument if FACT = 'F'; */ +/* > otherwise, C is an output argument. If FACT = 'F' and */ +/* > EQUED = 'C' or 'B', each element of C must be positive. */ +/* > If C is output, each element of C is a power of the radix. */ +/* > If C is input, each element of C should be a power of the radix */ +/* > to ensure a reliable solution and error estimates. Scaling by */ +/* > powers of the radix does not cause rounding errors unless the */ +/* > result underflows or overflows. Rounding errors during scaling */ +/* > lead to refining with a matrix that is not equivalent to the */ +/* > input matrix, producing error estimates that may not be */ +/* > reliable. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,NRHS) */ +/* > The right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (LDX,NRHS) */ +/* > On entry, the solution matrix X, as computed by SGETRS. */ +/* > On exit, the improved solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > Reciprocal scaled condition number. This is an estimate of the */ +/* > reciprocal Skeel condition number of the matrix A after */ +/* > equilibration (if done). If this is less than the machine */ +/* > precision (in particular, if it is zero), the matrix is singular */ +/* > to working precision. Note that the error may still be small even */ +/* > if this number is very small and the matrix appears ill- */ +/* > conditioned. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is REAL array, dimension (NRHS) */ +/* > Componentwise relative backward error. This is the */ +/* > componentwise relative backward error of each solution vector X(j) */ +/* > (i.e., the smallest relative change in any element of A or B that */ +/* > makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N_ERR_BNDS */ +/* > \verbatim */ +/* > N_ERR_BNDS is INTEGER */ +/* > Number of error bounds to return for each right hand side */ +/* > and each type (normwise or componentwise). See ERR_BNDS_NORM and */ +/* > ERR_BNDS_COMP below. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ERR_BNDS_NORM */ +/* > \verbatim */ +/* > ERR_BNDS_NORM is REAL array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > normwise relative error, which is defined as follows: */ +/* > */ +/* > Normwise relative error in the ith solution vector: */ +/* > max_j (abs(XTRUE(j,i) - X(j,i))) */ +/* > ------------------------------ */ +/* > max_j abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the type of error information as described */ +/* > below. There currently are up to three pieces of information */ +/* > returned. */ +/* > */ +/* > The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_NORM(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated normwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * slamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*A, where S scales each row by a power of the */ +/* > radix so all absolute row sums of Z are approximately 1. */ +/* > */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ERR_BNDS_COMP */ +/* > \verbatim */ +/* > ERR_BNDS_COMP is REAL array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > componentwise relative error, which is defined as follows: */ +/* > */ +/* > Componentwise relative error in the ith solution vector: */ +/* > abs(XTRUE(j,i) - X(j,i)) */ +/* > max_j ---------------------- */ +/* > abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the right-hand side i (on which the */ +/* > componentwise relative error depends), and the type of error */ +/* > information as described below. There currently are up to three */ +/* > pieces of information returned for each right-hand side. If */ +/* > componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ +/* > ERR_BNDS_COMP is not accessed. If N_ERR_BNDS < 3, then at most */ +/* > the first (:,N_ERR_BNDS) entries are returned. */ +/* > */ +/* > The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_COMP(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated componentwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * slamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*(A*diag(x)), where x is the solution for the */ +/* > current right-hand side and S scales each row of */ +/* > A*diag(x) by a power of the radix so all absolute row */ +/* > sums of Z are approximately 1. */ +/* > */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NPARAMS */ +/* > \verbatim */ +/* > NPARAMS is INTEGER */ +/* > Specifies the number of parameters set in PARAMS. If <= 0, the */ +/* > PARAMS array is never referenced and default values are used. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] PARAMS */ +/* > \verbatim */ +/* > PARAMS is REAL array, dimension NPARAMS */ +/* > Specifies algorithm parameters. If an entry is < 0.0, then */ +/* > that entry will be filled with default value used for that */ +/* > parameter. Only positions up to NPARAMS are accessed; defaults */ +/* > are used for higher-numbered parameters. */ +/* > */ +/* > PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */ +/* > refinement or not. */ +/* > Default: 1.0 */ +/* > = 0.0: No refinement is performed, and no error bounds are */ +/* > computed. */ +/* > = 1.0: Use the double-precision refinement algorithm, */ +/* > possibly with doubled-single computations if the */ +/* > compilation environment does not support DOUBLE */ +/* > PRECISION. */ +/* > (other values are reserved for future use) */ +/* > */ +/* > PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */ +/* > computations allowed for refinement. */ +/* > Default: 10 */ +/* > Aggressive: Set to 100 to permit convergence using approximate */ +/* > factorizations or factorizations other than LU. If */ +/* > the factorization uses a technique other than */ +/* > Gaussian elimination, the guarantees in */ +/* > err_bnds_norm and err_bnds_comp may no longer be */ +/* > trustworthy. */ +/* > */ +/* > PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */ +/* > will attempt to find a solution with small componentwise */ +/* > relative error in the double-precision algorithm. Positive */ +/* > is true, 0.0 is false. */ +/* > Default: 1.0 (attempt componentwise convergence) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (4*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. The solution to every right-hand side is */ +/* > guaranteed. */ +/* > < 0: If INFO = -i, the i-th argument had an illegal value */ +/* > > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */ +/* > has been completed, but the factor U is exactly singular, so */ +/* > the solution and error bounds could not be computed. RCOND = 0 */ +/* > is returned. */ +/* > = N+J: The solution corresponding to the Jth right-hand side is */ +/* > not guaranteed. The solutions corresponding to other right- */ +/* > hand sides K with K > J may not be guaranteed as well, but */ +/* > only the first such right-hand side is reported. If a small */ +/* > componentwise error is not requested (PARAMS(3) = 0.0) then */ +/* > the Jth right-hand side is the first with a normwise error */ +/* > bound that is not guaranteed (the smallest J such */ +/* > that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */ +/* > the Jth right-hand side is the first with either a normwise or */ +/* > componentwise error bound that is not guaranteed (the smallest */ +/* > J such that either ERR_BNDS_NORM(J,1) = 0.0 or */ +/* > ERR_BNDS_COMP(J,1) = 0.0). See the definition of */ +/* > ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */ +/* > about all of the right-hand sides check ERR_BNDS_NORM or */ +/* > ERR_BNDS_COMP. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup realGBcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int sgbrfsx_(char *trans, char *equed, integer *n, integer * + kl, integer *ku, integer *nrhs, real *ab, integer *ldab, real *afb, + integer *ldafb, integer *ipiv, real *r__, real *c__, real *b, integer + *ldb, real *x, integer *ldx, real *rcond, real *berr, integer * + n_err_bnds__, real *err_bnds_norm__, real *err_bnds_comp__, integer * + nparams, real *params, real *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, + x_dim1, x_offset, err_bnds_norm_dim1, err_bnds_norm_offset, + err_bnds_comp_dim1, err_bnds_comp_offset, i__1; + real r__1, r__2; + + /* Local variables */ + real illrcond_thresh__; + extern /* Subroutine */ int sla_gbrfsx_extended_(integer *, integer *, + integer *, integer *, integer *, integer *, real *, integer *, + real *, integer *, integer *, logical *, real *, real *, integer * + , real *, integer *, real *, integer *, real *, real *, real *, + real *, real *, real *, real *, integer *, real *, real *, + logical *, integer *); + real unstable_thresh__, err_lbnd__; + char norm[1]; + integer ref_type__; + extern integer ilatrans_(char *); + logical ignore_cwise__; + integer j; + extern logical lsame_(char *, char *); + real anorm, rcond_tmp__; + integer prec_type__; + extern real slangb_(char *, integer *, integer *, integer *, real *, + integer *, real *), slamch_(char *); + extern /* Subroutine */ int sgbcon_(char *, integer *, integer *, integer + *, real *, integer *, integer *, real *, real *, real *, integer * + , integer *), xerbla_(char *, integer *, ftnlen); + logical colequ, notran, rowequ; + integer trans_type__; + extern integer ilaprec_(char *); + extern real sla_gbrcond_(char *, integer *, integer *, integer *, real *, + integer *, real *, integer *, integer *, integer *, real *, + integer *, real *, integer *); + integer ithresh, n_norms__; + real rthresh, cwise_wrong__; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ================================================================== */ + + +/* Check the input parameters. */ + + /* Parameter adjustments */ + err_bnds_comp_dim1 = *nrhs; + err_bnds_comp_offset = 1 + err_bnds_comp_dim1 * 1; + err_bnds_comp__ -= err_bnds_comp_offset; + err_bnds_norm_dim1 = *nrhs; + err_bnds_norm_offset = 1 + err_bnds_norm_dim1 * 1; + err_bnds_norm__ -= err_bnds_norm_offset; + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + afb_dim1 = *ldafb; + afb_offset = 1 + afb_dim1 * 1; + afb -= afb_offset; + --ipiv; + --r__; + --c__; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --berr; + --params; + --work; + --iwork; + + /* Function Body */ + *info = 0; + trans_type__ = ilatrans_(trans); + ref_type__ = 1; + if (*nparams >= 1) { + if (params[1] < 0.f) { + params[1] = 1.f; + } else { + ref_type__ = params[1]; + } + } + +/* Set default parameters. */ + + illrcond_thresh__ = (real) (*n) * slamch_("Epsilon"); + ithresh = 10; + rthresh = .5f; + unstable_thresh__ = .25f; + ignore_cwise__ = FALSE_; + + if (*nparams >= 2) { + if (params[2] < 0.f) { + params[2] = (real) ithresh; + } else { + ithresh = (integer) params[2]; + } + } + if (*nparams >= 3) { + if (params[3] < 0.f) { + if (ignore_cwise__) { + params[3] = 0.f; + } else { + params[3] = 1.f; + } + } else { + ignore_cwise__ = params[3] == 0.f; + } + } + if (ref_type__ == 0 || *n_err_bnds__ == 0) { + n_norms__ = 0; + } else if (ignore_cwise__) { + n_norms__ = 1; + } else { + n_norms__ = 2; + } + + notran = lsame_(trans, "N"); + rowequ = lsame_(equed, "R") || lsame_(equed, "B"); + colequ = lsame_(equed, "C") || lsame_(equed, "B"); + +/* Test input parameters. */ + + if (trans_type__ == -1) { + *info = -1; + } else if (! rowequ && ! colequ && ! lsame_(equed, "N")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*kl < 0) { + *info = -4; + } else if (*ku < 0) { + *info = -5; + } else if (*nrhs < 0) { + *info = -6; + } else if (*ldab < *kl + *ku + 1) { + *info = -8; + } else if (*ldafb < (*kl << 1) + *ku + 1) { + *info = -10; + } else if (*ldb < f2cmax(1,*n)) { + *info = -13; + } else if (*ldx < f2cmax(1,*n)) { + *info = -15; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SGBRFSX", &i__1, (ftnlen)7); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *nrhs == 0) { + *rcond = 1.f; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + berr[j] = 0.f; + if (*n_err_bnds__ >= 1) { + err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f; + err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f; + } + if (*n_err_bnds__ >= 2) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 0.f; + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 0.f; + } + if (*n_err_bnds__ >= 3) { + err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 1.f; + err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 1.f; + } + } + return 0; + } + +/* Default to failure. */ + + *rcond = 0.f; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + berr[j] = 1.f; + if (*n_err_bnds__ >= 1) { + err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f; + err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f; + } + if (*n_err_bnds__ >= 2) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f; + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f; + } + if (*n_err_bnds__ >= 3) { + err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = 0.f; + err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = 0.f; + } + } + +/* Compute the norm of A and the reciprocal of the condition */ +/* number of A. */ + + if (notran) { + *(unsigned char *)norm = 'I'; + } else { + *(unsigned char *)norm = '1'; + } + anorm = slangb_(norm, n, kl, ku, &ab[ab_offset], ldab, &work[1]); + sgbcon_(norm, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], &anorm, rcond, + &work[1], &iwork[1], info); + +/* Perform refinement on each right-hand side */ + + if (ref_type__ != 0 && *info == 0) { + prec_type__ = ilaprec_("D"); + if (notran) { + sla_gbrfsx_extended_(&prec_type__, &trans_type__, n, kl, ku, + nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, & + ipiv[1], &colequ, &c__[1], &b[b_offset], ldb, &x[x_offset] + , ldx, &berr[1], &n_norms__, &err_bnds_norm__[ + err_bnds_norm_offset], &err_bnds_comp__[ + err_bnds_comp_offset], &work[*n + 1], &work[1], &work[(*n + << 1) + 1], &work[1], rcond, &ithresh, &rthresh, & + unstable_thresh__, &ignore_cwise__, info); + } else { + sla_gbrfsx_extended_(&prec_type__, &trans_type__, n, kl, ku, + nrhs, &ab[ab_offset], ldab, &afb[afb_offset], ldafb, & + ipiv[1], &rowequ, &r__[1], &b[b_offset], ldb, &x[x_offset] + , ldx, &berr[1], &n_norms__, &err_bnds_norm__[ + err_bnds_norm_offset], &err_bnds_comp__[ + err_bnds_comp_offset], &work[*n + 1], &work[1], &work[(*n + << 1) + 1], &work[1], rcond, &ithresh, &rthresh, & + unstable_thresh__, &ignore_cwise__, info); + } + } +/* Computing MAX */ + r__1 = 10.f, r__2 = sqrt((real) (*n)); + err_lbnd__ = f2cmax(r__1,r__2) * slamch_("Epsilon"); + if (*n_err_bnds__ >= 1 && n_norms__ >= 1) { + +/* Compute scaled normwise condition number cond(A*C). */ + + if (colequ && notran) { + rcond_tmp__ = sla_gbrcond_(trans, n, kl, ku, &ab[ab_offset], + ldab, &afb[afb_offset], ldafb, &ipiv[1], &c_n1, &c__[1], + info, &work[1], &iwork[1]); + } else if (rowequ && ! notran) { + rcond_tmp__ = sla_gbrcond_(trans, n, kl, ku, &ab[ab_offset], + ldab, &afb[afb_offset], ldafb, &ipiv[1], &c_n1, &r__[1], + info, &work[1], &iwork[1]); + } else { + rcond_tmp__ = sla_gbrcond_(trans, n, kl, ku, &ab[ab_offset], + ldab, &afb[afb_offset], ldafb, &ipiv[1], &c__0, &r__[1], + info, &work[1], &iwork[1]); + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + +/* Cap the error at 1.0. */ + + if (*n_err_bnds__ >= 2 && err_bnds_norm__[j + (err_bnds_norm_dim1 + << 1)] > 1.f) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f; + } + +/* Threshold the error (see LAWN). */ + + if (rcond_tmp__ < illrcond_thresh__) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = 1.f; + err_bnds_norm__[j + err_bnds_norm_dim1] = 0.f; + if (*info <= *n) { + *info = *n + j; + } + } else if (err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] < + err_lbnd__) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = err_lbnd__; + err_bnds_norm__[j + err_bnds_norm_dim1] = 1.f; + } + +/* Save the condition number. */ + + if (*n_err_bnds__ >= 3) { + err_bnds_norm__[j + err_bnds_norm_dim1 * 3] = rcond_tmp__; + } + } + } + if (*n_err_bnds__ >= 1 && n_norms__ >= 2) { + +/* Compute componentwise condition number cond(A*diag(Y(:,J))) for */ +/* each right-hand side using the current solution as an estimate of */ +/* the true solution. If the componentwise error estimate is too */ +/* large, then the solution is a lousy estimate of truth and the */ +/* estimated RCOND may be too optimistic. To avoid misleading users, */ +/* the inverse condition number is set to 0.0 when the estimated */ +/* cwise error is at least CWISE_WRONG. */ + + cwise_wrong__ = sqrt(slamch_("Epsilon")); + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] < + cwise_wrong__) { + rcond_tmp__ = sla_gbrcond_(trans, n, kl, ku, &ab[ab_offset], + ldab, &afb[afb_offset], ldafb, &ipiv[1], &c__1, &x[j * + x_dim1 + 1], info, &work[1], &iwork[1]); + } else { + rcond_tmp__ = 0.f; + } + +/* Cap the error at 1.0. */ + + if (*n_err_bnds__ >= 2 && err_bnds_comp__[j + (err_bnds_comp_dim1 + << 1)] > 1.f) { + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f; + } + +/* Threshold the error (see LAWN). */ + + if (rcond_tmp__ < illrcond_thresh__) { + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = 1.f; + err_bnds_comp__[j + err_bnds_comp_dim1] = 0.f; + if (params[3] == 1.f && *info < *n + j) { + *info = *n + j; + } + } else if (err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] < + err_lbnd__) { + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = err_lbnd__; + err_bnds_comp__[j + err_bnds_comp_dim1] = 1.f; + } + +/* Save the condition number. */ + + if (*n_err_bnds__ >= 3) { + err_bnds_comp__[j + err_bnds_comp_dim1 * 3] = rcond_tmp__; + } + } + } + + return 0; + +/* End of SGBRFSX */ + +} /* sgbrfsx_ */ + diff --git a/lapack-netlib/SRC/sgbsv.c b/lapack-netlib/SRC/sgbsv.c new file mode 100644 index 000000000..3eade6ff8 --- /dev/null +++ b/lapack-netlib/SRC/sgbsv.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 SGBSV computes the solution to system of linear equations A * X = B for GB matrices (simpl +e driver) */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SGBSV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO ) */ + +/* INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* REAL AB( LDAB, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SGBSV computes the solution to a real system of linear equations */ +/* > A * X = B, where A is a band matrix of order N with KL subdiagonals */ +/* > and KU superdiagonals, and X and B are N-by-NRHS matrices. */ +/* > */ +/* > The LU decomposition with partial pivoting and row interchanges is */ +/* > used to factor A as A = L * U, where L is a product of permutation */ +/* > and unit lower triangular matrices with KL subdiagonals, and U is */ +/* > upper triangular with KL+KU superdiagonals. The factored form of A */ +/* > is then used to solve the system of equations A * X = B. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of subdiagonals within the band of A. KL >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of superdiagonals within the band of A. KU >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is REAL array, dimension (LDAB,N) */ +/* > On entry, the matrix A in band storage, in rows KL+1 to */ +/* > 2*KL+KU+1; rows 1 to KL of the array need not be set. */ +/* > The j-th column of A is stored in the j-th column of the */ +/* > array AB as follows: */ +/* > AB(KL+KU+1+i-j,j) = A(i,j) for f2cmax(1,j-KU)<=i<=f2cmin(N,j+KL) */ +/* > On exit, details of the factorization: U is stored as an */ +/* > upper triangular band matrix with KL+KU superdiagonals in */ +/* > rows 1 to KL+KU+1, and the multipliers used during the */ +/* > factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */ +/* > See below for further details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices that define the permutation matrix P; */ +/* > row i of the matrix was interchanged with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,NRHS) */ +/* > On entry, the N-by-NRHS right hand side matrix B. */ +/* > On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, U(i,i) is exactly zero. The factorization */ +/* > has been completed, but the factor U is exactly */ +/* > singular, and the solution has not been computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realGBsolve */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The band storage scheme is illustrated by the following example, when */ +/* > M = N = 6, KL = 2, KU = 1: */ +/* > */ +/* > On entry: On exit: */ +/* > */ +/* > * * * + + + * * * u14 u25 u36 */ +/* > * * + + + + * * u13 u24 u35 u46 */ +/* > * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */ +/* > a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */ +/* > a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */ +/* > a31 a42 a53 a64 * * m31 m42 m53 m64 * * */ +/* > */ +/* > Array elements marked * are not used by the routine; elements marked */ +/* > + need not be set on entry, but are required by the routine to store */ +/* > elements of U because of fill-in resulting from the row interchanges. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int sgbsv_(integer *n, integer *kl, integer *ku, integer * + nrhs, real *ab, integer *ldab, integer *ipiv, real *b, integer *ldb, + integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), sgbtrf_( + integer *, integer *, integer *, integer *, real *, integer *, + integer *, integer *), sgbtrs_(char *, integer *, integer *, + integer *, integer *, real *, integer *, integer *, real *, + integer *, integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } else if (*kl < 0) { + *info = -2; + } else if (*ku < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*ldab < (*kl << 1) + *ku + 1) { + *info = -6; + } else if (*ldb < f2cmax(*n,1)) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SGBSV ", &i__1, (ftnlen)5); + return 0; + } + +/* Compute the LU factorization of the band matrix A. */ + + sgbtrf_(n, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + sgbtrs_("No transpose", n, kl, ku, nrhs, &ab[ab_offset], ldab, &ipiv[ + 1], &b[b_offset], ldb, info); + } + return 0; + +/* End of SGBSV */ + +} /* sgbsv_ */ + diff --git a/lapack-netlib/SRC/sgbsvx.c b/lapack-netlib/SRC/sgbsvx.c new file mode 100644 index 000000000..788d76cad --- /dev/null +++ b/lapack-netlib/SRC/sgbsvx.c @@ -0,0 +1,1137 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief SGBSVX computes the solution to system of linear equations A * X = B for GB matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SGBSVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SGBSVX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, */ +/* LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, */ +/* RCOND, FERR, BERR, WORK, IWORK, INFO ) */ + +/* CHARACTER EQUED, FACT, TRANS */ +/* INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS */ +/* REAL RCOND */ +/* INTEGER IPIV( * ), IWORK( * ) */ +/* REAL AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), */ +/* $ BERR( * ), C( * ), FERR( * ), R( * ), */ +/* $ WORK( * ), X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SGBSVX uses the LU factorization to compute the solution to a real */ +/* > system of linear equations A * X = B, A**T * X = B, or A**H * X = B, */ +/* > where A is a band matrix of order N with KL subdiagonals and KU */ +/* > superdiagonals, and X and B are N-by-NRHS matrices. */ +/* > */ +/* > Error bounds on the solution and a condition estimate are also */ +/* > provided. */ +/* > \endverbatim */ + +/* > \par Description: */ +/* ================= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The following steps are performed by this subroutine: */ +/* > */ +/* > 1. If FACT = 'E', real scaling factors are computed to equilibrate */ +/* > the system: */ +/* > TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */ +/* > TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */ +/* > TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */ +/* > Whether or not the system will be equilibrated depends on the */ +/* > scaling of the matrix A, but if equilibration is used, A is */ +/* > overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */ +/* > or diag(C)*B (if TRANS = 'T' or 'C'). */ +/* > */ +/* > 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the */ +/* > matrix A (after equilibration if FACT = 'E') as */ +/* > A = L * U, */ +/* > where L is a product of permutation and unit lower triangular */ +/* > matrices with KL subdiagonals, and U is upper triangular with */ +/* > KL+KU superdiagonals. */ +/* > */ +/* > 3. If some U(i,i)=0, so that U is exactly singular, then the routine */ +/* > returns with INFO = i. Otherwise, the factored form of A is used */ +/* > to estimate the condition number of the matrix A. If the */ +/* > reciprocal of the condition number is less than machine precision, */ +/* > INFO = N+1 is returned as a warning, but the routine still goes on */ +/* > to solve for X and compute error bounds as described below. */ +/* > */ +/* > 4. The system of equations is solved for X using the factored form */ +/* > of A. */ +/* > */ +/* > 5. Iterative refinement is applied to improve the computed solution */ +/* > matrix and calculate error bounds and backward error estimates */ +/* > for it. */ +/* > */ +/* > 6. If equilibration was used, the matrix X is premultiplied by */ +/* > diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */ +/* > that it solves the original system before equilibration. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] FACT */ +/* > \verbatim */ +/* > FACT is CHARACTER*1 */ +/* > Specifies whether or not the factored form of the matrix A is */ +/* > supplied on entry, and if not, whether the matrix A should be */ +/* > equilibrated before it is factored. */ +/* > = 'F': On entry, AFB and IPIV contain the factored form of */ +/* > A. If EQUED is not 'N', the matrix A has been */ +/* > equilibrated with scaling factors given by R and C. */ +/* > AB, AFB, and IPIV are not modified. */ +/* > = 'N': The matrix A will be copied to AFB and factored. */ +/* > = 'E': The matrix A will be equilibrated if necessary, then */ +/* > copied to AFB and factored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations. */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of subdiagonals within the band of A. KL >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of superdiagonals within the band of A. KU >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is 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(N,j+kl) */ +/* > */ +/* > If FACT = 'F' and EQUED is not 'N', then A must have been */ +/* > equilibrated by the scaling factors in R and/or C. AB is not */ +/* > modified if FACT = 'F' or 'N', or if FACT = 'E' and */ +/* > EQUED = 'N' on exit. */ +/* > */ +/* > On exit, if EQUED .ne. 'N', A is scaled as follows: */ +/* > EQUED = 'R': A := diag(R) * A */ +/* > EQUED = 'C': A := A * diag(C) */ +/* > EQUED = 'B': A := diag(R) * A * diag(C). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AFB */ +/* > \verbatim */ +/* > AFB is REAL array, dimension (LDAFB,N) */ +/* > If FACT = 'F', then AFB is an input argument and on entry */ +/* > contains details of the LU factorization of the band matrix */ +/* > A, as computed by SGBTRF. U is stored as an upper triangular */ +/* > band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */ +/* > and the multipliers used during the factorization are stored */ +/* > in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is */ +/* > the factored form of the equilibrated matrix A. */ +/* > */ +/* > If FACT = 'N', then AFB is an output argument and on exit */ +/* > returns details of the LU factorization of A. */ +/* > */ +/* > If FACT = 'E', then AFB is an output argument and on exit */ +/* > returns details of the LU factorization of the equilibrated */ +/* > matrix A (see the description of AB for the form of the */ +/* > equilibrated matrix). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAFB */ +/* > \verbatim */ +/* > LDAFB is INTEGER */ +/* > The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > If FACT = 'F', then IPIV is an input argument and on entry */ +/* > contains the pivot indices from the factorization A = L*U */ +/* > as computed by SGBTRF; row i of the matrix was interchanged */ +/* > with row IPIV(i). */ +/* > */ +/* > If FACT = 'N', then IPIV is an output argument and on exit */ +/* > contains the pivot indices from the factorization A = L*U */ +/* > of the original matrix A. */ +/* > */ +/* > If FACT = 'E', then IPIV is an output argument and on exit */ +/* > contains the pivot indices from the factorization A = L*U */ +/* > of the equilibrated matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies the form of equilibration that was done. */ +/* > = 'N': No equilibration (always true if FACT = 'N'). */ +/* > = 'R': Row equilibration, i.e., A has been premultiplied by */ +/* > diag(R). */ +/* > = 'C': Column equilibration, i.e., A has been postmultiplied */ +/* > by diag(C). */ +/* > = 'B': Both row and column equilibration, i.e., A has been */ +/* > replaced by diag(R) * A * diag(C). */ +/* > EQUED is an input argument if FACT = 'F'; otherwise, it is an */ +/* > output argument. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] R */ +/* > \verbatim */ +/* > R is REAL array, dimension (N) */ +/* > The row scale factors for A. If EQUED = 'R' or 'B', A is */ +/* > multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */ +/* > is not accessed. R is an input argument if FACT = 'F'; */ +/* > otherwise, R is an output argument. If FACT = 'F' and */ +/* > EQUED = 'R' or 'B', each element of R must be positive. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (N) */ +/* > The column scale factors for A. If EQUED = 'C' or 'B', A is */ +/* > multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */ +/* > is not accessed. C is an input argument if FACT = 'F'; */ +/* > otherwise, C is an output argument. If FACT = 'F' and */ +/* > EQUED = 'C' or 'B', each element of C must be positive. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, */ +/* > if EQUED = 'N', B is not modified; */ +/* > if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */ +/* > diag(R)*B; */ +/* > if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */ +/* > overwritten by diag(C)*B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (LDX,NRHS) */ +/* > If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X */ +/* > to the original system of equations. Note that A and B are */ +/* > modified on exit if EQUED .ne. 'N', and the solution to the */ +/* > equilibrated system is inv(diag(C))*X if TRANS = 'N' and */ +/* > EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' */ +/* > and EQUED = 'R' or 'B'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > The estimate of the reciprocal condition number of the matrix */ +/* > A after equilibration (if done). If RCOND is less than the */ +/* > machine precision (in particular, if RCOND = 0), the matrix */ +/* > is singular to working precision. This condition is */ +/* > indicated by a return code of INFO > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is REAL array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is REAL array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (3*N) */ +/* > On exit, WORK(1) contains the reciprocal pivot growth */ +/* > factor norm(A)/norm(U). The "f2cmax absolute element" norm is */ +/* > used. If WORK(1) is much less than 1, then the stability */ +/* > of the LU factorization of the (equilibrated) matrix A */ +/* > could be poor. This also means that the solution X, condition */ +/* > estimator RCOND, and forward error bound FERR could be */ +/* > unreliable. If factorization fails with 0 WORK(1) contains the reciprocal pivot growth factor for the */ +/* > leading INFO columns of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, and i is */ +/* > <= N: U(i,i) is exactly zero. The factorization */ +/* > has been completed, but the factor U is exactly */ +/* > singular, so the solution and error bounds */ +/* > could not be computed. RCOND = 0 is returned. */ +/* > = N+1: U is nonsingular, but RCOND is less than machine */ +/* > precision, meaning that the matrix is singular */ +/* > to working precision. Nevertheless, the */ +/* > solution and error bounds are computed because */ +/* > there are a number of situations where the */ +/* > computed solution can be more accurate than the */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup realGBsolve */ + +/* ===================================================================== */ +/* Subroutine */ int sgbsvx_(char *fact, char *trans, integer *n, integer *kl, + integer *ku, integer *nrhs, real *ab, integer *ldab, real *afb, + integer *ldafb, integer *ipiv, char *equed, real *r__, real *c__, + real *b, integer *ldb, real *x, integer *ldx, real *rcond, real *ferr, + real *berr, real *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, + x_dim1, x_offset, i__1, i__2, i__3, i__4, i__5; + real r__1, r__2, r__3; + + /* Local variables */ + real amax; + char norm[1]; + integer i__, j; + extern logical lsame_(char *, char *); + real rcmin, rcmax, anorm; + logical equil; + integer j1, j2; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *); + real colcnd; + extern real slangb_(char *, integer *, integer *, integer *, real *, + integer *, real *), slamch_(char *); + extern /* Subroutine */ int slaqgb_(integer *, integer *, integer *, + integer *, real *, integer *, real *, real *, real *, real *, + real *, char *); + logical nofact; + extern /* Subroutine */ int sgbcon_(char *, integer *, integer *, integer + *, real *, integer *, integer *, real *, real *, real *, integer * + , integer *), xerbla_(char *, integer *, ftnlen); + real bignum; + extern real slantb_(char *, char *, char *, integer *, integer *, real *, + integer *, real *); + extern /* Subroutine */ int sgbequ_(integer *, integer *, integer *, + integer *, real *, integer *, real *, real *, real *, real *, + real *, integer *); + integer infequ; + logical colequ; + extern /* Subroutine */ int sgbrfs_(char *, integer *, integer *, integer + *, integer *, real *, integer *, real *, integer *, integer *, + real *, integer *, real *, integer *, real *, real *, real *, + integer *, integer *), sgbtrf_(integer *, integer *, + integer *, integer *, real *, integer *, integer *, integer *), + slacpy_(char *, integer *, integer *, real *, integer *, real *, + integer *); + real rowcnd; + logical notran; + extern /* Subroutine */ int sgbtrs_(char *, integer *, integer *, integer + *, integer *, real *, integer *, integer *, real *, integer *, + integer *); + real smlnum; + logical rowequ; + real rpvgrw; + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ===================================================================== */ +/* Moved setting of INFO = N+1 so INFO does not subsequently get */ +/* overwritten. Sven, 17 Mar 05. */ +/* ===================================================================== */ + + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + afb_dim1 = *ldafb; + afb_offset = 1 + afb_dim1 * 1; + afb -= afb_offset; + --ipiv; + --r__; + --c__; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --iwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + equil = lsame_(fact, "E"); + notran = lsame_(trans, "N"); + if (nofact || equil) { + *(unsigned char *)equed = 'N'; + rowequ = FALSE_; + colequ = FALSE_; + } else { + rowequ = lsame_(equed, "R") || lsame_(equed, + "B"); + colequ = lsame_(equed, "C") || lsame_(equed, + "B"); + smlnum = slamch_("Safe minimum"); + bignum = 1.f / smlnum; + } + +/* Test the input parameters. */ + + if (! nofact && ! equil && ! lsame_(fact, "F")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*kl < 0) { + *info = -4; + } else if (*ku < 0) { + *info = -5; + } else if (*nrhs < 0) { + *info = -6; + } else if (*ldab < *kl + *ku + 1) { + *info = -8; + } else if (*ldafb < (*kl << 1) + *ku + 1) { + *info = -10; + } else if (lsame_(fact, "F") && ! (rowequ || colequ + || lsame_(equed, "N"))) { + *info = -12; + } else { + if (rowequ) { + rcmin = bignum; + rcmax = 0.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + r__1 = rcmin, r__2 = r__[j]; + rcmin = f2cmin(r__1,r__2); +/* Computing MAX */ + r__1 = rcmax, r__2 = r__[j]; + rcmax = f2cmax(r__1,r__2); +/* L10: */ + } + if (rcmin <= 0.f) { + *info = -13; + } else if (*n > 0) { + rowcnd = f2cmax(rcmin,smlnum) / f2cmin(rcmax,bignum); + } else { + rowcnd = 1.f; + } + } + if (colequ && *info == 0) { + rcmin = bignum; + rcmax = 0.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + r__1 = rcmin, r__2 = c__[j]; + rcmin = f2cmin(r__1,r__2); +/* Computing MAX */ + r__1 = rcmax, r__2 = c__[j]; + rcmax = f2cmax(r__1,r__2); +/* L20: */ + } + if (rcmin <= 0.f) { + *info = -14; + } else if (*n > 0) { + colcnd = f2cmax(rcmin,smlnum) / f2cmin(rcmax,bignum); + } else { + colcnd = 1.f; + } + } + if (*info == 0) { + if (*ldb < f2cmax(1,*n)) { + *info = -16; + } else if (*ldx < f2cmax(1,*n)) { + *info = -18; + } + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("SGBSVX", &i__1, (ftnlen)6); + return 0; + } + + if (equil) { + +/* Compute row and column scalings to equilibrate the matrix A. */ + + sgbequ_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], &rowcnd, + &colcnd, &amax, &infequ); + if (infequ == 0) { + +/* Equilibrate the matrix. */ + + slaqgb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], & + rowcnd, &colcnd, &amax, equed); + rowequ = lsame_(equed, "R") || lsame_(equed, + "B"); + colequ = lsame_(equed, "C") || lsame_(equed, + "B"); + } + } + +/* Scale the right hand side. */ + + if (notran) { + if (rowequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = r__[i__] * b[i__ + j * b_dim1]; +/* L30: */ + } +/* L40: */ + } + } + } else if (colequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + b[i__ + j * b_dim1] = c__[i__] * b[i__ + j * b_dim1]; +/* L50: */ + } +/* L60: */ + } + } + + if (nofact || equil) { + +/* Compute the LU factorization of the band matrix A. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = j - *ku; + j1 = f2cmax(i__2,1); +/* Computing MIN */ + i__2 = j + *kl; + j2 = f2cmin(i__2,*n); + i__2 = j2 - j1 + 1; + scopy_(&i__2, &ab[*ku + 1 - j + j1 + j * ab_dim1], &c__1, &afb[* + kl + *ku + 1 - j + j1 + j * afb_dim1], &c__1); +/* L70: */ + } + + sgbtrf_(n, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + +/* Compute the reciprocal pivot growth factor of the */ +/* leading rank-deficient INFO columns of A. */ + + anorm = 0.f; + i__1 = *info; + for (j = 1; j <= i__1; ++j) { +/* Computing MAX */ + i__2 = *ku + 2 - j; +/* Computing MIN */ + i__4 = *n + *ku + 1 - j, i__5 = *kl + *ku + 1; + i__3 = f2cmin(i__4,i__5); + for (i__ = f2cmax(i__2,1); i__ <= i__3; ++i__) { +/* Computing MAX */ + r__2 = anorm, r__3 = (r__1 = ab[i__ + j * ab_dim1], abs( + r__1)); + anorm = f2cmax(r__2,r__3); +/* L80: */ + } +/* L90: */ + } +/* Computing MIN */ + i__3 = *info - 1, i__2 = *kl + *ku; + i__1 = f2cmin(i__3,i__2); +/* Computing MAX */ + i__4 = 1, i__5 = *kl + *ku + 2 - *info; + rpvgrw = slantb_("M", "U", "N", info, &i__1, &afb[f2cmax(i__4,i__5) + + afb_dim1], ldafb, &work[1]); + if (rpvgrw == 0.f) { + rpvgrw = 1.f; + } else { + rpvgrw = anorm / rpvgrw; + } + work[1] = rpvgrw; + *rcond = 0.f; + return 0; + } + } + +/* Compute the norm of the matrix A and the */ +/* reciprocal pivot growth factor RPVGRW. */ + + if (notran) { + *(unsigned char *)norm = '1'; + } else { + *(unsigned char *)norm = 'I'; + } + anorm = slangb_(norm, n, kl, ku, &ab[ab_offset], ldab, &work[1]); + i__1 = *kl + *ku; + rpvgrw = slantb_("M", "U", "N", n, &i__1, &afb[afb_offset], ldafb, &work[ + 1]); + if (rpvgrw == 0.f) { + rpvgrw = 1.f; + } else { + rpvgrw = slangb_("M", n, kl, ku, &ab[ab_offset], ldab, &work[1]) / rpvgrw; + } + +/* Compute the reciprocal of the condition number of A. */ + + sgbcon_(norm, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], &anorm, rcond, + &work[1], &iwork[1], info); + +/* Compute the solution matrix X. */ + + slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + sgbtrs_(trans, n, kl, ku, nrhs, &afb[afb_offset], ldafb, &ipiv[1], &x[ + x_offset], ldx, info); + +/* Use iterative refinement to improve the computed solution and */ +/* compute error bounds and backward error estimates for it. */ + + sgbrfs_(trans, n, kl, ku, nrhs, &ab[ab_offset], ldab, &afb[afb_offset], + ldafb, &ipiv[1], &b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], & + berr[1], &work[1], &iwork[1], info); + +/* Transform the solution matrix X to a solution of the original */ +/* system. */ + + if (notran) { + if (colequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + x[i__ + j * x_dim1] = c__[i__] * x[i__ + j * x_dim1]; +/* L100: */ + } +/* L110: */ + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] /= colcnd; +/* L120: */ + } + } + } else if (rowequ) { + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + x[i__ + j * x_dim1] = r__[i__] * x[i__ + j * x_dim1]; +/* L130: */ + } +/* L140: */ + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + ferr[j] /= rowcnd; +/* L150: */ + } + } + +/* Set INFO = N+1 if the matrix is singular to working precision. */ + + if (*rcond < slamch_("Epsilon")) { + *info = *n + 1; + } + + work[1] = rpvgrw; + return 0; + +/* End of SGBSVX */ + +} /* sgbsvx_ */ + diff --git a/lapack-netlib/SRC/sgbsvxx.c b/lapack-netlib/SRC/sgbsvxx.c new file mode 100644 index 000000000..b8cf071e3 --- /dev/null +++ b/lapack-netlib/SRC/sgbsvxx.c @@ -0,0 +1,1248 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief SGBSVXX computes the solution to system of linear equations A * X = B for GB matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SGBSVXX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SGBSVXX( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, */ +/* LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX, */ +/* RCOND, RPVGRW, BERR, N_ERR_BNDS, */ +/* ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, */ +/* WORK, IWORK, INFO ) */ + +/* CHARACTER EQUED, FACT, TRANS */ +/* INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, NRHS, NPARAMS, */ +/* $ N_ERR_BNDS */ +/* REAL RCOND, RPVGRW */ +/* INTEGER IPIV( * ), IWORK( * ) */ +/* REAL AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), */ +/* $ X( LDX , * ),WORK( * ) */ +/* REAL R( * ), C( * ), PARAMS( * ), BERR( * ), */ +/* $ ERR_BNDS_NORM( NRHS, * ), */ +/* $ ERR_BNDS_COMP( NRHS, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SGBSVXX uses the LU factorization to compute the solution to a */ +/* > real system of linear equations A * X = B, where A is an */ +/* > N-by-N matrix and X and B are N-by-NRHS matrices. */ +/* > */ +/* > If requested, both normwise and maximum componentwise error bounds */ +/* > are returned. SGBSVXX will return a solution with a tiny */ +/* > guaranteed error (O(eps) where eps is the working machine */ +/* > precision) unless the matrix is very ill-conditioned, in which */ +/* > case a warning is returned. Relevant condition numbers also are */ +/* > calculated and returned. */ +/* > */ +/* > SGBSVXX accepts user-provided factorizations and equilibration */ +/* > factors; see the definitions of the FACT and EQUED options. */ +/* > Solving with refinement and using a factorization from a previous */ +/* > SGBSVXX call will also produce a solution with either O(eps) */ +/* > errors or warnings, but we cannot make that claim for general */ +/* > user-provided factorizations and equilibration factors if they */ +/* > differ from what SGBSVXX would itself produce. */ +/* > \endverbatim */ + +/* > \par Description: */ +/* ================= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The following steps are performed: */ +/* > */ +/* > 1. If FACT = 'E', real scaling factors are computed to equilibrate */ +/* > the system: */ +/* > */ +/* > TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */ +/* > TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */ +/* > TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */ +/* > */ +/* > Whether or not the system will be equilibrated depends on the */ +/* > scaling of the matrix A, but if equilibration is used, A is */ +/* > overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */ +/* > or diag(C)*B (if TRANS = 'T' or 'C'). */ +/* > */ +/* > 2. If FACT = 'N' or 'E', the LU decomposition is used to factor */ +/* > the matrix A (after equilibration if FACT = 'E') as */ +/* > */ +/* > A = P * L * U, */ +/* > */ +/* > where P is a permutation matrix, L is a unit lower triangular */ +/* > matrix, and U is upper triangular. */ +/* > */ +/* > 3. If some U(i,i)=0, so that U is exactly singular, then the */ +/* > routine returns with INFO = i. Otherwise, the factored form of A */ +/* > is used to estimate the condition number of the matrix A (see */ +/* > argument RCOND). If the reciprocal of the condition number is less */ +/* > than machine precision, the routine still goes on to solve for X */ +/* > and compute error bounds as described below. */ +/* > */ +/* > 4. The system of equations is solved for X using the factored form */ +/* > of A. */ +/* > */ +/* > 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */ +/* > the routine will use iterative refinement to try to get a small */ +/* > error and error bounds. Refinement calculates the residual to at */ +/* > least twice the working precision. */ +/* > */ +/* > 6. If equilibration was used, the matrix X is premultiplied by */ +/* > diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */ +/* > that it solves the original system before equilibration. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \verbatim */ +/* > Some optional parameters are bundled in the PARAMS array. These */ +/* > settings determine how refinement is performed, but often the */ +/* > defaults are acceptable. If the defaults are acceptable, users */ +/* > can pass NPARAMS = 0 which prevents the source code from accessing */ +/* > the PARAMS argument. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] FACT */ +/* > \verbatim */ +/* > FACT is CHARACTER*1 */ +/* > Specifies whether or not the factored form of the matrix A is */ +/* > supplied on entry, and if not, whether the matrix A should be */ +/* > equilibrated before it is factored. */ +/* > = 'F': On entry, AF and IPIV contain the factored form of A. */ +/* > If EQUED is not 'N', the matrix A has been */ +/* > equilibrated with scaling factors given by R and C. */ +/* > A, AF, and IPIV are not modified. */ +/* > = 'N': The matrix A will be copied to AF and factored. */ +/* > = 'E': The matrix A will be equilibrated if necessary, then */ +/* > copied to AF and factored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > Specifies the form of the system of equations: */ +/* > = 'N': A * X = B (No transpose) */ +/* > = 'T': A**T * X = B (Transpose) */ +/* > = 'C': A**H * X = B (Conjugate Transpose = Transpose) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of subdiagonals within the band of A. KL >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of superdiagonals within the band of A. KU >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is 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(N,j+kl) */ +/* > */ +/* > If FACT = 'F' and EQUED is not 'N', then AB must have been */ +/* > equilibrated by the scaling factors in R and/or C. AB is not */ +/* > modified if FACT = 'F' or 'N', or if FACT = 'E' and */ +/* > EQUED = 'N' on exit. */ +/* > */ +/* > On exit, if EQUED .ne. 'N', A is scaled as follows: */ +/* > EQUED = 'R': A := diag(R) * A */ +/* > EQUED = 'C': A := A * diag(C) */ +/* > EQUED = 'B': A := diag(R) * A * diag(C). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AFB */ +/* > \verbatim */ +/* > AFB is REAL array, dimension (LDAFB,N) */ +/* > If FACT = 'F', then AFB is an input argument and on entry */ +/* > contains details of the LU factorization of the band matrix */ +/* > A, as computed by SGBTRF. U is stored as an upper triangular */ +/* > band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */ +/* > and the multipliers used during the factorization are stored */ +/* > in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is */ +/* > the factored form of the equilibrated matrix A. */ +/* > */ +/* > If FACT = 'N', then AF is an output argument and on exit */ +/* > returns the factors L and U from the factorization A = P*L*U */ +/* > of the original matrix A. */ +/* > */ +/* > If FACT = 'E', then AF is an output argument and on exit */ +/* > returns the factors L and U from the factorization A = P*L*U */ +/* > of the equilibrated matrix A (see the description of A for */ +/* > the form of the equilibrated matrix). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAFB */ +/* > \verbatim */ +/* > LDAFB is INTEGER */ +/* > The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > If FACT = 'F', then IPIV is an input argument and on entry */ +/* > contains the pivot indices from the factorization A = P*L*U */ +/* > as computed by SGETRF; row i of the matrix was interchanged */ +/* > with row IPIV(i). */ +/* > */ +/* > If FACT = 'N', then IPIV is an output argument and on exit */ +/* > contains the pivot indices from the factorization A = P*L*U */ +/* > of the original matrix A. */ +/* > */ +/* > If FACT = 'E', then IPIV is an output argument and on exit */ +/* > contains the pivot indices from the factorization A = P*L*U */ +/* > of the equilibrated matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] EQUED */ +/* > \verbatim */ +/* > EQUED is CHARACTER*1 */ +/* > Specifies the form of equilibration that was done. */ +/* > = 'N': No equilibration (always true if FACT = 'N'). */ +/* > = 'R': Row equilibration, i.e., A has been premultiplied by */ +/* > diag(R). */ +/* > = 'C': Column equilibration, i.e., A has been postmultiplied */ +/* > by diag(C). */ +/* > = 'B': Both row and column equilibration, i.e., A has been */ +/* > replaced by diag(R) * A * diag(C). */ +/* > EQUED is an input argument if FACT = 'F'; otherwise, it is an */ +/* > output argument. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] R */ +/* > \verbatim */ +/* > R is REAL array, dimension (N) */ +/* > The row scale factors for A. If EQUED = 'R' or 'B', A is */ +/* > multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */ +/* > is not accessed. R is an input argument if FACT = 'F'; */ +/* > otherwise, R is an output argument. If FACT = 'F' and */ +/* > EQUED = 'R' or 'B', each element of R must be positive. */ +/* > If R is output, each element of R is a power of the radix. */ +/* > If R is input, each element of R should be a power of the radix */ +/* > to ensure a reliable solution and error estimates. Scaling by */ +/* > powers of the radix does not cause rounding errors unless the */ +/* > result underflows or overflows. Rounding errors during scaling */ +/* > lead to refining with a matrix that is not equivalent to the */ +/* > input matrix, producing error estimates that may not be */ +/* > reliable. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is REAL array, dimension (N) */ +/* > The column scale factors for A. If EQUED = 'C' or 'B', A is */ +/* > multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */ +/* > is not accessed. C is an input argument if FACT = 'F'; */ +/* > otherwise, C is an output argument. If FACT = 'F' and */ +/* > EQUED = 'C' or 'B', each element of C must be positive. */ +/* > If C is output, each element of C is a power of the radix. */ +/* > If C is input, each element of C should be a power of the radix */ +/* > to ensure a reliable solution and error estimates. Scaling by */ +/* > powers of the radix does not cause rounding errors unless the */ +/* > result underflows or overflows. Rounding errors during scaling */ +/* > lead to refining with a matrix that is not equivalent to the */ +/* > input matrix, producing error estimates that may not be */ +/* > reliable. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is REAL array, dimension (LDB,NRHS) */ +/* > On entry, the N-by-NRHS right hand side matrix B. */ +/* > On exit, */ +/* > if EQUED = 'N', B is not modified; */ +/* > if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */ +/* > diag(R)*B; */ +/* > if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */ +/* > overwritten by diag(C)*B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is REAL array, dimension (LDX,NRHS) */ +/* > If INFO = 0, the N-by-NRHS solution matrix X to the original */ +/* > system of equations. Note that A and B are modified on exit */ +/* > if EQUED .ne. 'N', and the solution to the equilibrated system is */ +/* > inv(diag(C))*X if TRANS = 'N' and EQUED = 'C' or 'B', or */ +/* > inv(diag(R))*X if TRANS = 'T' or 'C' and EQUED = 'R' or 'B'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is REAL */ +/* > Reciprocal scaled condition number. This is an estimate of the */ +/* > reciprocal Skeel condition number of the matrix A after */ +/* > equilibration (if done). If this is less than the machine */ +/* > precision (in particular, if it is zero), the matrix is singular */ +/* > to working precision. Note that the error may still be small even */ +/* > if this number is very small and the matrix appears ill- */ +/* > conditioned. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RPVGRW */ +/* > \verbatim */ +/* > RPVGRW is REAL */ +/* > Reciprocal pivot growth. On exit, this contains the reciprocal */ +/* > pivot growth factor norm(A)/norm(U). The "f2cmax absolute element" */ +/* > norm is used. If this is much less than 1, then the stability of */ +/* > the LU factorization of the (equilibrated) matrix A could be poor. */ +/* > This also means that the solution X, estimated condition numbers, */ +/* > and error bounds could be unreliable. If factorization fails with */ +/* > 0 for the leading INFO columns of A. In SGESVX, this quantity is */ +/* > returned in WORK(1). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is REAL array, dimension (NRHS) */ +/* > Componentwise relative backward error. This is the */ +/* > componentwise relative backward error of each solution vector X(j) */ +/* > (i.e., the smallest relative change in any element of A or B that */ +/* > makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N_ERR_BNDS */ +/* > \verbatim */ +/* > N_ERR_BNDS is INTEGER */ +/* > Number of error bounds to return for each right hand side */ +/* > and each type (normwise or componentwise). See ERR_BNDS_NORM and */ +/* > ERR_BNDS_COMP below. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ERR_BNDS_NORM */ +/* > \verbatim */ +/* > ERR_BNDS_NORM is REAL array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > normwise relative error, which is defined as follows: */ +/* > */ +/* > Normwise relative error in the ith solution vector: */ +/* > max_j (abs(XTRUE(j,i) - X(j,i))) */ +/* > ------------------------------ */ +/* > max_j abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the type of error information as described */ +/* > below. There currently are up to three pieces of information */ +/* > returned. */ +/* > */ +/* > The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_NORM(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated normwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * slamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*A, where S scales each row by a power of the */ +/* > radix so all absolute row sums of Z are approximately 1. */ +/* > */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ERR_BNDS_COMP */ +/* > \verbatim */ +/* > ERR_BNDS_COMP is REAL array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > componentwise relative error, which is defined as follows: */ +/* > */ +/* > Componentwise relative error in the ith solution vector: */ +/* > abs(XTRUE(j,i) - X(j,i)) */ +/* > max_j ---------------------- */ +/* > abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the right-hand side i (on which the */ +/* > componentwise relative error depends), and the type of error */ +/* > information as described below. There currently are up to three */ +/* > pieces of information returned for each right-hand side. If */ +/* > componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ +/* > ERR_BNDS_COMP is not accessed. If N_ERR_BNDS < 3, then at most */ +/* > the first (:,N_ERR_BNDS) entries are returned. */ +/* > */ +/* > The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_COMP(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). */ +/* > */ +/* > err = 2 "Guaranteed" error bound: The estimated forward error, */ +/* > almost certainly within a factor of 10 of the true error */ +/* > so long as the next entry is greater than the threshold */ +/* > sqrt(n) * slamch('Epsilon'). This error bound should only */ +/* > be trusted if the previous boolean is true. */ +/* > */ +/* > err = 3 Reciprocal condition number: Estimated componentwise */ +/* > reciprocal condition number. Compared with the threshold */ +/* > sqrt(n) * slamch('Epsilon') to determine if the error */ +/* > estimate is "guaranteed". These reciprocal condition */ +/* > numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */ +/* > appropriately scaled matrix Z. */ +/* > Let Z = S*(A*diag(x)), where x is the solution for the */ +/* > current right-hand side and S scales each row of */ +/* > A*diag(x) by a power of the radix so all absolute row */ +/* > sums of Z are approximately 1. */ +/* > */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NPARAMS */ +/* > \verbatim */ +/* > NPARAMS is INTEGER */ +/* > Specifies the number of parameters set in PARAMS. If <= 0, the */ +/* > PARAMS array is never referenced and default values are used. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] PARAMS */ +/* > \verbatim */ +/* > PARAMS is REAL array, dimension NPARAMS */ +/* > Specifies algorithm parameters. If an entry is < 0.0, then */ +/* > that entry will be filled with default value used for that */ +/* > parameter. Only positions up to NPARAMS are accessed; defaults */ +/* > are used for higher-numbered parameters. */ +/* > */ +/* > PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */ +/* > refinement or not. */ +/* > Default: 1.0 */ +/* > = 0.0: No refinement is performed, and no error bounds are */ +/* > computed. */ +/* > = 1.0: Use the double-precision refinement algorithm, */ +/* > possibly with doubled-single computations if the */ +/* > compilation environment does not support DOUBLE */ +/* > PRECISION. */ +/* > (other values are reserved for future use) */ +/* > */ +/* > PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */ +/* > computations allowed for refinement. */ +/* > Default: 10 */ +/* > Aggressive: Set to 100 to permit convergence using approximate */ +/* > factorizations or factorizations other than LU. If */ +/* > the factorization uses a technique other than */ +/* > Gaussian elimination, the guarantees in */ +/* > err_bnds_norm and err_bnds_comp may no longer be */ +/* > trustworthy. */ +/* > */ +/* > PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */ +/* > will attempt to find a solution with small componentwise */ +/* > relative error in the double-precision algorithm. Positive */ +/* > is true, 0.0 is false. */ +/* > Default: 1.0 (attempt componentwise convergence) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (4*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. The solution to every right-hand side is */ +/* > guaranteed. */ +/* > < 0: If INFO = -i, the i-th argument had an illegal value */ +/* > > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */ +/* > has been completed, but the factor U is exactly singular, so */ +/* > the solution and error bounds could not be computed. RCOND = 0 */ +/* > is returned. */ +/* > = N+J: The solution corresponding to the Jth right-hand side is */ +/* > not guaranteed. The solutions corresponding to other right- */ +/* > hand sides K with K > J may not be guaranteed as well, but */ +/* > only the first such right-hand side is reported. If a small */ +/* > componentwise error is not requested (PARAMS(3) = 0.0) then */ +/* > the Jth right-hand side is the first with a normwise error */ +/* > bound that is not guaranteed (the smallest J such */ +/* > that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */ +/* > the Jth right-hand side is the first with either a normwise or */ +/* > componentwise error bound that is not guaranteed (the smallest */ +/* > J such that either ERR_BNDS_NORM(J,1) = 0.0 or */ +/* > ERR_BNDS_COMP(J,1) = 0.0). See the definition of */ +/* > ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */ +/* > about all of the right-hand sides check ERR_BNDS_NORM or */ +/* > ERR_BNDS_COMP. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup realGBsolve */ + +/* ===================================================================== */ +/* Subroutine */ int sgbsvxx_(char *fact, char *trans, integer *n, integer * + kl, integer *ku, integer *nrhs, real *ab, integer *ldab, real *afb, + integer *ldafb, integer *ipiv, char *equed, real *r__, real *c__, + real *b, integer *ldb, real *x, integer *ldx, real *rcond, real * + rpvgrw, real *berr, integer *n_err_bnds__, real *err_bnds_norm__, + real *err_bnds_comp__, integer *nparams, real *params, real *work, + integer *iwork, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, + x_dim1, x_offset, err_bnds_norm_dim1, err_bnds_norm_offset, + err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2; + real r__1, r__2; + + /* Local variables */ + real amax; + extern real sla_gbrpvgrw_(integer *, integer *, integer *, integer *, + real *, integer *, real *, integer *); + integer i__, j; + extern logical lsame_(char *, char *); + real rcmin, rcmax; + logical equil; + real colcnd; + extern real slamch_(char *); + extern /* Subroutine */ int slaqgb_(integer *, integer *, integer *, + integer *, real *, integer *, real *, real *, real *, real *, + real *, char *); + logical nofact; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + real bignum; + integer infequ; + logical colequ; + extern /* Subroutine */ int sgbtrf_(integer *, integer *, integer *, + integer *, real *, integer *, integer *, integer *), slacpy_(char + *, integer *, integer *, real *, integer *, real *, integer *); + real rowcnd; + logical notran; + extern /* Subroutine */ int sgbtrs_(char *, integer *, integer *, integer + *, integer *, real *, integer *, integer *, real *, integer *, + integer *); + real smlnum; + logical rowequ; + extern /* Subroutine */ int slascl2_(integer *, integer *, real *, real *, + integer *), sgbequb_(integer *, integer *, integer *, integer *, + real *, integer *, real *, real *, real *, real *, real *, + integer *), sgbrfsx_(char *, char *, integer *, integer *, + integer *, integer *, real *, integer *, real *, integer *, + integer *, real *, real *, real *, integer *, real *, integer *, + real *, real *, integer *, real *, real *, integer *, real *, + real *, integer *, integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ================================================================== */ + + + /* Parameter adjustments */ + err_bnds_comp_dim1 = *nrhs; + err_bnds_comp_offset = 1 + err_bnds_comp_dim1 * 1; + err_bnds_comp__ -= err_bnds_comp_offset; + err_bnds_norm_dim1 = *nrhs; + err_bnds_norm_offset = 1 + err_bnds_norm_dim1 * 1; + err_bnds_norm__ -= err_bnds_norm_offset; + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + afb_dim1 = *ldafb; + afb_offset = 1 + afb_dim1 * 1; + afb -= afb_offset; + --ipiv; + --r__; + --c__; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --berr; + --params; + --work; + --iwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + equil = lsame_(fact, "E"); + notran = lsame_(trans, "N"); + smlnum = slamch_("Safe minimum"); + bignum = 1.f / smlnum; + if (nofact || equil) { + *(unsigned char *)equed = 'N'; + rowequ = FALSE_; + colequ = FALSE_; + } else { + rowequ = lsame_(equed, "R") || lsame_(equed, + "B"); + colequ = lsame_(equed, "C") || lsame_(equed, + "B"); + } + +/* Default is failure. If an input parameter is wrong or */ +/* factorization fails, make everything look horrible. Only the */ +/* pivot growth is set here, the rest is initialized in SGBRFSX. */ + + *rpvgrw = 0.f; + +/* Test the input parameters. PARAMS is not tested until SGBRFSX. */ + + if (! nofact && ! equil && ! lsame_(fact, "F")) { + *info = -1; + } else if (! notran && ! lsame_(trans, "T") && ! + lsame_(trans, "C")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*kl < 0) { + *info = -4; + } else if (*ku < 0) { + *info = -5; + } else if (*nrhs < 0) { + *info = -6; + } else if (*ldab < *kl + *ku + 1) { + *info = -8; + } else if (*ldafb < (*kl << 1) + *ku + 1) { + *info = -10; + } else if (lsame_(fact, "F") && ! (rowequ || colequ + || lsame_(equed, "N"))) { + *info = -12; + } else { + if (rowequ) { + rcmin = bignum; + rcmax = 0.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + r__1 = rcmin, r__2 = r__[j]; + rcmin = f2cmin(r__1,r__2); +/* Computing MAX */ + r__1 = rcmax, r__2 = r__[j]; + rcmax = f2cmax(r__1,r__2); +/* L10: */ + } + if (rcmin <= 0.f) { + *info = -13; + } else if (*n > 0) { + rowcnd = f2cmax(rcmin,smlnum) / f2cmin(rcmax,bignum); + } else { + rowcnd = 1.f; + } + } + if (colequ && *info == 0) { + rcmin = bignum; + rcmax = 0.f; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { +/* Computing MIN */ + r__1 = rcmin, r__2 = c__[j]; + rcmin = f2cmin(r__1,r__2); +/* Computing MAX */ + r__1 = rcmax, r__2 = c__[j]; + rcmax = f2cmax(r__1,r__2); +/* L20: */ + } + if (rcmin <= 0.f) { + *info = -14; + } else if (*n > 0) { + colcnd = f2cmax(rcmin,smlnum) / f2cmin(rcmax,bignum); + } else { + colcnd = 1.f; + } + } + if (*info == 0) { + if (*ldb < f2cmax(1,*n)) { + *info = -15; + } else if (*ldx < f2cmax(1,*n)) { + *info = -16; + } + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("SGBSVXX", &i__1, (ftnlen)7); + return 0; + } + + if (equil) { + +/* Compute row and column scalings to equilibrate the matrix A. */ + + sgbequb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], & + rowcnd, &colcnd, &amax, &infequ); + if (infequ == 0) { + +/* Equilibrate the matrix. */ + + slaqgb_(n, n, kl, ku, &ab[ab_offset], ldab, &r__[1], &c__[1], & + rowcnd, &colcnd, &amax, equed); + rowequ = lsame_(equed, "R") || lsame_(equed, + "B"); + colequ = lsame_(equed, "C") || lsame_(equed, + "B"); + } + +/* If the scaling factors are not applied, set them to 1.0. */ + + if (! rowequ) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + r__[j] = 1.f; + } + } + if (! colequ) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + c__[j] = 1.f; + } + } + } + +/* Scale the right hand side. */ + + if (notran) { + if (rowequ) { + slascl2_(n, nrhs, &r__[1], &b[b_offset], ldb); + } + } else { + if (colequ) { + slascl2_(n, nrhs, &c__[1], &b[b_offset], ldb); + } + } + + if (nofact || equil) { + +/* Compute the LU factorization of A. */ + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = (*kl << 1) + *ku + 1; + for (i__ = *kl + 1; i__ <= i__2; ++i__) { + afb[i__ + j * afb_dim1] = ab[i__ - *kl + j * ab_dim1]; +/* L30: */ + } +/* L40: */ + } + sgbtrf_(n, n, kl, ku, &afb[afb_offset], ldafb, &ipiv[1], info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + +/* Pivot in column INFO is exactly 0 */ +/* Compute the reciprocal pivot growth factor of the */ +/* leading rank-deficient INFO columns of A. */ + + *rpvgrw = sla_gbrpvgrw_(n, kl, ku, info, &ab[ab_offset], ldab, & + afb[afb_offset], ldafb); + return 0; + } + } + +/* Compute the reciprocal pivot growth factor RPVGRW. */ + + *rpvgrw = sla_gbrpvgrw_(n, kl, ku, n, &ab[ab_offset], ldab, &afb[ + afb_offset], ldafb); + +/* Compute the solution matrix X. */ + + slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + sgbtrs_(trans, n, kl, ku, nrhs, &afb[afb_offset], ldafb, &ipiv[1], &x[ + x_offset], ldx, info); + +/* Use iterative refinement to improve the computed solution and */ +/* compute error bounds and backward error estimates for it. */ + + sgbrfsx_(trans, equed, n, kl, ku, nrhs, &ab[ab_offset], ldab, &afb[ + afb_offset], ldafb, &ipiv[1], &r__[1], &c__[1], &b[b_offset], ldb, + &x[x_offset], ldx, rcond, &berr[1], n_err_bnds__, & + err_bnds_norm__[err_bnds_norm_offset], &err_bnds_comp__[ + err_bnds_comp_offset], nparams, ¶ms[1], &work[1], &iwork[1], + info); + +/* Scale solutions. */ + + if (colequ && notran) { + slascl2_(n, nrhs, &c__[1], &x[x_offset], ldx); + } else if (rowequ && ! notran) { + slascl2_(n, nrhs, &r__[1], &x[x_offset], ldx); + } + + return 0; + +/* End of SGBSVXX */ + +} /* sgbsvxx_ */ + diff --git a/lapack-netlib/SRC/sgbtf2.c b/lapack-netlib/SRC/sgbtf2.c new file mode 100644 index 000000000..01b361bd0 --- /dev/null +++ b/lapack-netlib/SRC/sgbtf2.c @@ -0,0 +1,696 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b SGBTF2 computes the LU factorization of a general band matrix using the unblocked version of th +e algorithm. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SGBTF2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO ) */ + +/* INTEGER INFO, KL, KU, LDAB, M, N */ +/* INTEGER IPIV( * ) */ +/* REAL AB( LDAB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SGBTF2 computes an LU factorization of a real m-by-n band matrix A */ +/* > using partial pivoting with row interchanges. */ +/* > */ +/* > This is the unblocked version of the algorithm, calling Level 2 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of subdiagonals within the band of A. KL >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of superdiagonals within the band of A. KU >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is REAL array, dimension (LDAB,N) */ +/* > On entry, the matrix A in band storage, in rows KL+1 to */ +/* > 2*KL+KU+1; rows 1 to KL of the array need not be set. */ +/* > The j-th column of A is stored in the j-th column of the */ +/* > array AB as follows: */ +/* > AB(kl+ku+1+i-j,j) = A(i,j) for f2cmax(1,j-ku)<=i<=f2cmin(m,j+kl) */ +/* > */ +/* > On exit, details of the factorization: U is stored as an */ +/* > upper triangular band matrix with KL+KU superdiagonals in */ +/* > rows 1 to KL+KU+1, and the multipliers used during the */ +/* > factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */ +/* > See below for further details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (f2cmin(M,N)) */ +/* > The pivot indices; for 1 <= i <= f2cmin(M,N), row i of the */ +/* > matrix was interchanged with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = +i, U(i,i) is exactly zero. The factorization */ +/* > has been completed, but the factor U is exactly */ +/* > singular, and division by zero will occur if it is used */ +/* > to solve a system of equations. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realGBcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The band storage scheme is illustrated by the following example, when */ +/* > M = N = 6, KL = 2, KU = 1: */ +/* > */ +/* > On entry: On exit: */ +/* > */ +/* > * * * + + + * * * u14 u25 u36 */ +/* > * * + + + + * * u13 u24 u35 u46 */ +/* > * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */ +/* > a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */ +/* > a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */ +/* > a31 a42 a53 a64 * * m31 m42 m53 m64 * * */ +/* > */ +/* > Array elements marked * are not used by the routine; elements marked */ +/* > + need not be set on entry, but are required by the routine to store */ +/* > elements of U, because of fill-in resulting from the row */ +/* > interchanges. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int sgbtf2_(integer *m, integer *n, integer *kl, integer *ku, + real *ab, integer *ldab, integer *ipiv, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; + real r__1; + + /* Local variables */ + extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, + integer *, real *, integer *, real *, integer *); + integer i__, j; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), + sswap_(integer *, real *, integer *, real *, integer *); + integer km, jp, ju, kv; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer isamax_(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 */ + + +/* ===================================================================== */ + + +/* KV is the number of superdiagonals in the factor U, allowing for */ +/* fill-in. */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --ipiv; + + /* Function Body */ + kv = *ku + *kl; + +/* Test the input parameters. */ + + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0) { + *info = -3; + } else if (*ku < 0) { + *info = -4; + } else if (*ldab < *kl + kv + 1) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SGBTF2", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Gaussian elimination with partial pivoting */ + +/* Set fill-in elements in columns KU+2 to KV to zero. */ + + i__1 = f2cmin(kv,*n); + for (j = *ku + 2; j <= i__1; ++j) { + i__2 = *kl; + for (i__ = kv - j + 2; i__ <= i__2; ++i__) { + ab[i__ + j * ab_dim1] = 0.f; +/* L10: */ + } +/* L20: */ + } + +/* JU is the index of the last column affected by the current stage */ +/* of the factorization. */ + + ju = 1; + + i__1 = f2cmin(*m,*n); + for (j = 1; j <= i__1; ++j) { + +/* Set fill-in elements in column J+KV to zero. */ + + if (j + kv <= *n) { + i__2 = *kl; + for (i__ = 1; i__ <= i__2; ++i__) { + ab[i__ + (j + kv) * ab_dim1] = 0.f; +/* L30: */ + } + } + +/* Find pivot and test for singularity. KM is the number of */ +/* subdiagonal elements in the current column. */ + +/* Computing MIN */ + i__2 = *kl, i__3 = *m - j; + km = f2cmin(i__2,i__3); + i__2 = km + 1; + jp = isamax_(&i__2, &ab[kv + 1 + j * ab_dim1], &c__1); + ipiv[j] = jp + j - 1; + if (ab[kv + jp + j * ab_dim1] != 0.f) { +/* Computing MAX */ +/* Computing MIN */ + i__4 = j + *ku + jp - 1; + i__2 = ju, i__3 = f2cmin(i__4,*n); + ju = f2cmax(i__2,i__3); + +/* Apply interchange to columns J to JU. */ + + if (jp != 1) { + i__2 = ju - j + 1; + i__3 = *ldab - 1; + i__4 = *ldab - 1; + sswap_(&i__2, &ab[kv + jp + j * ab_dim1], &i__3, &ab[kv + 1 + + j * ab_dim1], &i__4); + } + + if (km > 0) { + +/* Compute multipliers. */ + + r__1 = 1.f / ab[kv + 1 + j * ab_dim1]; + sscal_(&km, &r__1, &ab[kv + 2 + j * ab_dim1], &c__1); + +/* Update trailing submatrix within the band. */ + + if (ju > j) { + i__2 = ju - j; + i__3 = *ldab - 1; + i__4 = *ldab - 1; + sger_(&km, &i__2, &c_b9, &ab[kv + 2 + j * ab_dim1], &c__1, + &ab[kv + (j + 1) * ab_dim1], &i__3, &ab[kv + 1 + + (j + 1) * ab_dim1], &i__4); + } + } + } else { + +/* If pivot is zero, set INFO to the index of the pivot */ +/* unless a zero pivot has already been found. */ + + if (*info == 0) { + *info = j; + } + } +/* L40: */ + } + return 0; + +/* End of SGBTF2 */ + +} /* sgbtf2_ */ + diff --git a/lapack-netlib/SRC/sgbtrf.c b/lapack-netlib/SRC/sgbtrf.c new file mode 100644 index 000000000..bf6e4deb7 --- /dev/null +++ b/lapack-netlib/SRC/sgbtrf.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 SGBTRF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download SGBTRF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO ) */ + +/* INTEGER INFO, KL, KU, LDAB, M, N */ +/* INTEGER IPIV( * ) */ +/* REAL AB( LDAB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SGBTRF computes an LU factorization of a real m-by-n band matrix A */ +/* > using partial pivoting with row interchanges. */ +/* > */ +/* > This is the blocked version of the algorithm, calling Level 3 BLAS. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows of the matrix A. M >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of subdiagonals within the band of A. KL >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of superdiagonals within the band of A. KU >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AB */ +/* > \verbatim */ +/* > AB is REAL array, dimension (LDAB,N) */ +/* > On entry, the matrix A in band storage, in rows KL+1 to */ +/* > 2*KL+KU+1; rows 1 to KL of the array need not be set. */ +/* > The j-th column of A is stored in the j-th column of the */ +/* > array AB as follows: */ +/* > AB(kl+ku+1+i-j,j) = A(i,j) for f2cmax(1,j-ku)<=i<=f2cmin(m,j+kl) */ +/* > */ +/* > On exit, details of the factorization: U is stored as an */ +/* > upper triangular band matrix with KL+KU superdiagonals in */ +/* > rows 1 to KL+KU+1, and the multipliers used during the */ +/* > factorization are stored in rows KL+KU+2 to 2*KL+KU+1. */ +/* > See below for further details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (f2cmin(M,N)) */ +/* > The pivot indices; for 1 <= i <= f2cmin(M,N), row i of the */ +/* > matrix was interchanged with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = +i, U(i,i) is exactly zero. The factorization */ +/* > has been completed, but the factor U is exactly */ +/* > singular, and division by zero will occur if it is used */ +/* > to solve a system of equations. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup realGBcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The band storage scheme is illustrated by the following example, when */ +/* > M = N = 6, KL = 2, KU = 1: */ +/* > */ +/* > On entry: On exit: */ +/* > */ +/* > * * * + + + * * * u14 u25 u36 */ +/* > * * + + + + * * u13 u24 u35 u46 */ +/* > * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56 */ +/* > a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66 */ +/* > a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 * */ +/* > a31 a42 a53 a64 * * m31 m42 m53 m64 * * */ +/* > */ +/* > Array elements marked * are not used by the routine; elements marked */ +/* > + need not be set on entry, but are required by the routine to store */ +/* > elements of U because of fill-in resulting from the row interchanges. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int sgbtrf_(integer *m, integer *n, integer *kl, integer *ku, + real *ab, integer *ldab, integer *ipiv, integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4, i__5, i__6; + real r__1; + + /* Local variables */ + extern /* Subroutine */ int sger_(integer *, integer *, real *, real *, + integer *, real *, integer *, real *, integer *); + real temp; + integer i__, j; + extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *), + sgemm_(char *, char *, integer *, integer *, integer *, real *, + real *, integer *, real *, integer *, real *, real *, integer *); + real work13[4160] /* was [65][64] */, work31[4160] /* was [65][ + 64] */; + integer i2, i3, j2, j3, k2; + extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *, + integer *), sswap_(integer *, real *, integer *, real *, integer * + ), strsm_(char *, char *, char *, char *, integer *, integer *, + real *, real *, integer *, real *, integer *), sgbtf2_(integer *, integer *, integer *, integer + *, real *, integer *, integer *, integer *); + integer jb, nb, ii, jj, jm, ip, jp, km, ju, kv, nw; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen), isamax_(integer *, real *, + integer *); + extern /* Subroutine */ int slaswp_(integer *, real *, integer *, integer + *, integer *, integer *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* KV is the number of superdiagonals in the factor U, allowing for */ +/* fill-in */ + + /* Parameter adjustments */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --ipiv; + + /* Function Body */ + kv = *ku + *kl; + +/* Test the input parameters. */ + + *info = 0; + if (*m < 0) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0) { + *info = -3; + } else if (*ku < 0) { + *info = -4; + } else if (*ldab < *kl + kv + 1) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SGBTRF", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*m == 0 || *n == 0) { + return 0; + } + +/* Determine the block size for this environment */ + + nb = ilaenv_(&c__1, "SGBTRF", " ", m, n, kl, ku, (ftnlen)6, (ftnlen)1); + +/* The block size must not exceed the limit set by the size of the */ +/* local arrays WORK13 and WORK31. */ + + nb = f2cmin(nb,64); + + if (nb <= 1 || nb > *kl) { + +/* Use unblocked code */ + + sgbtf2_(m, n, kl, ku, &ab[ab_offset], ldab, &ipiv[1], info); + } else { + +/* Use blocked code */ + +/* Zero the superdiagonal elements of the work array WORK13 */ + + i__1 = nb; + for (j = 1; j <= i__1; ++j) { + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + work13[i__ + j * 65 - 66] = 0.f; +/* L10: */ + } +/* L20: */ + } + +/* Zero the subdiagonal elements of the work array WORK31 */ + + i__1 = nb; + for (j = 1; j <= i__1; ++j) { + i__2 = nb; + for (i__ = j + 1; i__ <= i__2; ++i__) { + work31[i__ + j * 65 - 66] = 0.f; +/* L30: */ + } +/* L40: */ + } + +/* Gaussian elimination with partial pivoting */ + +/* Set fill-in elements in columns KU+2 to KV to zero */ + + i__1 = f2cmin(kv,*n); + for (j = *ku + 2; j <= i__1; ++j) { + i__2 = *kl; + for (i__ = kv - j + 2; i__ <= i__2; ++i__) { + ab[i__ + j * ab_dim1] = 0.f; +/* L50: */ + } +/* L60: */ + } + +/* JU is the index of the last column affected by the current */ +/* stage of the factorization */ + + ju = 1; + + i__1 = f2cmin(*m,*n); + i__2 = nb; + for (j = 1; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) { +/* Computing MIN */ + i__3 = nb, i__4 = f2cmin(*m,*n) - j + 1; + jb = f2cmin(i__3,i__4); + +/* The active part of the matrix is partitioned */ + +/* A11 A12 A13 */ +/* A21 A22 A23 */ +/* A31 A32 A33 */ + +/* Here A11, A21 and A31 denote the current block of JB columns */ +/* which is about to be factorized. The number of rows in the */ +/* partitioning are JB, I2, I3 respectively, and the numbers */ +/* of columns are JB, J2, J3. The superdiagonal elements of A13 */ +/* and the subdiagonal elements of A31 lie outside the band. */ + +/* Computing MIN */ + i__3 = *kl - jb, i__4 = *m - j - jb + 1; + i2 = f2cmin(i__3,i__4); +/* Computing MIN */ + i__3 = jb, i__4 = *m - j - *kl + 1; + i3 = f2cmin(i__3,i__4); + +/* J2 and J3 are computed after JU has been updated. */ + +/* Factorize the current block of JB columns */ + + i__3 = j + jb - 1; + for (jj = j; jj <= i__3; ++jj) { + +/* Set fill-in elements in column JJ+KV to zero */ + + if (jj + kv <= *n) { + i__4 = *kl; + for (i__ = 1; i__ <= i__4; ++i__) { + ab[i__ + (jj + kv) * ab_dim1] = 0.f; +/* L70: */ + } + } + +/* Find pivot and test for singularity. KM is the number of */ +/* subdiagonal elements in the current column. */ + +/* Computing MIN */ + i__4 = *kl, i__5 = *m - jj; + km = f2cmin(i__4,i__5); + i__4 = km + 1; + jp = isamax_(&i__4, &ab[kv + 1 + jj * ab_dim1], &c__1); + ipiv[jj] = jp + jj - j; + if (ab[kv + jp + jj * ab_dim1] != 0.f) { +/* Computing MAX */ +/* Computing MIN */ + i__6 = jj + *ku + jp - 1; + i__4 = ju, i__5 = f2cmin(i__6,*n); + ju = f2cmax(i__4,i__5); + if (jp != 1) { + +/* Apply interchange to columns J to J+JB-1 */ + + if (jp + jj - 1 < j + *kl) { + + i__4 = *ldab - 1; + i__5 = *ldab - 1; + sswap_(&jb, &ab[kv + 1 + jj - j + j * ab_dim1], & + i__4, &ab[kv + jp + jj - j + j * ab_dim1], + &i__5); + } else { + +/* The interchange affects columns J to JJ-1 of A31 */ +/* which are stored in the work array WORK31 */ + + i__4 = jj - j; + i__5 = *ldab - 1; + sswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], + &i__5, &work31[jp + jj - j - *kl - 1], & + c__65); + i__4 = j + jb - jj; + i__5 = *ldab - 1; + i__6 = *ldab - 1; + sswap_(&i__4, &ab[kv + 1 + jj * ab_dim1], &i__5, & + ab[kv + jp + jj * ab_dim1], &i__6); + } + } + +/* Compute multipliers */ + + r__1 = 1.f / ab[kv + 1 + jj * ab_dim1]; + sscal_(&km, &r__1, &ab[kv + 2 + jj * ab_dim1], &c__1); + +/* Update trailing submatrix within the band and within */ +/* the current block. JM is the index of the last column */ +/* which needs to be updated. */ + +/* Computing MIN */ + i__4 = ju, i__5 = j + jb - 1; + jm = f2cmin(i__4,i__5); + if (jm > jj) { + i__4 = jm - jj; + i__5 = *ldab - 1; + i__6 = *ldab - 1; + sger_(&km, &i__4, &c_b18, &ab[kv + 2 + jj * ab_dim1], + &c__1, &ab[kv + (jj + 1) * ab_dim1], &i__5, & + ab[kv + 1 + (jj + 1) * ab_dim1], &i__6); + } + } else { + +/* If pivot is zero, set INFO to the index of the pivot */ +/* unless a zero pivot has already been found. */ + + if (*info == 0) { + *info = jj; + } + } + +/* Copy current column of A31 into the work array WORK31 */ + +/* Computing MIN */ + i__4 = jj - j + 1; + nw = f2cmin(i__4,i3); + if (nw > 0) { + scopy_(&nw, &ab[kv + *kl + 1 - jj + j + jj * ab_dim1], & + c__1, &work31[(jj - j + 1) * 65 - 65], &c__1); + } +/* L80: */ + } + if (j + jb <= *n) { + +/* Apply the row interchanges to the other blocks. */ + +/* Computing MIN */ + i__3 = ju - j + 1; + j2 = f2cmin(i__3,kv) - jb; +/* Computing MAX */ + i__3 = 0, i__4 = ju - j - kv + 1; + j3 = f2cmax(i__3,i__4); + +/* Use SLASWP to apply the row interchanges to A12, A22, and */ +/* A32. */ + + i__3 = *ldab - 1; + slaswp_(&j2, &ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__3, & + c__1, &jb, &ipiv[j], &c__1); + +/* Adjust the pivot indices. */ + + i__3 = j + jb - 1; + for (i__ = j; i__ <= i__3; ++i__) { + ipiv[i__] = ipiv[i__] + j - 1; +/* L90: */ + } + +/* Apply the row interchanges to A13, A23, and A33 */ +/* columnwise. */ + + k2 = j - 1 + jb + j2; + i__3 = j3; + for (i__ = 1; i__ <= i__3; ++i__) { + jj = k2 + i__; + i__4 = j + jb - 1; + for (ii = j + i__ - 1; ii <= i__4; ++ii) { + ip = ipiv[ii]; + if (ip != ii) { + temp = ab[kv + 1 + ii - jj + jj * ab_dim1]; + ab[kv + 1 + ii - jj + jj * ab_dim1] = ab[kv + 1 + + ip - jj + jj * ab_dim1]; + ab[kv + 1 + ip - jj + jj * ab_dim1] = temp; + } +/* L100: */ + } +/* L110: */ + } + +/* Update the relevant part of the trailing submatrix */ + + if (j2 > 0) { + +/* Update A12 */ + + i__3 = *ldab - 1; + i__4 = *ldab - 1; + strsm_("Left", "Lower", "No transpose", "Unit", &jb, &j2, + &c_b31, &ab[kv + 1 + j * ab_dim1], &i__3, &ab[kv + + 1 - jb + (j + jb) * ab_dim1], &i__4); + + if (i2 > 0) { + +/* Update A22 */ + + i__3 = *ldab - 1; + i__4 = *ldab - 1; + i__5 = *ldab - 1; + sgemm_("No transpose", "No transpose", &i2, &j2, &jb, + &c_b18, &ab[kv + 1 + jb + j * ab_dim1], &i__3, + &ab[kv + 1 - jb + (j + jb) * ab_dim1], &i__4, + &c_b31, &ab[kv + 1 + (j + jb) * ab_dim1], & + i__5); + } + + if (i3 > 0) { + +/* Update A32 */ + + i__3 = *ldab - 1; + i__4 = *ldab - 1; + sgemm_("No transpose", "No transpose", &i3, &j2, &jb, + &c_b18, work31, &c__65, &ab[kv + 1 - jb + (j + + jb) * ab_dim1], &i__3, &c_b31, &ab[kv + *kl + + 1 - jb + (j + jb) * ab_dim1], &i__4); + } + } + + if (j3 > 0) { + +/* Copy the lower triangle of A13 into the work array */ +/* WORK13 */ + + i__3 = j3; + for (jj = 1; jj <= i__3; ++jj) { + i__4 = jb; + for (ii = jj; ii <= i__4; ++ii) { + work13[ii + jj * 65 - 66] = ab[ii - jj + 1 + (jj + + j + kv - 1) * ab_dim1]; +/* L120: */ + } +/* L130: */ + } + +/* Update A13 in the work array */ + + i__3 = *ldab - 1; + strsm_("Left", "Lower", "No transpose", "Unit", &jb, &j3, + &c_b31, &ab[kv + 1 + j * ab_dim1], &i__3, work13, + &c__65); + + if (i2 > 0) { + +/* Update A23 */ + + i__3 = *ldab - 1; + i__4 = *ldab - 1; + sgemm_("No transpose", "No transpose", &i2, &j3, &jb, + &c_b18, &ab[kv + 1 + jb + j * ab_dim1], &i__3, + work13, &c__65, &c_b31, &ab[jb + 1 + (j + kv) + * ab_dim1], &i__4); + } + + if (i3 > 0) { + +/* Update A33 */ + + i__3 = *ldab - 1; + sgemm_("No transpose", "No transpose", &i3, &j3, &jb, + &c_b18, work31, &c__65, work13, &c__65, & + c_b31, &ab[*kl + 1 + (j + kv) * ab_dim1], & + i__3); + } + +/* Copy the lower triangle of A13 back into place */ + + i__3 = j3; + for (jj = 1; jj <= i__3; ++jj) { + i__4 = jb; + for (ii = jj; ii <= i__4; ++ii) { + ab[ii - jj + 1 + (jj + j + kv - 1) * ab_dim1] = + work13[ii + jj * 65 - 66]; +/* L140: */ + } +/* L150: */ + } + } + } else { + +/* Adjust the pivot indices. */ + + i__3 = j + jb - 1; + for (i__ = j; i__ <= i__3; ++i__) { + ipiv[i__] = ipiv[i__] + j - 1; +/* L160: */ + } + } + +/* Partially undo the interchanges in the current block to */ +/* restore the upper triangular form of A31 and copy the upper */ +/* triangle of A31 back into place */ + + i__3 = j; + for (jj = j + jb - 1; jj >= i__3; --jj) { + jp = ipiv[jj] - jj + 1; + if (jp != 1) { + +/* Apply interchange to columns J to JJ-1 */ + + if (jp + jj - 1 < j + *kl) { + +/* The interchange does not affect A31 */ + + i__4 = jj - j; + i__5 = *ldab - 1; + i__6 = *ldab - 1; + sswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], & + i__5, &ab[kv + jp + jj - j + j * ab_dim1], & + i__6); + } else { + +/* The interchange does affect A31 */ + + i__4 = jj - j; + i__5 = *ldab - 1; + sswap_(&i__4, &ab[kv + 1 + jj - j + j * ab_dim1], & + i__5, &work31[jp + jj - j - *kl - 1], &c__65); + } + } + +/* Copy the current column of A31 back into place */ + +/* Computing MIN */ + i__4 = i3, i__5 = jj - j + 1; + nw = f2cmin(i__4,i__5); + if (nw > 0) { + scopy_(&nw, &work31[(jj - j + 1) * 65 - 65], &c__1, &ab[ + kv + *kl + 1 - jj + j + jj * ab_dim1], &c__1); + } +/* L170: */ + } +/* L180: */ + } + } + + return 0; + +/* End of SGBTRF */ + +} /* sgbtrf_ */ +