diff --git a/lapack-netlib/SRC/zhetrf.c b/lapack-netlib/SRC/zhetrf.c new file mode 100644 index 000000000..a5a9e348c --- /dev/null +++ b/lapack-netlib/SRC/zhetrf.c @@ -0,0 +1,775 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHETRF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHETRF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHETRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LWORK, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHETRF computes the factorization of a complex Hermitian matrix A */ +/* > using the Bunch-Kaufman diagonal pivoting method. The form of the */ +/* > factorization is */ +/* > */ +/* > A = U*D*U**H or A = L*D*L**H */ +/* > */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and D is Hermitian 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 COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the Hermitian matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, 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 COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of WORK. LWORK >=1. For best performance */ +/* > LWORK >= N*NB, where NB is the block size returned by ILAENV. */ +/* > \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 complex16HEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > If UPLO = 'U', then A = U*D*U**H, 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**H, 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 zhetrf_(char *uplo, integer *n, doublecomplex *a, + integer *lda, integer *ipiv, doublecomplex *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 zhetf2_(char *, integer *, doublecomplex *, + integer *, integer *, integer *); + integer kb, nb; + extern /* Subroutine */ int zlahef_(char *, integer *, integer *, integer + *, doublecomplex *, integer *, integer *, doublecomplex *, + integer *, integer *), 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; + --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, "ZHETRF", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); + lwkopt = *n * nb; + work[1].r = (doublereal) lwkopt, work[1].i = 0.; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHETRF", &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, "ZHETRF", 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*D*U**H 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 ZLAHEF; */ +/* 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 */ + + zlahef_(uplo, &k, &nb, &kb, &a[a_offset], lda, &ipiv[1], &work[1], + n, &iinfo); + } else { + +/* Use unblocked code to factorize columns 1:k of A */ + + zhetf2_(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**H 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 ZLAHEF; */ +/* 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; + zlahef_(uplo, &i__1, &nb, &kb, &a[k + k * a_dim1], lda, &ipiv[k], + &work[1], n, &iinfo); + } else { + +/* Use unblocked code to factorize columns k:n of A */ + + i__1 = *n - k + 1; + zhetf2_(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].r = (doublereal) lwkopt, work[1].i = 0.; + return 0; + +/* End of ZHETRF */ + +} /* zhetrf_ */ + diff --git a/lapack-netlib/SRC/zhetrf_aa.c b/lapack-netlib/SRC/zhetrf_aa.c new file mode 100644 index 000000000..0e7a44161 --- /dev/null +++ b/lapack-netlib/SRC/zhetrf_aa.c @@ -0,0 +1,932 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHETRF_AA */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHETRF_AA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHETRF_AA( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER N, LDA, LWORK, INFO */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), WORK( * ) */ + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHETRF_AA computes the factorization of a complex hermitian matrix A */ +/* > using the Aasen's algorithm. The form of the factorization is */ +/* > */ +/* > A = U**H*T*U or A = L*T*L**H */ +/* > */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and T is a hermitian 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 COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the hermitian matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, 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 COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of 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 complex16HEcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zhetrf_aa_(char *uplo, integer *n, doublecomplex *a, + integer *lda, integer *ipiv, doublecomplex *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + doublereal d__1; + doublecomplex z__1; + + /* Local variables */ + integer j; + doublecomplex alpha; + extern /* Subroutine */ int zlahef_aa_(char *, integer *, integer *, + integer *, doublecomplex *, integer *, integer *, doublecomplex *, + integer *, doublecomplex *); + extern logical lsame_(char *, char *); + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *), zgemm_(char *, char *, integer *, + integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + logical upper; + integer k1, k2, j1, j2, j3; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zswap_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *); + integer jb, nb, mj, nj; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer lwkopt; + logical lquery; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + + +/* ===================================================================== */ + + +/* Determine the block size */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + --work; + + /* Function Body */ + nb = ilaenv_(&c__1, "ZHETRF_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].r = (doublereal) lwkopt, work[1].i = 0.; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHETRF_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) { + i__1 = a_dim1 + 1; + i__2 = a_dim1 + 1; + d__1 = a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + 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**H*D*U using the upper triangle of A */ +/* ..................................................... */ + +/* copy first row A(1, 1:N) into H(1:n) (stored in WORK(1:N)) */ + + zcopy_(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 ZLAHEF; */ +/* 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; + zlahef_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; + zswap_(&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 the first panel and JB=1 (NB=1), then nothing to do */ + + if (j1 > 1 || jb > 1) { + +/* Merge rank-1 update with BLAS-3 update */ + + d_cnjg(&z__1, &a[j + (j + 1) * a_dim1]); + alpha.r = z__1.r, alpha.i = z__1.i; + i__1 = j + (j + 1) * a_dim1; + a[i__1].r = 1., a[i__1].i = 0.; + i__1 = *n - j; + zcopy_(&i__1, &a[j - 1 + (j + 1) * a_dim1], lda, &work[j + 1 + - j1 + 1 + jb * *n], &c__1); + i__1 = *n - j; + zscal_(&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=0 and K2=1 for the first panel, */ +/* and K1=1 and K2=0 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 ZGEMV */ + + j3 = j2; + for (mj = nj - 1; mj >= 1; --mj) { + i__3 = jb + 1; + z__1.r = -1., z__1.i = 0.; + zgemm_("Conjugate transpose", "Transpose", &c__1, &mj, + &i__3, &z__1, &a[j1 - k2 + j3 * a_dim1], lda, + &work[j3 - j1 + 1 + k1 * *n], n, &c_b2, &a[ + j3 + j3 * a_dim1], lda) + ; + ++j3; + } + +/* Update off-diagonal block of J2-th block row with ZGEMM */ + + i__3 = *n - j3 + 1; + i__4 = jb + 1; + z__1.r = -1., z__1.i = 0.; + zgemm_("Conjugate transpose", "Transpose", &nj, &i__3, & + i__4, &z__1, &a[j1 - k2 + j2 * a_dim1], lda, & + work[j3 - j1 + 1 + k1 * *n], n, &c_b2, &a[j2 + j3 + * a_dim1], lda); + } + +/* Recover T( J, J+1 ) */ + + i__2 = j + (j + 1) * a_dim1; + d_cnjg(&z__1, &alpha); + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + } + +/* WORK(J+1, 1) stores H(J+1, 1) */ + + i__2 = *n - j; + zcopy_(&i__2, &a[j + 1 + (j + 1) * a_dim1], lda, &work[1], &c__1); + } + goto L10; + } else { + +/* ..................................................... */ +/* Factorize A as L*D*L**H using the lower triangle of A */ +/* ..................................................... */ + +/* copy first column A(1:N, 1) into H(1:N, 1) */ +/* (stored in WORK(1:N)) */ + + zcopy_(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 ZLAHEF; */ +/* 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; + zlahef_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; + zswap_(&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 the first panel and JB=1 (NB=1), then nothing to do */ + + if (j1 > 1 || jb > 1) { + +/* Merge rank-1 update with BLAS-3 update */ + + d_cnjg(&z__1, &a[j + 1 + j * a_dim1]); + alpha.r = z__1.r, alpha.i = z__1.i; + i__2 = j + 1 + j * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + i__2 = *n - j; + zcopy_(&i__2, &a[j + 1 + (j - 1) * a_dim1], &c__1, &work[j + + 1 - j1 + 1 + jb * *n], &c__1); + i__2 = *n - j; + zscal_(&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=0 and K2=1 for the first panel, */ +/* and K1=1 and K2=0 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 ZGEMV */ + + j3 = j2; + for (mj = nj - 1; mj >= 1; --mj) { + i__3 = jb + 1; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Conjugate transpose", &mj, & + c__1, &i__3, &z__1, &work[j3 - j1 + 1 + k1 * * + n], n, &a[j3 + (j1 - k2) * a_dim1], lda, & + c_b2, &a[j3 + j3 * a_dim1], lda); + ++j3; + } + +/* Update off-diagonal block of J2-th block column with ZGEMM */ + + i__3 = *n - j3 + 1; + i__4 = jb + 1; + z__1.r = -1., z__1.i = 0.; + zgemm_("No transpose", "Conjugate transpose", &i__3, &nj, + &i__4, &z__1, &work[j3 - j1 + 1 + k1 * *n], n, &a[ + j2 + (j1 - k2) * a_dim1], lda, &c_b2, &a[j3 + j2 * + a_dim1], lda); + } + +/* Recover T( J+1, J ) */ + + i__1 = j + 1 + j * a_dim1; + d_cnjg(&z__1, &alpha); + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + } + +/* WORK(J+1, 1) stores H(J+1, 1) */ + + i__1 = *n - j; + zcopy_(&i__1, &a[j + 1 + (j + 1) * a_dim1], &c__1, &work[1], & + c__1); + } + goto L11; + } + +L20: + return 0; + +/* End of ZHETRF_AA */ + +} /* zhetrf_aa__ */ + diff --git a/lapack-netlib/SRC/zhetrf_aa_2stage.c b/lapack-netlib/SRC/zhetrf_aa_2stage.c new file mode 100644 index 000000000..9b0a2d7ae --- /dev/null +++ b/lapack-netlib/SRC/zhetrf_aa_2stage.c @@ -0,0 +1,1163 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHETRF_AA_2STAGE */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHETRF_AA_2STAGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHETRF_AA_2STAGE( UPLO, N, A, LDA, TB, LTB, IPIV, */ +/* IPIV2, WORK, LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER N, LDA, LTB, LWORK, INFO */ +/* INTEGER IPIV( * ), IPIV2( * ) */ +/* COMPLEX*16 A( LDA, * ), TB( * ), WORK( * ) */ + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHETRF_AA_2STAGE computes the factorization of a double hermitian matrix A */ +/* > using the Aasen's algorithm. The form of the factorization is */ +/* > */ +/* > A = U**H*T*U or A = L*T*L**H */ +/* > */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and T is a hermitian band matrix with the */ +/* > bandwidth of NB (NB is internally selected and stored in TB( 1 ), and T is */ +/* > LU factorized with partial pivoting). */ +/* > */ +/* > 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 COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the hermitian matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, L is stored below (or above) the subdiaonal blocks, */ +/* > when UPLO is 'L' (or 'U'). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TB */ +/* > \verbatim */ +/* > TB is COMPLEX*16 array, dimension (LTB) */ +/* > On exit, details of the LU factorization of the band matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LTB */ +/* > \verbatim */ +/* > LTB is INTEGER */ +/* > The size of the array TB. LTB >= 4*N, internally */ +/* > used to select NB such that LTB >= (3*NB+1)*N. */ +/* > */ +/* > If LTB = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal size of LTB, */ +/* > returns this value as the first entry of TB, and */ +/* > no error message related to LTB is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > On exit, it contains the details of the interchanges, i.e., */ +/* > the row and column k of A were interchanged with the */ +/* > row and column IPIV(k). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV2 */ +/* > \verbatim */ +/* > IPIV2 is INTEGER array, dimension (N) */ +/* > On exit, it contains the details of the interchanges, i.e., */ +/* > the row and column k of T were interchanged with the */ +/* > row and column IPIV(k). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 workspace of size LWORK */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The size of WORK. LWORK >= N, internally used to select NB */ +/* > such that LWORK >= N*NB. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal size of the WORK array, */ +/* > returns this value as the first entry of the WORK array, and */ +/* > no error message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: if INFO = i, band LU factorization failed on i-th column */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup complex16SYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zhetrf_aa_2stage_(char *uplo, integer *n, doublecomplex + *a, integer *lda, doublecomplex *tb, integer *ltb, integer *ipiv, + integer *ipiv2, doublecomplex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3, i__4; + doublereal d__1; + doublecomplex z__1; + + /* Local variables */ + integer ldtb, i__, j, k; + extern logical lsame_(char *, char *); + integer iinfo; + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + integer i1; + logical upper; + integer i2; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zswap_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *), ztrsm_(char *, char *, + char *, char *, integer *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *); + integer jb, kb, nb, td, nt; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int zlacgv_(integer *, doublecomplex *, integer *) + , zgbtrf_(integer *, integer *, integer *, integer *, + doublecomplex *, integer *, integer *, integer *), zgetrf_( + integer *, integer *, doublecomplex *, integer *, integer *, + integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, + integer *, doublecomplex *, integer *), zlaset_(char *, + integer *, integer *, doublecomplex *, doublecomplex *, + doublecomplex *, integer *), zhegst_(integer *, char *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *, + integer *); + logical tquery, wquery; + doublecomplex piv; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --tb; + --ipiv; + --ipiv2; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + wquery = *lwork == -1; + tquery = *ltb == -1; + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*ltb < *n << 2 && ! tquery) { + *info = -6; + } else if (*lwork < *n && ! wquery) { + *info = -10; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHETRF_AA_2STAGE", &i__1, (ftnlen)16); + return 0; + } + +/* Answer the query */ + + nb = ilaenv_(&c__1, "ZHETRF_AA_2STAGE", uplo, n, &c_n1, &c_n1, &c_n1, ( + ftnlen)16, (ftnlen)1); + if (*info == 0) { + if (tquery) { + i__1 = (nb * 3 + 1) * *n; + tb[1].r = (doublereal) i__1, tb[1].i = 0.; + } + if (wquery) { + i__1 = *n * nb; + work[1].r = (doublereal) i__1, work[1].i = 0.; + } + } + if (tquery || wquery) { + return 0; + } + +/* Quick return */ + + if (*n == 0) { + return 0; + } + +/* Determine the number of the block size */ + + ldtb = *ltb / *n; + if (ldtb < nb * 3 + 1) { + nb = (ldtb - 1) / 3; + } + if (*lwork < nb * *n) { + nb = *lwork / *n; + } + +/* Determine the number of the block columns */ + + nt = (*n + nb - 1) / nb; + td = nb << 1; + kb = f2cmin(nb,*n); + +/* Initialize vectors/matrices */ + + i__1 = kb; + for (j = 1; j <= i__1; ++j) { + ipiv[j] = j; + } + +/* Save NB */ + + tb[1].r = (doublereal) nb, tb[1].i = 0.; + + if (upper) { + +/* ..................................................... */ +/* Factorize A as U**H*D*U using the upper triangle of A */ +/* ..................................................... */ + + i__1 = nt - 1; + for (j = 0; j <= i__1; ++j) { + +/* Generate Jth column of W and H */ + +/* Computing MIN */ + i__2 = nb, i__3 = *n - j * nb; + kb = f2cmin(i__2,i__3); + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + if (i__ == 1) { +/* H(I,J) = T(I,I)*U(I,J) + T(I+1,I)*U(I+1,J) */ + if (i__ == j - 1) { + jb = nb + kb; + } else { + jb = nb << 1; + } + i__3 = ldtb - 1; + zgemm_("NoTranspose", "NoTranspose", &nb, &kb, &jb, & + c_b14, &tb[td + 1 + i__ * nb * ldtb], &i__3, &a[( + i__ - 1) * nb + 1 + (j * nb + 1) * a_dim1], lda, & + c_b15, &work[i__ * nb + 1], n); + } else { +/* H(I,J) = T(I,I-1)*U(I-1,J) + T(I,I)*U(I,J) + T(I,I+1)*U(I+1,J) */ + if (i__ == j - 1) { + jb = (nb << 1) + kb; + } else { + jb = nb * 3; + } + i__3 = ldtb - 1; + zgemm_("NoTranspose", "NoTranspose", &nb, &kb, &jb, & + c_b14, &tb[td + nb + 1 + (i__ - 1) * nb * ldtb], & + i__3, &a[(i__ - 2) * nb + 1 + (j * nb + 1) * + a_dim1], lda, &c_b15, &work[i__ * nb + 1], n); + } + } + +/* Compute T(J,J) */ + + i__2 = ldtb - 1; + zlacpy_("Upper", &kb, &kb, &a[j * nb + 1 + (j * nb + 1) * a_dim1], + lda, &tb[td + 1 + j * nb * ldtb], &i__2); + if (j > 1) { +/* T(J,J) = U(1:J,J)'*H(1:J) */ + i__2 = (j - 1) * nb; + i__3 = ldtb - 1; + zgemm_("Conjugate transpose", "NoTranspose", &kb, &kb, &i__2, + &c_b23, &a[(j * nb + 1) * a_dim1 + 1], lda, &work[nb + + 1], n, &c_b14, &tb[td + 1 + j * nb * ldtb], &i__3); +/* T(J,J) += U(J,J)'*T(J,J-1)*U(J-1,J) */ + i__2 = ldtb - 1; + zgemm_("Conjugate transpose", "NoTranspose", &kb, &nb, &kb, & + c_b14, &a[(j - 1) * nb + 1 + (j * nb + 1) * a_dim1], + lda, &tb[td + nb + 1 + (j - 1) * nb * ldtb], &i__2, & + c_b15, &work[1], n); + i__2 = ldtb - 1; + zgemm_("NoTranspose", "NoTranspose", &kb, &kb, &nb, &c_b23, & + work[1], n, &a[(j - 2) * nb + 1 + (j * nb + 1) * + a_dim1], lda, &c_b14, &tb[td + 1 + j * nb * ldtb], & + i__2); + } + if (j > 0) { + i__2 = ldtb - 1; + zhegst_(&c__1, "Upper", &kb, &tb[td + 1 + j * nb * ldtb], & + i__2, &a[(j - 1) * nb + 1 + (j * nb + 1) * a_dim1], + lda, &iinfo); + } + +/* Expand T(J,J) into full format */ + + i__2 = kb; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = td + 1 + (j * nb + i__ - 1) * ldtb; + i__4 = td + 1 + (j * nb + i__ - 1) * ldtb; + d__1 = tb[i__4].r; + tb[i__3].r = d__1, tb[i__3].i = 0.; + i__3 = kb; + for (k = i__ + 1; k <= i__3; ++k) { + i__4 = td + (k - i__) + 1 + (j * nb + i__ - 1) * ldtb; + d_cnjg(&z__1, &tb[td - (k - (i__ + 1)) + (j * nb + k - 1) + * ldtb]); + tb[i__4].r = z__1.r, tb[i__4].i = z__1.i; + } + } + + if (j < nt - 1) { + if (j > 0) { + +/* Compute H(J,J) */ + + if (j == 1) { + i__2 = ldtb - 1; + zgemm_("NoTranspose", "NoTranspose", &kb, &kb, &kb, & + c_b14, &tb[td + 1 + j * nb * ldtb], &i__2, &a[ + (j - 1) * nb + 1 + (j * nb + 1) * a_dim1], + lda, &c_b15, &work[j * nb + 1], n); + } else { + i__2 = nb + kb; + i__3 = ldtb - 1; + zgemm_("NoTranspose", "NoTranspose", &kb, &kb, &i__2, + &c_b14, &tb[td + nb + 1 + (j - 1) * nb * ldtb] + , &i__3, &a[(j - 2) * nb + 1 + (j * nb + 1) * + a_dim1], lda, &c_b15, &work[j * nb + 1], n); + } + +/* Update with the previous column */ + + i__2 = *n - (j + 1) * nb; + i__3 = j * nb; + zgemm_("Conjugate transpose", "NoTranspose", &nb, &i__2, & + i__3, &c_b23, &work[nb + 1], n, &a[((j + 1) * nb + + 1) * a_dim1 + 1], lda, &c_b14, &a[j * nb + 1 + ( + (j + 1) * nb + 1) * a_dim1], lda); + } + +/* Copy panel to workspace to call ZGETRF */ + + i__2 = nb; + for (k = 1; k <= i__2; ++k) { + i__3 = *n - (j + 1) * nb; + zcopy_(&i__3, &a[j * nb + k + ((j + 1) * nb + 1) * a_dim1] + , lda, &work[(k - 1) * *n + 1], &c__1); + } + +/* Factorize panel */ + + i__2 = *n - (j + 1) * nb; + zgetrf_(&i__2, &nb, &work[1], n, &ipiv[(j + 1) * nb + 1], & + iinfo); +/* IF (IINFO.NE.0 .AND. INFO.EQ.0) THEN */ +/* INFO = IINFO+(J+1)*NB */ +/* END IF */ + +/* Copy panel back */ + + i__2 = nb; + for (k = 1; k <= i__2; ++k) { + +/* Copy only L-factor */ + + i__3 = *n - k - (j + 1) * nb; + zcopy_(&i__3, &work[k + 1 + (k - 1) * *n], &c__1, &a[j * + nb + k + ((j + 1) * nb + k + 1) * a_dim1], lda); + +/* Transpose U-factor to be copied back into T(J+1, J) */ + + zlacgv_(&k, &work[(k - 1) * *n + 1], &c__1); + } + +/* Compute T(J+1, J), zero out for GEMM update */ + +/* Computing MIN */ + i__2 = nb, i__3 = *n - (j + 1) * nb; + kb = f2cmin(i__2,i__3); + i__2 = ldtb - 1; + zlaset_("Full", &kb, &nb, &c_b15, &c_b15, &tb[td + nb + 1 + j + * nb * ldtb], &i__2); + i__2 = ldtb - 1; + zlacpy_("Upper", &kb, &nb, &work[1], n, &tb[td + nb + 1 + j * + nb * ldtb], &i__2); + if (j > 0) { + i__2 = ldtb - 1; + ztrsm_("R", "U", "N", "U", &kb, &nb, &c_b14, &a[(j - 1) * + nb + 1 + (j * nb + 1) * a_dim1], lda, &tb[td + nb + + 1 + j * nb * ldtb], &i__2); + } + +/* Copy T(J,J+1) into T(J+1, J), both upper/lower for GEMM */ +/* updates */ + + i__2 = nb; + for (k = 1; k <= i__2; ++k) { + i__3 = kb; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = td - nb + k - i__ + 1 + (j * nb + nb + i__ - 1) + * ldtb; + d_cnjg(&z__1, &tb[td + nb + i__ - k + 1 + (j * nb + k + - 1) * ldtb]); + tb[i__4].r = z__1.r, tb[i__4].i = z__1.i; + } + } + zlaset_("Lower", &kb, &nb, &c_b15, &c_b14, &a[j * nb + 1 + (( + j + 1) * nb + 1) * a_dim1], lda); + +/* Apply pivots to trailing submatrix of A */ + + i__2 = kb; + for (k = 1; k <= i__2; ++k) { +/* > Adjust ipiv */ + ipiv[(j + 1) * nb + k] += (j + 1) * nb; + + i1 = (j + 1) * nb + k; + i2 = ipiv[(j + 1) * nb + k]; + if (i1 != i2) { +/* > Apply pivots to previous columns of L */ + i__3 = k - 1; + zswap_(&i__3, &a[(j + 1) * nb + 1 + i1 * a_dim1], & + c__1, &a[(j + 1) * nb + 1 + i2 * a_dim1], & + c__1); +/* > Swap A(I1+1:M, I1) with A(I2, I1+1:M) */ + if (i2 > i1 + 1) { + i__3 = i2 - i1 - 1; + zswap_(&i__3, &a[i1 + (i1 + 1) * a_dim1], lda, &a[ + i1 + 1 + i2 * a_dim1], &c__1); + i__3 = i2 - i1 - 1; + zlacgv_(&i__3, &a[i1 + 1 + i2 * a_dim1], &c__1); + } + i__3 = i2 - i1; + zlacgv_(&i__3, &a[i1 + (i1 + 1) * a_dim1], lda); +/* > Swap A(I2+1:M, I1) with A(I2+1:M, I2) */ + if (i2 < *n) { + i__3 = *n - i2; + zswap_(&i__3, &a[i1 + (i2 + 1) * a_dim1], lda, &a[ + i2 + (i2 + 1) * a_dim1], lda); + } +/* > Swap A(I1, I1) with A(I2, I2) */ + i__3 = i1 + i1 * a_dim1; + piv.r = a[i__3].r, piv.i = a[i__3].i; + i__3 = i1 + i1 * a_dim1; + i__4 = i2 + i2 * a_dim1; + a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; + i__3 = i2 + i2 * a_dim1; + a[i__3].r = piv.r, a[i__3].i = piv.i; +/* > Apply pivots to previous columns of L */ + if (j > 0) { + i__3 = j * nb; + zswap_(&i__3, &a[i1 * a_dim1 + 1], &c__1, &a[i2 * + a_dim1 + 1], &c__1); + } + } + } + } + } + } else { + +/* ..................................................... */ +/* Factorize A as L*D*L**H using the lower triangle of A */ +/* ..................................................... */ + + i__1 = nt - 1; + for (j = 0; j <= i__1; ++j) { + +/* Generate Jth column of W and H */ + +/* Computing MIN */ + i__2 = nb, i__3 = *n - j * nb; + kb = f2cmin(i__2,i__3); + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + if (i__ == 1) { +/* H(I,J) = T(I,I)*L(J,I)' + T(I+1,I)'*L(J,I+1)' */ + if (i__ == j - 1) { + jb = nb + kb; + } else { + jb = nb << 1; + } + i__3 = ldtb - 1; + zgemm_("NoTranspose", "Conjugate transpose", &nb, &kb, & + jb, &c_b14, &tb[td + 1 + i__ * nb * ldtb], &i__3, + &a[j * nb + 1 + ((i__ - 1) * nb + 1) * a_dim1], + lda, &c_b15, &work[i__ * nb + 1], n); + } else { +/* H(I,J) = T(I,I-1)*L(J,I-1)' + T(I,I)*L(J,I)' + T(I,I+1)*L(J,I+1)' */ + if (i__ == j - 1) { + jb = (nb << 1) + kb; + } else { + jb = nb * 3; + } + i__3 = ldtb - 1; + zgemm_("NoTranspose", "Conjugate transpose", &nb, &kb, & + jb, &c_b14, &tb[td + nb + 1 + (i__ - 1) * nb * + ldtb], &i__3, &a[j * nb + 1 + ((i__ - 2) * nb + 1) + * a_dim1], lda, &c_b15, &work[i__ * nb + 1], n); + } + } + +/* Compute T(J,J) */ + + i__2 = ldtb - 1; + zlacpy_("Lower", &kb, &kb, &a[j * nb + 1 + (j * nb + 1) * a_dim1], + lda, &tb[td + 1 + j * nb * ldtb], &i__2); + if (j > 1) { +/* T(J,J) = L(J,1:J)*H(1:J) */ + i__2 = (j - 1) * nb; + i__3 = ldtb - 1; + zgemm_("NoTranspose", "NoTranspose", &kb, &kb, &i__2, &c_b23, + &a[j * nb + 1 + a_dim1], lda, &work[nb + 1], n, & + c_b14, &tb[td + 1 + j * nb * ldtb], &i__3); +/* T(J,J) += L(J,J)*T(J,J-1)*L(J,J-1)' */ + i__2 = ldtb - 1; + zgemm_("NoTranspose", "NoTranspose", &kb, &nb, &kb, &c_b14, & + a[j * nb + 1 + ((j - 1) * nb + 1) * a_dim1], lda, &tb[ + td + nb + 1 + (j - 1) * nb * ldtb], &i__2, &c_b15, & + work[1], n); + i__2 = ldtb - 1; + zgemm_("NoTranspose", "Conjugate transpose", &kb, &kb, &nb, & + c_b23, &work[1], n, &a[j * nb + 1 + ((j - 2) * nb + 1) + * a_dim1], lda, &c_b14, &tb[td + 1 + j * nb * ldtb], + &i__2); + } + if (j > 0) { + i__2 = ldtb - 1; + zhegst_(&c__1, "Lower", &kb, &tb[td + 1 + j * nb * ldtb], & + i__2, &a[j * nb + 1 + ((j - 1) * nb + 1) * a_dim1], + lda, &iinfo); + } + +/* Expand T(J,J) into full format */ + + i__2 = kb; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = td + 1 + (j * nb + i__ - 1) * ldtb; + i__4 = td + 1 + (j * nb + i__ - 1) * ldtb; + d__1 = tb[i__4].r; + tb[i__3].r = d__1, tb[i__3].i = 0.; + i__3 = kb; + for (k = i__ + 1; k <= i__3; ++k) { + i__4 = td - (k - (i__ + 1)) + (j * nb + k - 1) * ldtb; + d_cnjg(&z__1, &tb[td + (k - i__) + 1 + (j * nb + i__ - 1) + * ldtb]); + tb[i__4].r = z__1.r, tb[i__4].i = z__1.i; + } + } + + if (j < nt - 1) { + if (j > 0) { + +/* Compute H(J,J) */ + + if (j == 1) { + i__2 = ldtb - 1; + zgemm_("NoTranspose", "Conjugate transpose", &kb, &kb, + &kb, &c_b14, &tb[td + 1 + j * nb * ldtb], & + i__2, &a[j * nb + 1 + ((j - 1) * nb + 1) * + a_dim1], lda, &c_b15, &work[j * nb + 1], n); + } else { + i__2 = nb + kb; + i__3 = ldtb - 1; + zgemm_("NoTranspose", "Conjugate transpose", &kb, &kb, + &i__2, &c_b14, &tb[td + nb + 1 + (j - 1) * + nb * ldtb], &i__3, &a[j * nb + 1 + ((j - 2) * + nb + 1) * a_dim1], lda, &c_b15, &work[j * nb + + 1], n); + } + +/* Update with the previous column */ + + i__2 = *n - (j + 1) * nb; + i__3 = j * nb; + zgemm_("NoTranspose", "NoTranspose", &i__2, &nb, &i__3, & + c_b23, &a[(j + 1) * nb + 1 + a_dim1], lda, &work[ + nb + 1], n, &c_b14, &a[(j + 1) * nb + 1 + (j * nb + + 1) * a_dim1], lda); + } + +/* Factorize panel */ + + i__2 = *n - (j + 1) * nb; + zgetrf_(&i__2, &nb, &a[(j + 1) * nb + 1 + (j * nb + 1) * + a_dim1], lda, &ipiv[(j + 1) * nb + 1], &iinfo); +/* IF (IINFO.NE.0 .AND. INFO.EQ.0) THEN */ +/* INFO = IINFO+(J+1)*NB */ +/* END IF */ + +/* Compute T(J+1, J), zero out for GEMM update */ + +/* Computing MIN */ + i__2 = nb, i__3 = *n - (j + 1) * nb; + kb = f2cmin(i__2,i__3); + i__2 = ldtb - 1; + zlaset_("Full", &kb, &nb, &c_b15, &c_b15, &tb[td + nb + 1 + j + * nb * ldtb], &i__2); + i__2 = ldtb - 1; + zlacpy_("Upper", &kb, &nb, &a[(j + 1) * nb + 1 + (j * nb + 1) + * a_dim1], lda, &tb[td + nb + 1 + j * nb * ldtb], & + i__2); + if (j > 0) { + i__2 = ldtb - 1; + ztrsm_("R", "L", "C", "U", &kb, &nb, &c_b14, &a[j * nb + + 1 + ((j - 1) * nb + 1) * a_dim1], lda, &tb[td + + nb + 1 + j * nb * ldtb], &i__2); + } + +/* Copy T(J+1,J) into T(J, J+1), both upper/lower for GEMM */ +/* updates */ + + i__2 = nb; + for (k = 1; k <= i__2; ++k) { + i__3 = kb; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = td - nb + k - i__ + 1 + (j * nb + nb + i__ - 1) + * ldtb; + d_cnjg(&z__1, &tb[td + nb + i__ - k + 1 + (j * nb + k + - 1) * ldtb]); + tb[i__4].r = z__1.r, tb[i__4].i = z__1.i; + } + } + zlaset_("Upper", &kb, &nb, &c_b15, &c_b14, &a[(j + 1) * nb + + 1 + (j * nb + 1) * a_dim1], lda); + +/* Apply pivots to trailing submatrix of A */ + + i__2 = kb; + for (k = 1; k <= i__2; ++k) { +/* > Adjust ipiv */ + ipiv[(j + 1) * nb + k] += (j + 1) * nb; + + i1 = (j + 1) * nb + k; + i2 = ipiv[(j + 1) * nb + k]; + if (i1 != i2) { +/* > Apply pivots to previous columns of L */ + i__3 = k - 1; + zswap_(&i__3, &a[i1 + ((j + 1) * nb + 1) * a_dim1], + lda, &a[i2 + ((j + 1) * nb + 1) * a_dim1], + lda); +/* > Swap A(I1+1:M, I1) with A(I2, I1+1:M) */ + if (i2 > i1 + 1) { + i__3 = i2 - i1 - 1; + zswap_(&i__3, &a[i1 + 1 + i1 * a_dim1], &c__1, &a[ + i2 + (i1 + 1) * a_dim1], lda); + i__3 = i2 - i1 - 1; + zlacgv_(&i__3, &a[i2 + (i1 + 1) * a_dim1], lda); + } + i__3 = i2 - i1; + zlacgv_(&i__3, &a[i1 + 1 + i1 * a_dim1], &c__1); +/* > Swap A(I2+1:M, I1) with A(I2+1:M, I2) */ + if (i2 < *n) { + i__3 = *n - i2; + zswap_(&i__3, &a[i2 + 1 + i1 * a_dim1], &c__1, &a[ + i2 + 1 + i2 * a_dim1], &c__1); + } +/* > Swap A(I1, I1) with A(I2, I2) */ + i__3 = i1 + i1 * a_dim1; + piv.r = a[i__3].r, piv.i = a[i__3].i; + i__3 = i1 + i1 * a_dim1; + i__4 = i2 + i2 * a_dim1; + a[i__3].r = a[i__4].r, a[i__3].i = a[i__4].i; + i__3 = i2 + i2 * a_dim1; + a[i__3].r = piv.r, a[i__3].i = piv.i; +/* > Apply pivots to previous columns of L */ + if (j > 0) { + i__3 = j * nb; + zswap_(&i__3, &a[i1 + a_dim1], lda, &a[i2 + + a_dim1], lda); + } + } + } + +/* Apply pivots to previous columns of L */ + +/* CALL ZLASWP( J*NB, A( 1, 1 ), LDA, */ +/* $ (J+1)*NB+1, (J+1)*NB+KB, IPIV, 1 ) */ + } + } + } + +/* Factor the band matrix */ + zgbtrf_(n, n, &nb, &nb, &tb[1], &ldtb, &ipiv2[1], info); + + return 0; + +/* End of ZHETRF_AA_2STAGE */ + +} /* zhetrf_aa_2stage__ */ + diff --git a/lapack-netlib/SRC/zhetrf_rk.c b/lapack-netlib/SRC/zhetrf_rk.c new file mode 100644 index 000000000..4998a7355 --- /dev/null +++ b/lapack-netlib/SRC/zhetrf_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 ZHETRF_RK computes the factorization of a complex Hermitian indefinite matrix using the bounded + Bunch-Kaufman (rook) diagonal pivoting method (BLAS3 blocked algorithm). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHETRF_RK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHETRF_RK( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, */ +/* INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LWORK, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), E ( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > ZHETRF_RK computes the factorization of a complex Hermitian matrix A */ +/* > using the bounded Bunch-Kaufman (rook) diagonal pivoting method: */ +/* > */ +/* > A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T), */ +/* > */ +/* > where U (or L) is unit upper (or lower) triangular matrix, */ +/* > U**H (or L**H) is the conjugate of U (or L), P is a permutation */ +/* > matrix, P**T is the transpose of P, and D is Hermitian 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 */ +/* > Hermitian matrix A is stored: */ +/* > = 'U': Upper triangular */ +/* > = 'L': Lower triangular */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the Hermitian matrix A. */ +/* > If UPLO = 'U': the leading N-by-N upper triangular part */ +/* > of A contains the upper triangular part of the matrix A, */ +/* > and the strictly lower triangular part of A is not */ +/* > referenced. */ +/* > */ +/* > If UPLO = 'L': the leading N-by-N lower triangular part */ +/* > of A contains the lower triangular part of the matrix A, */ +/* > and the strictly upper triangular part of A is not */ +/* > referenced. */ +/* > */ +/* > On exit, contains: */ +/* > a) ONLY diagonal elements of the Hermitian block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > are stored on exit in array E), and */ +/* > b) If UPLO = 'U': factor U in the superdiagonal part of A. */ +/* > If UPLO = 'L': factor L in the subdiagonal part of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is COMPLEX*16 array, dimension (N) */ +/* > On exit, contains the superdiagonal (or subdiagonal) */ +/* > elements of the Hermitian block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) is set to 0; */ +/* > If UPLO = 'L': E(i) = D(i+1,i), i=1:N-1, E(N) is set to 0. */ +/* > */ +/* > NOTE: For 1-by-1 diagonal block D(k), where */ +/* > 1 <= k <= N, the element E(k) is set to 0 in both */ +/* > UPLO = 'U' or UPLO = 'L' cases. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > IPIV describes the permutation matrix P in the factorization */ +/* > of matrix A as follows. The absolute value of IPIV(k) */ +/* > represents the index of row and column that were */ +/* > interchanged with the k-th row and column. The value of UPLO */ +/* > describes the order in which the interchanges were applied. */ +/* > Also, the sign of IPIV represents the block structure of */ +/* > the Hermitian block diagonal matrix D with 1-by-1 or 2-by-2 */ +/* > diagonal blocks which correspond to 1 or 2 interchanges */ +/* > at each factorization step. 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 COMPLEX*16 array, dimension ( MAX(1,LWORK) ). */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of 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 complex16HEcomputational */ + +/* > \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 zhetrf_rk_(char *uplo, integer *n, doublecomplex *a, + integer *lda, doublecomplex *e, integer *ipiv, doublecomplex *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 zhetf2_rk_(char *, integer *, doublecomplex * + , integer *, doublecomplex *, integer *, integer *); + extern logical lsame_(char *, char *); + integer nbmin, iinfo; + extern /* Subroutine */ int zlahef_rk_(char *, integer *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, integer *); + logical upper; + extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *, + doublecomplex *, 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, "ZHETRF_RK", uplo, n, &c_n1, &c_n1, &c_n1, ( + ftnlen)9, (ftnlen)1); + lwkopt = *n * nb; + work[1].r = (doublereal) lwkopt, work[1].i = 0.; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHETRF_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, "ZHETRF_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 ZLAHEF_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 */ + + zlahef_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 */ + + zhetf2_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; + zswap_(&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 ZLAHEF_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; + zlahef_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; + zhetf2_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; + zswap_(&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].r = (doublereal) lwkopt, work[1].i = 0.; + return 0; + +/* End of ZHETRF_RK */ + +} /* zhetrf_rk__ */ + diff --git a/lapack-netlib/SRC/zhetrf_rook.c b/lapack-netlib/SRC/zhetrf_rook.c new file mode 100644 index 000000000..3802dcfee --- /dev/null +++ b/lapack-netlib/SRC/zhetrf_rook.c @@ -0,0 +1,817 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHETRF_ROOK computes the factorization of a complex Hermitian indefinite matrix using the bound +ed Bunch-Kaufman ("rook") diagonal pivoting method (blocked algorithm, calling Level 3 BLAS). */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHETRF_ROOK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHETRF_ROOK( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LWORK, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHETRF_ROOK computes the factorization of a complex Hermitian 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 Hermitian 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 COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the Hermitian matrix A. If UPLO = 'U', the leading */ +/* > N-by-N upper triangular part of A contains the upper */ +/* > triangular part of the matrix A, and the strictly lower */ +/* > triangular part of A is not referenced. If UPLO = 'L', the */ +/* > leading N-by-N lower triangular part of A contains the lower */ +/* > triangular part of the matrix A, and the strictly upper */ +/* > triangular part of A is not referenced. */ +/* > */ +/* > On exit, 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': */ +/* > Only the last KB elements of IPIV are set. */ +/* > */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* > interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and */ +/* > columns k and -IPIV(k) were interchanged and rows and */ +/* > columns k-1 and -IPIV(k-1) were inerchaged, */ +/* > D(k-1:k,k-1:k) is a 2-by-2 diagonal block. */ +/* > */ +/* > If UPLO = 'L': */ +/* > Only the first KB elements of IPIV are set. */ +/* > */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) */ +/* > were interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > */ +/* > If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and */ +/* > columns k and -IPIV(k) were interchanged and rows and */ +/* > columns k+1 and -IPIV(k+1) were inerchaged, */ +/* > D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)). */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The length of WORK. LWORK >=1. For best performance */ +/* > LWORK >= N*NB, where NB is the block size returned by ILAENV. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the optimal size of the WORK array, returns */ +/* > this value as the first entry of the WORK array, and no error */ +/* > message related to LWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) is exactly zero. The factorization */ +/* > has been completed, but the block diagonal matrix D is */ +/* > exactly singular, and division by zero will occur if it */ +/* > is used to solve a system of equations. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16HEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > If UPLO = 'U', then A = U*D*U**T, where */ +/* > U = P(n)*U(n)* ... *P(k)U(k)* ..., */ +/* > i.e., U is a product of terms P(k)*U(k), where k decreases from n to */ +/* > 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* > and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* > defined by IPIV(k), and U(k) is a unit upper triangular matrix, such */ +/* > that if the diagonal block D(k) is of order s (s = 1 or 2), then */ +/* > */ +/* > ( I v 0 ) k-s */ +/* > U(k) = ( 0 I 0 ) s */ +/* > ( 0 0 I ) n-k */ +/* > k-s s n-k */ +/* > */ +/* > If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k). */ +/* > If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k), */ +/* > and A(k,k), and v overwrites A(1:k-2,k-1:k). */ +/* > */ +/* > If UPLO = 'L', then A = L*D*L**T, where */ +/* > L = P(1)*L(1)* ... *P(k)*L(k)* ..., */ +/* > i.e., L is a product of terms P(k)*L(k), where k increases from 1 to */ +/* > n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1 */ +/* > and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as */ +/* > defined by IPIV(k), and L(k) is a unit lower triangular matrix, such */ +/* > that if the diagonal block D(k) is of order s (s = 1 or 2), then */ +/* > */ +/* > ( I 0 0 ) k-1 */ +/* > L(k) = ( 0 I 0 ) s */ +/* > ( 0 v I ) n-k-s+1 */ +/* > k-1 s n-k-s+1 */ +/* > */ +/* > If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k). */ +/* > If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k), */ +/* > and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1). */ +/* > \endverbatim */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > June 2016, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int zhetrf_rook_(char *uplo, integer *n, doublecomplex *a, + integer *lda, integer *ipiv, doublecomplex *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; + extern /* Subroutine */ int zhetf2_rook_(char *, integer *, + doublecomplex *, integer *, integer *, integer *); + integer iws; + extern /* Subroutine */ int zlahef_rook_(char *, integer *, integer *, + integer *, doublecomplex *, integer *, integer *, doublecomplex *, + integer *, integer *); + + +/* -- LAPACK computational routine (version 3.6.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --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, "ZHETRF_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].r = (doublereal) lwkopt, work[1].i = 0.; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHETRF_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, "ZHETRF_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 ZLAHEF_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 */ + + zlahef_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 */ + + zhetf2_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 ZLAHEF_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; + zlahef_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; + zhetf2_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].r = (doublereal) lwkopt, work[1].i = 0.; + return 0; + +/* End of ZHETRF_ROOK */ + +} /* zhetrf_rook__ */ + diff --git a/lapack-netlib/SRC/zhetri.c b/lapack-netlib/SRC/zhetri.c new file mode 100644 index 000000000..8fd8b8f13 --- /dev/null +++ b/lapack-netlib/SRC/zhetri.c @@ -0,0 +1,936 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHETRI */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHETRI + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHETRI( UPLO, N, A, LDA, IPIV, WORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHETRI computes the inverse of a complex Hermitian indefinite matrix */ +/* > A using the factorization A = U*D*U**H or A = L*D*L**H computed by */ +/* > ZHETRF. */ +/* > \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**H; */ +/* > = 'L': Lower triangular, form is A = L*D*L**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the block diagonal matrix D and the multipliers */ +/* > used to obtain the factor U or L as computed by ZHETRF. */ +/* > */ +/* > On exit, if INFO = 0, the (Hermitian) 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 ZHETRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 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 complex16HEcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zhetri_(char *uplo, integer *n, doublecomplex *a, + integer *lda, integer *ipiv, doublecomplex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1; + doublecomplex z__1, z__2; + + /* Local variables */ + doublecomplex temp, akkp1; + doublereal d__; + integer j, k; + doublereal t; + extern logical lsame_(char *, char *); + extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + integer kstep; + extern /* Subroutine */ int zhemv_(char *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, integer *); + logical upper; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zswap_(integer *, doublecomplex *, + integer *, doublecomplex *, 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_("ZHETRI", &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)) { + i__1 = *info + *info * a_dim1; + if (ipiv[*info] > 0 && (a[i__1].r == 0. && a[i__1].i == 0.)) { + return 0; + } +/* L10: */ + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + i__2 = *info + *info * a_dim1; + if (ipiv[*info] > 0 && (a[i__2].r == 0. && a[i__2].i == 0.)) { + return 0; + } +/* L20: */ + } + } + *info = 0; + + if (upper) { + +/* Compute inv(A) from the factorization A = U*D*U**H. */ + +/* 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 L50; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Invert the diagonal block. */ + + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + d__1 = 1. / a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + +/* Compute column K of the inverse. */ + + if (k > 1) { + i__1 = k - 1; + zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1); + i__1 = k - 1; + z__1.r = -1., z__1.i = 0.; + zhemv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1, + &c_b2, &a[k * a_dim1 + 1], &c__1); + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + i__3 = k - 1; + zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k * a_dim1 + 1], & + c__1); + d__1 = z__2.r; + z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + } + kstep = 1; + } else { + +/* 2 x 2 diagonal block */ + +/* Invert the diagonal block. */ + + t = z_abs(&a[k + (k + 1) * a_dim1]); + i__1 = k + k * a_dim1; + ak = a[i__1].r / t; + i__1 = k + 1 + (k + 1) * a_dim1; + akp1 = a[i__1].r / t; + i__1 = k + (k + 1) * a_dim1; + z__1.r = a[i__1].r / t, z__1.i = a[i__1].i / t; + akkp1.r = z__1.r, akkp1.i = z__1.i; + d__ = t * (ak * akp1 - 1.); + i__1 = k + k * a_dim1; + d__1 = akp1 / d__; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = k + 1 + (k + 1) * a_dim1; + d__1 = ak / d__; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = k + (k + 1) * a_dim1; + z__2.r = -akkp1.r, z__2.i = -akkp1.i; + z__1.r = z__2.r / d__, z__1.i = z__2.i / d__; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + +/* Compute columns K and K+1 of the inverse. */ + + if (k > 1) { + i__1 = k - 1; + zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1); + i__1 = k - 1; + z__1.r = -1., z__1.i = 0.; + zhemv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1, + &c_b2, &a[k * a_dim1 + 1], &c__1); + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + i__3 = k - 1; + zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k * a_dim1 + 1], & + c__1); + d__1 = z__2.r; + z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + i__1 = k + (k + 1) * a_dim1; + i__2 = k + (k + 1) * a_dim1; + i__3 = k - 1; + zdotc_(&z__2, &i__3, &a[k * a_dim1 + 1], &c__1, &a[(k + 1) * + a_dim1 + 1], &c__1); + z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + i__1 = k - 1; + zcopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], & + c__1); + i__1 = k - 1; + z__1.r = -1., z__1.i = 0.; + zhemv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1, + &c_b2, &a[(k + 1) * a_dim1 + 1], &c__1); + i__1 = k + 1 + (k + 1) * a_dim1; + i__2 = k + 1 + (k + 1) * a_dim1; + i__3 = k - 1; + zdotc_(&z__2, &i__3, &work[1], &c__1, &a[(k + 1) * a_dim1 + 1] + , &c__1); + d__1 = z__2.r; + z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + } + 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; + zswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + 1], & + c__1); + i__1 = k - 1; + for (j = kp + 1; j <= i__1; ++j) { + d_cnjg(&z__1, &a[j + k * a_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + i__2 = j + k * a_dim1; + d_cnjg(&z__1, &a[kp + j * a_dim1]); + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = kp + j * a_dim1; + a[i__2].r = temp.r, a[i__2].i = temp.i; +/* L40: */ + } + i__1 = kp + k * a_dim1; + d_cnjg(&z__1, &a[kp + k * a_dim1]); + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + i__1 = k + k * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + k * a_dim1; + i__2 = kp + kp * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + kp * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + if (kstep == 2) { + i__1 = k + (k + 1) * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + (k + 1) * a_dim1; + i__2 = kp + (k + 1) * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + (k + 1) * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + } + } + + k += kstep; + goto L30; +L50: + + ; + } else { + +/* Compute inv(A) from the factorization A = L*D*L**H. */ + +/* 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; +L60: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L80; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Invert the diagonal block. */ + + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + d__1 = 1. / a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + +/* Compute column K of the inverse. */ + + if (k < *n) { + i__1 = *n - k; + zcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1); + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zhemv_(uplo, &i__1, &z__1, &a[k + 1 + (k + 1) * a_dim1], lda, + &work[1], &c__1, &c_b2, &a[k + 1 + k * a_dim1], &c__1); + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + i__3 = *n - k; + zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k + 1 + k * a_dim1], + &c__1); + d__1 = z__2.r; + z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + } + kstep = 1; + } else { + +/* 2 x 2 diagonal block */ + +/* Invert the diagonal block. */ + + t = z_abs(&a[k + (k - 1) * a_dim1]); + i__1 = k - 1 + (k - 1) * a_dim1; + ak = a[i__1].r / t; + i__1 = k + k * a_dim1; + akp1 = a[i__1].r / t; + i__1 = k + (k - 1) * a_dim1; + z__1.r = a[i__1].r / t, z__1.i = a[i__1].i / t; + akkp1.r = z__1.r, akkp1.i = z__1.i; + d__ = t * (ak * akp1 - 1.); + i__1 = k - 1 + (k - 1) * a_dim1; + d__1 = akp1 / d__; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = k + k * a_dim1; + d__1 = ak / d__; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = k + (k - 1) * a_dim1; + z__2.r = -akkp1.r, z__2.i = -akkp1.i; + z__1.r = z__2.r / d__, z__1.i = z__2.i / d__; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + +/* Compute columns K-1 and K of the inverse. */ + + if (k < *n) { + i__1 = *n - k; + zcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1); + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zhemv_(uplo, &i__1, &z__1, &a[k + 1 + (k + 1) * a_dim1], lda, + &work[1], &c__1, &c_b2, &a[k + 1 + k * a_dim1], &c__1); + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + i__3 = *n - k; + zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k + 1 + k * a_dim1], + &c__1); + d__1 = z__2.r; + z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + i__1 = k + (k - 1) * a_dim1; + i__2 = k + (k - 1) * a_dim1; + i__3 = *n - k; + zdotc_(&z__2, &i__3, &a[k + 1 + k * a_dim1], &c__1, &a[k + 1 + + (k - 1) * a_dim1], &c__1); + z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + i__1 = *n - k; + zcopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], & + c__1); + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zhemv_(uplo, &i__1, &z__1, &a[k + 1 + (k + 1) * a_dim1], lda, + &work[1], &c__1, &c_b2, &a[k + 1 + (k - 1) * a_dim1], + &c__1); + i__1 = k - 1 + (k - 1) * a_dim1; + i__2 = k - 1 + (k - 1) * a_dim1; + i__3 = *n - k; + zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k + 1 + (k - 1) * + a_dim1], &c__1); + d__1 = z__2.r; + z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + } + 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; + zswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + kp * + a_dim1], &c__1); + } + i__1 = kp - 1; + for (j = k + 1; j <= i__1; ++j) { + d_cnjg(&z__1, &a[j + k * a_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + i__2 = j + k * a_dim1; + d_cnjg(&z__1, &a[kp + j * a_dim1]); + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = kp + j * a_dim1; + a[i__2].r = temp.r, a[i__2].i = temp.i; +/* L70: */ + } + i__1 = kp + k * a_dim1; + d_cnjg(&z__1, &a[kp + k * a_dim1]); + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + i__1 = k + k * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + k * a_dim1; + i__2 = kp + kp * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + kp * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + if (kstep == 2) { + i__1 = k + (k - 1) * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + (k - 1) * a_dim1; + i__2 = kp + (k - 1) * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + (k - 1) * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + } + } + + k -= kstep; + goto L60; +L80: + ; + } + + return 0; + +/* End of ZHETRI */ + +} /* zhetri_ */ + diff --git a/lapack-netlib/SRC/zhetri2.c b/lapack-netlib/SRC/zhetri2.c new file mode 100644 index 000000000..03f801b15 --- /dev/null +++ b/lapack-netlib/SRC/zhetri2.c @@ -0,0 +1,608 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHETRI2 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHETRI2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHETRI2( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LWORK, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHETRI2 computes the inverse of a COMPLEX*16 hermitian indefinite matrix */ +/* > A using the factorization A = U*D*U**T or A = L*D*L**T computed by */ +/* > ZHETRF. ZHETRI2 set the LEADING DIMENSION of the workspace */ +/* > before calling ZHETRI2X 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 COMPLEX*16 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 ZHETRF. */ +/* > */ +/* > 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 ZHETRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 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 complex16HEcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zhetri2_(char *uplo, integer *n, doublecomplex *a, + integer *lda, integer *ipiv, doublecomplex *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1; + + /* Local variables */ + extern /* Subroutine */ int zhetri2x_(char *, integer *, doublecomplex *, + integer *, integer *, doublecomplex *, 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 zhetri_(char *, integer *, doublecomplex *, + integer *, integer *, doublecomplex *, 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, "ZHETRF", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, + (ftnlen)1); + if (nbmax >= *n) { + minsize = *n; + } else { + minsize = (*n + nbmax + 1) * (nbmax + 3); + } + + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*lwork < minsize && ! lquery) { + *info = -7; + } + +/* Quick return if possible */ + + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHETRI2", &i__1, (ftnlen)7); + return 0; + } else if (lquery) { + work[1].r = (doublereal) minsize, work[1].i = 0.; + return 0; + } + if (*n == 0) { + return 0; + } + if (nbmax >= *n) { + zhetri_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], info); + } else { + zhetri2x_(uplo, n, &a[a_offset], lda, &ipiv[1], &work[1], &nbmax, + info); + } + return 0; + +/* End of ZHETRI2 */ + +} /* zhetri2_ */ + diff --git a/lapack-netlib/SRC/zhetri2x.c b/lapack-netlib/SRC/zhetri2x.c new file mode 100644 index 000000000..d6b07ccc5 --- /dev/null +++ b/lapack-netlib/SRC/zhetri2x.c @@ -0,0 +1,1271 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHETRI2X */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHETRI2X + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHETRI2X( UPLO, N, A, LDA, IPIV, WORK, NB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N, NB */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), WORK( N+NB+1,* ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHETRI2X computes the inverse of a COMPLEX*16 Hermitian indefinite matrix */ +/* > A using the factorization A = U*D*U**H or A = L*D*L**H computed by */ +/* > ZHETRF. */ +/* > \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**H; */ +/* > = 'L': Lower triangular, form is A = L*D*L**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the NNB diagonal matrix D and the multipliers */ +/* > used to obtain the factor U or L as computed by ZHETRF. */ +/* > */ +/* > 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 ZHETRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 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 complex16HEcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zhetri2x_(char *uplo, integer *n, doublecomplex *a, + integer *lda, integer *ipiv, doublecomplex *work, integer *nb, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, work_dim1, work_offset, i__1, i__2, i__3, i__4, + i__5, i__6; + doublereal d__1; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + integer invd; + doublecomplex akkp1; + extern /* Subroutine */ int zheswapr_(char *, integer *, doublecomplex *, + integer *, integer *, integer *); + doublecomplex d__; + integer i__, j, k; + doublecomplex t; + extern logical lsame_(char *, char *); + integer iinfo; + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + integer count; + logical upper; + extern /* Subroutine */ int ztrmm_(char *, char *, char *, char *, + integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *); + doublecomplex ak, u01_i_j__; + integer u11; + doublecomplex u11_i_j__; + integer ip; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), ztrtri_( + char *, char *, integer *, doublecomplex *, integer *, integer *); + integer nnb, cut; + doublecomplex akp1, u01_ip1_j__, u11_ip1_j__; + extern /* Subroutine */ int zsyconv_(char *, char *, integer *, + doublecomplex *, integer *, integer *, doublecomplex *, integer *); + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --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_("ZHETRI2X", &i__1, (ftnlen)8); + return 0; + } + if (*n == 0) { + return 0; + } + +/* Convert A */ +/* Workspace got Non-diag elements of D */ + + zsyconv_(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)) { + i__1 = *info + *info * a_dim1; + if (ipiv[*info] > 0 && (a[i__1].r == 0. && a[i__1].i == 0.)) { + return 0; + } + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + i__2 = *info + *info * a_dim1; + if (ipiv[*info] > 0 && (a[i__2].r == 0. && a[i__2].i == 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**H)*inv(D)*inv(U)*P**H. */ + + ztrtri_(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 */ + i__1 = k + invd * work_dim1; + i__2 = k + k * a_dim1; + d__1 = 1. / a[i__2].r; + work[i__1].r = d__1, work[i__1].i = 0.; + i__1 = k + (invd + 1) * work_dim1; + work[i__1].r = 0., work[i__1].i = 0.; + ++k; + } else { +/* 2 x 2 diagonal NNB */ + d__1 = z_abs(&work[k + 1 + work_dim1]); + t.r = d__1, t.i = 0.; + i__1 = k + k * a_dim1; + d__1 = a[i__1].r; + z__2.r = d__1, z__2.i = 0.; + z_div(&z__1, &z__2, &t); + ak.r = z__1.r, ak.i = z__1.i; + i__1 = k + 1 + (k + 1) * a_dim1; + d__1 = a[i__1].r; + z__2.r = d__1, z__2.i = 0.; + z_div(&z__1, &z__2, &t); + akp1.r = z__1.r, akp1.i = z__1.i; + z_div(&z__1, &work[k + 1 + work_dim1], &t); + akkp1.r = z__1.r, akkp1.i = z__1.i; + z__3.r = ak.r * akp1.r - ak.i * akp1.i, z__3.i = ak.r * + akp1.i + ak.i * akp1.r; + z__2.r = z__3.r - 1., z__2.i = z__3.i; + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + + t.i * z__2.r; + d__.r = z__1.r, d__.i = z__1.i; + i__1 = k + invd * work_dim1; + z_div(&z__1, &akp1, &d__); + work[i__1].r = z__1.r, work[i__1].i = z__1.i; + i__1 = k + 1 + (invd + 1) * work_dim1; + z_div(&z__1, &ak, &d__); + work[i__1].r = z__1.r, work[i__1].i = z__1.i; + i__1 = k + (invd + 1) * work_dim1; + z__2.r = -akkp1.r, z__2.i = -akkp1.i; + z_div(&z__1, &z__2, &d__); + work[i__1].r = z__1.r, work[i__1].i = z__1.i; + i__1 = k + 1 + invd * work_dim1; + d_cnjg(&z__1, &work[k + (invd + 1) * work_dim1]); + work[i__1].r = z__1.r, work[i__1].i = z__1.i; + k += 2; + } + } + +/* inv(U**H) = (inv(U))**H */ + +/* inv(U**H)*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) { + i__3 = i__ + j * work_dim1; + i__4 = i__ + (cut + j) * a_dim1; + work[i__3].r = a[i__4].r, work[i__3].i = a[i__4].i; + } + } + +/* U11 Block */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = u11 + i__ + i__ * work_dim1; + work[i__2].r = 1., work[i__2].i = 0.; + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = u11 + i__ + j * work_dim1; + work[i__3].r = 0., work[i__3].i = 0.; + } + i__2 = nnb; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = u11 + i__ + j * work_dim1; + i__4 = cut + i__ + (cut + j) * a_dim1; + work[i__3].r = a[i__4].r, work[i__3].i = a[i__4].i; + } + } + +/* invD*U01 */ + + i__ = 1; + while(i__ <= cut) { + if (ipiv[i__] > 0) { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + i__2 = i__ + j * work_dim1; + i__3 = i__ + invd * work_dim1; + i__4 = i__ + j * work_dim1; + z__1.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, z__1.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + ++i__; + } else { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + i__2 = i__ + j * work_dim1; + u01_i_j__.r = work[i__2].r, u01_i_j__.i = work[i__2] + .i; + i__2 = i__ + 1 + j * work_dim1; + u01_ip1_j__.r = work[i__2].r, u01_ip1_j__.i = work[ + i__2].i; + i__2 = i__ + j * work_dim1; + i__3 = i__ + invd * work_dim1; + z__2.r = work[i__3].r * u01_i_j__.r - work[i__3].i * + u01_i_j__.i, z__2.i = work[i__3].r * + u01_i_j__.i + work[i__3].i * u01_i_j__.r; + i__4 = i__ + (invd + 1) * work_dim1; + z__3.r = work[i__4].r * u01_ip1_j__.r - work[i__4].i * + u01_ip1_j__.i, z__3.i = work[i__4].r * + u01_ip1_j__.i + work[i__4].i * u01_ip1_j__.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + i__2 = i__ + 1 + j * work_dim1; + i__3 = i__ + 1 + invd * work_dim1; + z__2.r = work[i__3].r * u01_i_j__.r - work[i__3].i * + u01_i_j__.i, z__2.i = work[i__3].r * + u01_i_j__.i + work[i__3].i * u01_i_j__.r; + i__4 = i__ + 1 + (invd + 1) * work_dim1; + z__3.r = work[i__4].r * u01_ip1_j__.r - work[i__4].i * + u01_ip1_j__.i, z__3.i = work[i__4].r * + u01_ip1_j__.i + work[i__4].i * u01_ip1_j__.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + i__ += 2; + } + } + +/* invD1*U11 */ + + i__ = 1; + while(i__ <= nnb) { + if (ipiv[cut + i__] > 0) { + i__1 = nnb; + for (j = i__; j <= i__1; ++j) { + i__2 = u11 + i__ + j * work_dim1; + i__3 = cut + i__ + invd * work_dim1; + i__4 = u11 + i__ + j * work_dim1; + z__1.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, z__1.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + ++i__; + } else { + i__1 = nnb; + for (j = i__; j <= i__1; ++j) { + i__2 = u11 + i__ + j * work_dim1; + u11_i_j__.r = work[i__2].r, u11_i_j__.i = work[i__2] + .i; + i__2 = u11 + i__ + 1 + j * work_dim1; + u11_ip1_j__.r = work[i__2].r, u11_ip1_j__.i = work[ + i__2].i; + i__2 = u11 + i__ + j * work_dim1; + i__3 = cut + i__ + invd * work_dim1; + i__4 = u11 + i__ + j * work_dim1; + z__2.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, z__2.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + i__5 = cut + i__ + (invd + 1) * work_dim1; + i__6 = u11 + i__ + 1 + j * work_dim1; + z__3.r = work[i__5].r * work[i__6].r - work[i__5].i * + work[i__6].i, z__3.i = work[i__5].r * work[ + i__6].i + work[i__5].i * work[i__6].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + i__2 = u11 + i__ + 1 + j * work_dim1; + i__3 = cut + i__ + 1 + invd * work_dim1; + z__2.r = work[i__3].r * u11_i_j__.r - work[i__3].i * + u11_i_j__.i, z__2.i = work[i__3].r * + u11_i_j__.i + work[i__3].i * u11_i_j__.r; + i__4 = cut + i__ + 1 + (invd + 1) * work_dim1; + z__3.r = work[i__4].r * u11_ip1_j__.r - work[i__4].i * + u11_ip1_j__.i, z__3.i = work[i__4].r * + u11_ip1_j__.i + work[i__4].i * u11_ip1_j__.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + i__ += 2; + } + } + +/* U11**H*invD1*U11->U11 */ + + i__1 = *n + *nb + 1; + ztrmm_("L", "U", "C", "U", &nnb, &nnb, &c_b1, &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) { + i__3 = cut + i__ + (cut + j) * a_dim1; + i__4 = u11 + i__ + j * work_dim1; + a[i__3].r = work[i__4].r, a[i__3].i = work[i__4].i; + } + } + +/* U01**H*invD*U01->A(CUT+I,CUT+J) */ + + i__1 = *n + *nb + 1; + i__2 = *n + *nb + 1; + zgemm_("C", "N", &nnb, &nnb, &cut, &c_b1, &a[(cut + 1) * a_dim1 + + 1], lda, &work[work_offset], &i__1, &c_b2, &work[u11 + 1 + + work_dim1], &i__2); + +/* U11 = U11**H*invD1*U11 + U01**H*invD*U01 */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = i__; j <= i__2; ++j) { + i__3 = cut + i__ + (cut + j) * a_dim1; + i__4 = cut + i__ + (cut + j) * a_dim1; + i__5 = u11 + i__ + j * work_dim1; + z__1.r = a[i__4].r + work[i__5].r, z__1.i = a[i__4].i + + work[i__5].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + +/* U01 = U00**H*invD0*U01 */ + + i__1 = *n + *nb + 1; + ztrmm_("L", uplo, "C", "U", &cut, &nnb, &c_b1, &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) { + i__3 = i__ + (cut + j) * a_dim1; + i__4 = i__ + j * work_dim1; + a[i__3].r = work[i__4].r, a[i__3].i = work[i__4].i; + } + } + +/* Next Block */ + + } + +/* Apply PERMUTATIONS P and P**H: P * inv(U**H)*inv(D)*inv(U) *P**H */ + + i__ = 1; + while(i__ <= *n) { + if (ipiv[i__] > 0) { + ip = ipiv[i__]; + if (i__ < ip) { + zheswapr_(uplo, n, &a[a_offset], lda, &i__, &ip); + } + if (i__ > ip) { + zheswapr_(uplo, n, &a[a_offset], lda, &ip, &i__); + } + } else { + ip = -ipiv[i__]; + ++i__; + if (i__ - 1 < ip) { + i__1 = i__ - 1; + zheswapr_(uplo, n, &a[a_offset], lda, &i__1, &ip); + } + if (i__ - 1 > ip) { + i__1 = i__ - 1; + zheswapr_(uplo, n, &a[a_offset], lda, &ip, &i__1); + } + } + ++i__; + } + } else { + +/* LOWER... */ + +/* invA = P * inv(U**H)*inv(D)*inv(U)*P**H. */ + + ztrtri_(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 */ + i__1 = k + invd * work_dim1; + i__2 = k + k * a_dim1; + d__1 = 1. / a[i__2].r; + work[i__1].r = d__1, work[i__1].i = 0.; + i__1 = k + (invd + 1) * work_dim1; + work[i__1].r = 0., work[i__1].i = 0.; + --k; + } else { +/* 2 x 2 diagonal NNB */ + d__1 = z_abs(&work[k - 1 + work_dim1]); + t.r = d__1, t.i = 0.; + i__1 = k - 1 + (k - 1) * a_dim1; + d__1 = a[i__1].r; + z__2.r = d__1, z__2.i = 0.; + z_div(&z__1, &z__2, &t); + ak.r = z__1.r, ak.i = z__1.i; + i__1 = k + k * a_dim1; + d__1 = a[i__1].r; + z__2.r = d__1, z__2.i = 0.; + z_div(&z__1, &z__2, &t); + akp1.r = z__1.r, akp1.i = z__1.i; + z_div(&z__1, &work[k - 1 + work_dim1], &t); + akkp1.r = z__1.r, akkp1.i = z__1.i; + z__3.r = ak.r * akp1.r - ak.i * akp1.i, z__3.i = ak.r * + akp1.i + ak.i * akp1.r; + z__2.r = z__3.r - 1., z__2.i = z__3.i; + z__1.r = t.r * z__2.r - t.i * z__2.i, z__1.i = t.r * z__2.i + + t.i * z__2.r; + d__.r = z__1.r, d__.i = z__1.i; + i__1 = k - 1 + invd * work_dim1; + z_div(&z__1, &akp1, &d__); + work[i__1].r = z__1.r, work[i__1].i = z__1.i; + i__1 = k + invd * work_dim1; + z_div(&z__1, &ak, &d__); + work[i__1].r = z__1.r, work[i__1].i = z__1.i; + i__1 = k + (invd + 1) * work_dim1; + z__2.r = -akkp1.r, z__2.i = -akkp1.i; + z_div(&z__1, &z__2, &d__); + work[i__1].r = z__1.r, work[i__1].i = z__1.i; + i__1 = k - 1 + (invd + 1) * work_dim1; + d_cnjg(&z__1, &work[k + (invd + 1) * work_dim1]); + work[i__1].r = z__1.r, work[i__1].i = z__1.i; + k += -2; + } + } + +/* inv(U**H) = (inv(U))**H */ + +/* inv(U**H)*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) { + i__3 = i__ + j * work_dim1; + i__4 = cut + nnb + i__ + (cut + j) * a_dim1; + work[i__3].r = a[i__4].r, work[i__3].i = a[i__4].i; + } + } +/* L11 Block */ + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = u11 + i__ + i__ * work_dim1; + work[i__2].r = 1., work[i__2].i = 0.; + i__2 = nnb; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = u11 + i__ + j * work_dim1; + work[i__3].r = 0., work[i__3].i = 0.; + } + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = u11 + i__ + j * work_dim1; + i__4 = cut + i__ + (cut + j) * a_dim1; + work[i__3].r = a[i__4].r, work[i__3].i = a[i__4].i; + } + } + +/* 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) { + i__2 = i__ + j * work_dim1; + i__3 = cut + nnb + i__ + invd * work_dim1; + i__4 = i__ + j * work_dim1; + z__1.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, z__1.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + --i__; + } else { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + i__2 = i__ + j * work_dim1; + u01_i_j__.r = work[i__2].r, u01_i_j__.i = work[i__2] + .i; + i__2 = i__ - 1 + j * work_dim1; + u01_ip1_j__.r = work[i__2].r, u01_ip1_j__.i = work[ + i__2].i; + i__2 = i__ + j * work_dim1; + i__3 = cut + nnb + i__ + invd * work_dim1; + z__2.r = work[i__3].r * u01_i_j__.r - work[i__3].i * + u01_i_j__.i, z__2.i = work[i__3].r * + u01_i_j__.i + work[i__3].i * u01_i_j__.r; + i__4 = cut + nnb + i__ + (invd + 1) * work_dim1; + z__3.r = work[i__4].r * u01_ip1_j__.r - work[i__4].i * + u01_ip1_j__.i, z__3.i = work[i__4].r * + u01_ip1_j__.i + work[i__4].i * u01_ip1_j__.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + i__2 = i__ - 1 + j * work_dim1; + i__3 = cut + nnb + i__ - 1 + (invd + 1) * work_dim1; + z__2.r = work[i__3].r * u01_i_j__.r - work[i__3].i * + u01_i_j__.i, z__2.i = work[i__3].r * + u01_i_j__.i + work[i__3].i * u01_i_j__.r; + i__4 = cut + nnb + i__ - 1 + invd * work_dim1; + z__3.r = work[i__4].r * u01_ip1_j__.r - work[i__4].i * + u01_ip1_j__.i, z__3.i = work[i__4].r * + u01_ip1_j__.i + work[i__4].i * u01_ip1_j__.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + i__ += -2; + } + } + +/* invD1*L11 */ + + i__ = nnb; + while(i__ >= 1) { + if (ipiv[cut + i__] > 0) { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + i__2 = u11 + i__ + j * work_dim1; + i__3 = cut + i__ + invd * work_dim1; + i__4 = u11 + i__ + j * work_dim1; + z__1.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, z__1.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + --i__; + } else { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + i__2 = u11 + i__ + j * work_dim1; + u11_i_j__.r = work[i__2].r, u11_i_j__.i = work[i__2] + .i; + i__2 = u11 + i__ - 1 + j * work_dim1; + u11_ip1_j__.r = work[i__2].r, u11_ip1_j__.i = work[ + i__2].i; + i__2 = u11 + i__ + j * work_dim1; + i__3 = cut + i__ + invd * work_dim1; + i__4 = u11 + i__ + j * work_dim1; + z__2.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, z__2.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + i__5 = cut + i__ + (invd + 1) * work_dim1; + z__3.r = work[i__5].r * u11_ip1_j__.r - work[i__5].i * + u11_ip1_j__.i, z__3.i = work[i__5].r * + u11_ip1_j__.i + work[i__5].i * u11_ip1_j__.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + i__2 = u11 + i__ - 1 + j * work_dim1; + i__3 = cut + i__ - 1 + (invd + 1) * work_dim1; + z__2.r = work[i__3].r * u11_i_j__.r - work[i__3].i * + u11_i_j__.i, z__2.i = work[i__3].r * + u11_i_j__.i + work[i__3].i * u11_i_j__.r; + i__4 = cut + i__ - 1 + invd * work_dim1; + z__3.r = work[i__4].r * u11_ip1_j__.r - work[i__4].i * + u11_ip1_j__.i, z__3.i = work[i__4].r * + u11_ip1_j__.i + work[i__4].i * u11_ip1_j__.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + i__ += -2; + } + } + +/* L11**H*invD1*L11->L11 */ + + i__1 = *n + *nb + 1; + ztrmm_("L", uplo, "C", "U", &nnb, &nnb, &c_b1, &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) { + i__3 = cut + i__ + (cut + j) * a_dim1; + i__4 = u11 + i__ + j * work_dim1; + a[i__3].r = work[i__4].r, a[i__3].i = work[i__4].i; + } + } + + if (cut + nnb < *n) { + +/* L21**H*invD2*L21->A(CUT+I,CUT+J) */ + + i__1 = *n - nnb - cut; + i__2 = *n + *nb + 1; + i__3 = *n + *nb + 1; + zgemm_("C", "N", &nnb, &nnb, &i__1, &c_b1, &a[cut + nnb + 1 + + (cut + 1) * a_dim1], lda, &work[work_offset], &i__2, & + c_b2, &work[u11 + 1 + work_dim1], &i__3); + +/* L11 = L11**H*invD1*L11 + U01**H*invD*U01 */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = cut + i__ + (cut + j) * a_dim1; + i__4 = cut + i__ + (cut + j) * a_dim1; + i__5 = u11 + i__ + j * work_dim1; + z__1.r = a[i__4].r + work[i__5].r, z__1.i = a[i__4].i + + work[i__5].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + +/* L01 = L22**H*invD2*L21 */ + + i__1 = *n - nnb - cut; + i__2 = *n + *nb + 1; + ztrmm_("L", uplo, "C", "U", &i__1, &nnb, &c_b1, &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) { + i__3 = cut + nnb + i__ + (cut + j) * a_dim1; + i__4 = i__ + j * work_dim1; + a[i__3].r = work[i__4].r, a[i__3].i = work[i__4].i; + } + } + } else { + +/* L11 = L11**H*invD1*L11 */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = cut + i__ + (cut + j) * a_dim1; + i__4 = u11 + i__ + j * work_dim1; + a[i__3].r = work[i__4].r, a[i__3].i = work[i__4].i; + } + } + } + +/* Next Block */ + + cut += nnb; + } + +/* Apply PERMUTATIONS P and P**H: P * inv(U**H)*inv(D)*inv(U) *P**H */ + + i__ = *n; + while(i__ >= 1) { + if (ipiv[i__] > 0) { + ip = ipiv[i__]; + if (i__ < ip) { + zheswapr_(uplo, n, &a[a_offset], lda, &i__, &ip); + } + if (i__ > ip) { + zheswapr_(uplo, n, &a[a_offset], lda, &ip, &i__); + } + } else { + ip = -ipiv[i__]; + if (i__ < ip) { + zheswapr_(uplo, n, &a[a_offset], lda, &i__, &ip); + } + if (i__ > ip) { + zheswapr_(uplo, n, &a[a_offset], lda, &ip, &i__); + } + --i__; + } + --i__; + } + } + + return 0; + +/* End of ZHETRI2X */ + +} /* zhetri2x_ */ + diff --git a/lapack-netlib/SRC/zhetri_3.c b/lapack-netlib/SRC/zhetri_3.c new file mode 100644 index 000000000..441318bc3 --- /dev/null +++ b/lapack-netlib/SRC/zhetri_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 ZHETRI_3 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHETRI_3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHETRI_3( UPLO, N, A, LDA, E, IPIV, WORK, LWORK, */ +/* INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LWORK, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), E( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > ZHETRI_3 computes the inverse of a complex Hermitian indefinite */ +/* > matrix A using the factorization computed by ZHETRF_RK or ZHETRF_BK: */ +/* > */ +/* > A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T), */ +/* > */ +/* > where U (or L) is unit upper (or lower) triangular matrix, */ +/* > U**H (or L**H) is the conjugate of U (or L), P is a permutation */ +/* > matrix, P**T is the transpose of P, and D is Hermitian and block */ +/* > diagonal with 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > ZHETRI_3 sets the leading dimension of the workspace before calling */ +/* > ZHETRI_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 COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, diagonal of the block diagonal matrix D and */ +/* > factors U or L as computed by ZHETRF_RK and ZHETRF_BK: */ +/* > a) ONLY diagonal elements of the Hermitian block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > 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 Hermitian 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 COMPLEX*16 array, dimension (N) */ +/* > On entry, contains the superdiagonal (or subdiagonal) */ +/* > elements of the Hermitian block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) 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 ZHETRF_RK or ZHETRF_BK. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 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 complex16HEcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > \verbatim */ +/* > */ +/* > November 2017, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int zhetri_3_(char *uplo, integer *n, doublecomplex *a, + integer *lda, doublecomplex *e, integer *ipiv, doublecomplex *work, + integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + + /* Local variables */ + extern /* Subroutine */ int zhetri_3x_(char *, integer *, doublecomplex * + , integer *, doublecomplex *, integer *, doublecomplex *, integer + *, integer *); + extern logical lsame_(char *, char *); + 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, "ZHETRI_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_("ZHETRI_3", &i__1, (ftnlen)8); + return 0; + } else if (lquery) { + work[1].r = (doublereal) lwkopt, work[1].i = 0.; + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + zhetri_3x_(uplo, n, &a[a_offset], lda, &e[1], &ipiv[1], &work[1], &nb, + info); + + work[1].r = (doublereal) lwkopt, work[1].i = 0.; + + return 0; + +/* End of ZHETRI_3 */ + +} /* zhetri_3__ */ + diff --git a/lapack-netlib/SRC/zhetri_3x.c b/lapack-netlib/SRC/zhetri_3x.c new file mode 100644 index 000000000..5cd2a4593 --- /dev/null +++ b/lapack-netlib/SRC/zhetri_3x.c @@ -0,0 +1,1312 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHETRI_3X */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHETRI_3X + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHETRI_3X( UPLO, N, A, LDA, E, IPIV, WORK, NB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N, NB */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), E( * ), WORK( N+NB+1, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > ZHETRI_3X computes the inverse of a complex Hermitian indefinite */ +/* > matrix A using the factorization computed by ZHETRF_RK or ZHETRF_BK: */ +/* > */ +/* > A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T), */ +/* > */ +/* > where U (or L) is unit upper (or lower) triangular matrix, */ +/* > U**H (or L**H) is the conjugate of U (or L), P is a permutation */ +/* > matrix, P**T is the transpose of P, and D is Hermitian 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 COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, diagonal of the block diagonal matrix D and */ +/* > factors U or L as computed by ZHETRF_RK and ZHETRF_BK: */ +/* > a) ONLY diagonal elements of the Hermitian block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > 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 Hermitian 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 COMPLEX*16 array, dimension (N) */ +/* > On entry, contains the superdiagonal (or subdiagonal) */ +/* > elements of the Hermitian block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i), i=2:N, E(1) 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 ZHETRF_RK or ZHETRF_BK. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 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 complex16HEcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > \verbatim */ +/* > */ +/* > June 2017, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int zhetri_3x_(char *uplo, integer *n, doublecomplex *a, + integer *lda, doublecomplex *e, integer *ipiv, doublecomplex *work, + integer *nb, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, work_dim1, work_offset, i__1, i__2, i__3, i__4, + i__5, i__6; + doublereal d__1; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + integer invd; + doublecomplex akkp1; + extern /* Subroutine */ int zheswapr_(char *, integer *, doublecomplex *, + integer *, integer *, integer *); + doublecomplex d__; + integer i__, j, k; + doublereal t; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + logical upper; + extern /* Subroutine */ int ztrmm_(char *, char *, char *, char *, + integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *); + doublereal ak; + doublecomplex u01_i_j__; + integer u11; + doublecomplex u11_i_j__; + integer ip; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + integer icount; + extern /* Subroutine */ int ztrtri_(char *, char *, integer *, + doublecomplex *, integer *, integer *); + integer nnb, cut; + doublereal akp1; + doublecomplex 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_("ZHETRI_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) { + i__2 = k + work_dim1; + i__3 = k; + work[i__2].r = e[i__3].r, work[i__2].i = e[i__3].i; + } + +/* 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)) { + i__1 = *info + *info * a_dim1; + if (ipiv[*info] > 0 && (a[i__1].r == 0. && a[i__1].i == 0.)) { + return 0; + } + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + i__2 = *info + *info * a_dim1; + if (ipiv[*info] > 0 && (a[i__2].r == 0. && a[i__2].i == 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**H) * inv(D) * inv(U) * P**T. */ + + ztrtri_(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 */ + i__1 = k + invd * work_dim1; + i__2 = k + k * a_dim1; + d__1 = 1. / a[i__2].r; + work[i__1].r = d__1, work[i__1].i = 0.; + i__1 = k + (invd + 1) * work_dim1; + work[i__1].r = 0., work[i__1].i = 0.; + } else { +/* 2 x 2 diagonal NNB */ + t = z_abs(&work[k + 1 + work_dim1]); + i__1 = k + k * a_dim1; + ak = a[i__1].r / t; + i__1 = k + 1 + (k + 1) * a_dim1; + akp1 = a[i__1].r / t; + i__1 = k + 1 + work_dim1; + z__1.r = work[i__1].r / t, z__1.i = work[i__1].i / t; + akkp1.r = z__1.r, akkp1.i = z__1.i; + d__1 = ak * akp1; + z__2.r = d__1 - 1., z__2.i = 0.; + z__1.r = t * z__2.r, z__1.i = t * z__2.i; + d__.r = z__1.r, d__.i = z__1.i; + i__1 = k + invd * work_dim1; + z__2.r = akp1, z__2.i = 0.; + z_div(&z__1, &z__2, &d__); + work[i__1].r = z__1.r, work[i__1].i = z__1.i; + i__1 = k + 1 + (invd + 1) * work_dim1; + z__2.r = ak, z__2.i = 0.; + z_div(&z__1, &z__2, &d__); + work[i__1].r = z__1.r, work[i__1].i = z__1.i; + i__1 = k + (invd + 1) * work_dim1; + z__2.r = -akkp1.r, z__2.i = -akkp1.i; + z_div(&z__1, &z__2, &d__); + work[i__1].r = z__1.r, work[i__1].i = z__1.i; + i__1 = k + 1 + invd * work_dim1; + d_cnjg(&z__1, &work[k + (invd + 1) * work_dim1]); + work[i__1].r = z__1.r, work[i__1].i = z__1.i; + ++k; + } + ++k; + } + +/* inv(U**H) = (inv(U))**H */ + +/* inv(U**H) * 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) { + i__3 = i__ + j * work_dim1; + i__4 = i__ + (cut + j) * a_dim1; + work[i__3].r = a[i__4].r, work[i__3].i = a[i__4].i; + } + } + +/* U11 Block */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = u11 + i__ + i__ * work_dim1; + work[i__2].r = 1., work[i__2].i = 0.; + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = u11 + i__ + j * work_dim1; + work[i__3].r = 0., work[i__3].i = 0.; + } + i__2 = nnb; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = u11 + i__ + j * work_dim1; + i__4 = cut + i__ + (cut + j) * a_dim1; + work[i__3].r = a[i__4].r, work[i__3].i = a[i__4].i; + } + } + +/* invD * U01 */ + + i__ = 1; + while(i__ <= cut) { + if (ipiv[i__] > 0) { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + i__2 = i__ + j * work_dim1; + i__3 = i__ + invd * work_dim1; + i__4 = i__ + j * work_dim1; + z__1.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, z__1.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } else { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + i__2 = i__ + j * work_dim1; + u01_i_j__.r = work[i__2].r, u01_i_j__.i = work[i__2] + .i; + i__2 = i__ + 1 + j * work_dim1; + u01_ip1_j__.r = work[i__2].r, u01_ip1_j__.i = work[ + i__2].i; + i__2 = i__ + j * work_dim1; + i__3 = i__ + invd * work_dim1; + z__2.r = work[i__3].r * u01_i_j__.r - work[i__3].i * + u01_i_j__.i, z__2.i = work[i__3].r * + u01_i_j__.i + work[i__3].i * u01_i_j__.r; + i__4 = i__ + (invd + 1) * work_dim1; + z__3.r = work[i__4].r * u01_ip1_j__.r - work[i__4].i * + u01_ip1_j__.i, z__3.i = work[i__4].r * + u01_ip1_j__.i + work[i__4].i * u01_ip1_j__.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + i__2 = i__ + 1 + j * work_dim1; + i__3 = i__ + 1 + invd * work_dim1; + z__2.r = work[i__3].r * u01_i_j__.r - work[i__3].i * + u01_i_j__.i, z__2.i = work[i__3].r * + u01_i_j__.i + work[i__3].i * u01_i_j__.r; + i__4 = i__ + 1 + (invd + 1) * work_dim1; + z__3.r = work[i__4].r * u01_ip1_j__.r - work[i__4].i * + u01_ip1_j__.i, z__3.i = work[i__4].r * + u01_ip1_j__.i + work[i__4].i * u01_ip1_j__.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + ++i__; + } + ++i__; + } + +/* invD1 * U11 */ + + i__ = 1; + while(i__ <= nnb) { + if (ipiv[cut + i__] > 0) { + i__1 = nnb; + for (j = i__; j <= i__1; ++j) { + i__2 = u11 + i__ + j * work_dim1; + i__3 = cut + i__ + invd * work_dim1; + i__4 = u11 + i__ + j * work_dim1; + z__1.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, z__1.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } else { + i__1 = nnb; + for (j = i__; j <= i__1; ++j) { + i__2 = u11 + i__ + j * work_dim1; + u11_i_j__.r = work[i__2].r, u11_i_j__.i = work[i__2] + .i; + i__2 = u11 + i__ + 1 + j * work_dim1; + u11_ip1_j__.r = work[i__2].r, u11_ip1_j__.i = work[ + i__2].i; + i__2 = u11 + i__ + j * work_dim1; + i__3 = cut + i__ + invd * work_dim1; + i__4 = u11 + i__ + j * work_dim1; + z__2.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, z__2.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + i__5 = cut + i__ + (invd + 1) * work_dim1; + i__6 = u11 + i__ + 1 + j * work_dim1; + z__3.r = work[i__5].r * work[i__6].r - work[i__5].i * + work[i__6].i, z__3.i = work[i__5].r * work[ + i__6].i + work[i__5].i * work[i__6].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + i__2 = u11 + i__ + 1 + j * work_dim1; + i__3 = cut + i__ + 1 + invd * work_dim1; + z__2.r = work[i__3].r * u11_i_j__.r - work[i__3].i * + u11_i_j__.i, z__2.i = work[i__3].r * + u11_i_j__.i + work[i__3].i * u11_i_j__.r; + i__4 = cut + i__ + 1 + (invd + 1) * work_dim1; + z__3.r = work[i__4].r * u11_ip1_j__.r - work[i__4].i * + u11_ip1_j__.i, z__3.i = work[i__4].r * + u11_ip1_j__.i + work[i__4].i * u11_ip1_j__.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + ++i__; + } + ++i__; + } + +/* U11**H * invD1 * U11 -> U11 */ + + i__1 = *n + *nb + 1; + ztrmm_("L", "U", "C", "U", &nnb, &nnb, &c_b1, &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) { + i__3 = cut + i__ + (cut + j) * a_dim1; + i__4 = u11 + i__ + j * work_dim1; + a[i__3].r = work[i__4].r, a[i__3].i = work[i__4].i; + } + } + +/* U01**H * invD * U01 -> A( CUT+I, CUT+J ) */ + + i__1 = *n + *nb + 1; + i__2 = *n + *nb + 1; + zgemm_("C", "N", &nnb, &nnb, &cut, &c_b1, &a[(cut + 1) * a_dim1 + + 1], lda, &work[work_offset], &i__1, &c_b2, &work[u11 + 1 + + work_dim1], &i__2); + +/* U11 = U11**H * invD1 * U11 + U01**H * invD * U01 */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = nnb; + for (j = i__; j <= i__2; ++j) { + i__3 = cut + i__ + (cut + j) * a_dim1; + i__4 = cut + i__ + (cut + j) * a_dim1; + i__5 = u11 + i__ + j * work_dim1; + z__1.r = a[i__4].r + work[i__5].r, z__1.i = a[i__4].i + + work[i__5].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + +/* U01 = U00**H * invD0 * U01 */ + + i__1 = *n + *nb + 1; + ztrmm_("L", uplo, "C", "U", &cut, &nnb, &c_b1, &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) { + i__3 = i__ + (cut + j) * a_dim1; + i__4 = i__ + j * work_dim1; + a[i__3].r = work[i__4].r, a[i__3].i = work[i__4].i; + } + } + +/* Next Block */ + + } + +/* Apply PERMUTATIONS P and P**T: */ +/* P * inv(U**H) * 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) { + zheswapr_(uplo, n, &a[a_offset], lda, &i__, &ip); + } + if (i__ > ip) { + zheswapr_(uplo, n, &a[a_offset], lda, &ip, &i__); + } + } + } + + } else { + +/* Begin Lower */ + +/* inv A = P * inv(L**H) * inv(D) * inv(L) * P**T. */ + + ztrtri_(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 */ + i__1 = k + invd * work_dim1; + i__2 = k + k * a_dim1; + d__1 = 1. / a[i__2].r; + work[i__1].r = d__1, work[i__1].i = 0.; + i__1 = k + (invd + 1) * work_dim1; + work[i__1].r = 0., work[i__1].i = 0.; + } else { +/* 2 x 2 diagonal NNB */ + t = z_abs(&work[k - 1 + work_dim1]); + i__1 = k - 1 + (k - 1) * a_dim1; + ak = a[i__1].r / t; + i__1 = k + k * a_dim1; + akp1 = a[i__1].r / t; + i__1 = k - 1 + work_dim1; + z__1.r = work[i__1].r / t, z__1.i = work[i__1].i / t; + akkp1.r = z__1.r, akkp1.i = z__1.i; + d__1 = ak * akp1; + z__2.r = d__1 - 1., z__2.i = 0.; + z__1.r = t * z__2.r, z__1.i = t * z__2.i; + d__.r = z__1.r, d__.i = z__1.i; + i__1 = k - 1 + invd * work_dim1; + z__2.r = akp1, z__2.i = 0.; + z_div(&z__1, &z__2, &d__); + work[i__1].r = z__1.r, work[i__1].i = z__1.i; + i__1 = k + invd * work_dim1; + z__2.r = ak, z__2.i = 0.; + z_div(&z__1, &z__2, &d__); + work[i__1].r = z__1.r, work[i__1].i = z__1.i; + i__1 = k + (invd + 1) * work_dim1; + z__2.r = -akkp1.r, z__2.i = -akkp1.i; + z_div(&z__1, &z__2, &d__); + work[i__1].r = z__1.r, work[i__1].i = z__1.i; + i__1 = k - 1 + (invd + 1) * work_dim1; + d_cnjg(&z__1, &work[k + (invd + 1) * work_dim1]); + work[i__1].r = z__1.r, work[i__1].i = z__1.i; + --k; + } + --k; + } + +/* inv(L**H) = (inv(L))**H */ + +/* inv(L**H) * 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) { + i__3 = i__ + j * work_dim1; + i__4 = cut + nnb + i__ + (cut + j) * a_dim1; + work[i__3].r = a[i__4].r, work[i__3].i = a[i__4].i; + } + } + +/* L11 Block */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = u11 + i__ + i__ * work_dim1; + work[i__2].r = 1., work[i__2].i = 0.; + i__2 = nnb; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = u11 + i__ + j * work_dim1; + work[i__3].r = 0., work[i__3].i = 0.; + } + i__2 = i__ - 1; + for (j = 1; j <= i__2; ++j) { + i__3 = u11 + i__ + j * work_dim1; + i__4 = cut + i__ + (cut + j) * a_dim1; + work[i__3].r = a[i__4].r, work[i__3].i = a[i__4].i; + } + } + +/* 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) { + i__2 = i__ + j * work_dim1; + i__3 = cut + nnb + i__ + invd * work_dim1; + i__4 = i__ + j * work_dim1; + z__1.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, z__1.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } else { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + i__2 = i__ + j * work_dim1; + u01_i_j__.r = work[i__2].r, u01_i_j__.i = work[i__2] + .i; + i__2 = i__ - 1 + j * work_dim1; + u01_ip1_j__.r = work[i__2].r, u01_ip1_j__.i = work[ + i__2].i; + i__2 = i__ + j * work_dim1; + i__3 = cut + nnb + i__ + invd * work_dim1; + z__2.r = work[i__3].r * u01_i_j__.r - work[i__3].i * + u01_i_j__.i, z__2.i = work[i__3].r * + u01_i_j__.i + work[i__3].i * u01_i_j__.r; + i__4 = cut + nnb + i__ + (invd + 1) * work_dim1; + z__3.r = work[i__4].r * u01_ip1_j__.r - work[i__4].i * + u01_ip1_j__.i, z__3.i = work[i__4].r * + u01_ip1_j__.i + work[i__4].i * u01_ip1_j__.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + i__2 = i__ - 1 + j * work_dim1; + i__3 = cut + nnb + i__ - 1 + (invd + 1) * work_dim1; + z__2.r = work[i__3].r * u01_i_j__.r - work[i__3].i * + u01_i_j__.i, z__2.i = work[i__3].r * + u01_i_j__.i + work[i__3].i * u01_i_j__.r; + i__4 = cut + nnb + i__ - 1 + invd * work_dim1; + z__3.r = work[i__4].r * u01_ip1_j__.r - work[i__4].i * + u01_ip1_j__.i, z__3.i = work[i__4].r * + u01_ip1_j__.i + work[i__4].i * u01_ip1_j__.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + --i__; + } + --i__; + } + +/* invD1*L11 */ + + i__ = nnb; + while(i__ >= 1) { + if (ipiv[cut + i__] > 0) { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + i__2 = u11 + i__ + j * work_dim1; + i__3 = cut + i__ + invd * work_dim1; + i__4 = u11 + i__ + j * work_dim1; + z__1.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, z__1.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } else { + i__1 = nnb; + for (j = 1; j <= i__1; ++j) { + i__2 = u11 + i__ + j * work_dim1; + u11_i_j__.r = work[i__2].r, u11_i_j__.i = work[i__2] + .i; + i__2 = u11 + i__ - 1 + j * work_dim1; + u11_ip1_j__.r = work[i__2].r, u11_ip1_j__.i = work[ + i__2].i; + i__2 = u11 + i__ + j * work_dim1; + i__3 = cut + i__ + invd * work_dim1; + i__4 = u11 + i__ + j * work_dim1; + z__2.r = work[i__3].r * work[i__4].r - work[i__3].i * + work[i__4].i, z__2.i = work[i__3].r * work[ + i__4].i + work[i__3].i * work[i__4].r; + i__5 = cut + i__ + (invd + 1) * work_dim1; + z__3.r = work[i__5].r * u11_ip1_j__.r - work[i__5].i * + u11_ip1_j__.i, z__3.i = work[i__5].r * + u11_ip1_j__.i + work[i__5].i * u11_ip1_j__.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + i__2 = u11 + i__ - 1 + j * work_dim1; + i__3 = cut + i__ - 1 + (invd + 1) * work_dim1; + z__2.r = work[i__3].r * u11_i_j__.r - work[i__3].i * + u11_i_j__.i, z__2.i = work[i__3].r * + u11_i_j__.i + work[i__3].i * u11_i_j__.r; + i__4 = cut + i__ - 1 + invd * work_dim1; + z__3.r = work[i__4].r * u11_ip1_j__.r - work[i__4].i * + u11_ip1_j__.i, z__3.i = work[i__4].r * + u11_ip1_j__.i + work[i__4].i * u11_ip1_j__.r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + --i__; + } + --i__; + } + +/* L11**H * invD1 * L11 -> L11 */ + + i__1 = *n + *nb + 1; + ztrmm_("L", uplo, "C", "U", &nnb, &nnb, &c_b1, &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) { + i__3 = cut + i__ + (cut + j) * a_dim1; + i__4 = u11 + i__ + j * work_dim1; + a[i__3].r = work[i__4].r, a[i__3].i = work[i__4].i; + } + } + + if (cut + nnb < *n) { + +/* L21**H * invD2*L21 -> A( CUT+I, CUT+J ) */ + + i__1 = *n - nnb - cut; + i__2 = *n + *nb + 1; + i__3 = *n + *nb + 1; + zgemm_("C", "N", &nnb, &nnb, &i__1, &c_b1, &a[cut + nnb + 1 + + (cut + 1) * a_dim1], lda, &work[work_offset], &i__2, & + c_b2, &work[u11 + 1 + work_dim1], &i__3); + +/* L11 = L11**H * invD1 * L11 + U01**H * invD * U01 */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = cut + i__ + (cut + j) * a_dim1; + i__4 = cut + i__ + (cut + j) * a_dim1; + i__5 = u11 + i__ + j * work_dim1; + z__1.r = a[i__4].r + work[i__5].r, z__1.i = a[i__4].i + + work[i__5].i; + a[i__3].r = z__1.r, a[i__3].i = z__1.i; + } + } + +/* L01 = L22**H * invD2 * L21 */ + + i__1 = *n - nnb - cut; + i__2 = *n + *nb + 1; + ztrmm_("L", uplo, "C", "U", &i__1, &nnb, &c_b1, &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) { + i__3 = cut + nnb + i__ + (cut + j) * a_dim1; + i__4 = i__ + j * work_dim1; + a[i__3].r = work[i__4].r, a[i__3].i = work[i__4].i; + } + } + + } else { + +/* L11 = L11**H * invD1 * L11 */ + + i__1 = nnb; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = cut + i__ + (cut + j) * a_dim1; + i__4 = u11 + i__ + j * work_dim1; + a[i__3].r = work[i__4].r, a[i__3].i = work[i__4].i; + } + } + } + +/* Next Block */ + + cut += nnb; + + } + +/* Apply PERMUTATIONS P and P**T: */ +/* P * inv(L**H) * 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) { + zheswapr_(uplo, n, &a[a_offset], lda, &i__, &ip); + } + if (i__ > ip) { + zheswapr_(uplo, n, &a[a_offset], lda, &ip, &i__); + } + } + } + + } + + return 0; + +/* End of ZHETRI_3X */ + +} /* zhetri_3x__ */ + diff --git a/lapack-netlib/SRC/zhetri_rook.c b/lapack-netlib/SRC/zhetri_rook.c new file mode 100644 index 000000000..25be938c4 --- /dev/null +++ b/lapack-netlib/SRC/zhetri_rook.c @@ -0,0 +1,1117 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHETRI_ROOK computes the inverse of HE matrix using the factorization obtained with the bounded + Bunch-Kaufman ("rook") diagonal pivoting method. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHETRI_ROOK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHETRI_ROOK( UPLO, N, A, LDA, IPIV, WORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHETRI_ROOK computes the inverse of a complex Hermitian indefinite matrix */ +/* > A using the factorization A = U*D*U**H or A = L*D*L**H computed by */ +/* > ZHETRF_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**H; */ +/* > = 'L': Lower triangular, form is A = L*D*L**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the block diagonal matrix D and the multipliers */ +/* > used to obtain the factor U or L as computed by ZHETRF_ROOK. */ +/* > */ +/* > On exit, if INFO = 0, the (Hermitian) 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 ZHETRF_ROOK. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 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 2013 */ + +/* > \ingroup complex16HEcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2013, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int zhetri_rook_(char *uplo, integer *n, doublecomplex *a, + integer *lda, integer *ipiv, doublecomplex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1; + doublecomplex z__1, z__2; + + /* Local variables */ + doublecomplex temp, akkp1; + doublereal d__; + integer j, k; + doublereal t; + extern logical lsame_(char *, char *); + extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + integer kstep; + extern /* Subroutine */ int zhemv_(char *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, integer *); + logical upper; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zswap_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *); + doublereal ak; + integer kp; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal akp1; + + +/* -- LAPACK computational routine (version 3.5.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2013 */ + + +/* ===================================================================== */ + + +/* 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_("ZHETRI_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)) { + i__1 = *info + *info * a_dim1; + if (ipiv[*info] > 0 && (a[i__1].r == 0. && a[i__1].i == 0.)) { + return 0; + } +/* L10: */ + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + i__2 = *info + *info * a_dim1; + if (ipiv[*info] > 0 && (a[i__2].r == 0. && a[i__2].i == 0.)) { + return 0; + } +/* L20: */ + } + } + *info = 0; + + if (upper) { + +/* Compute inv(A) from the factorization A = U*D*U**H. */ + +/* 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 L70; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Invert the diagonal block. */ + + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + d__1 = 1. / a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + +/* Compute column K of the inverse. */ + + if (k > 1) { + i__1 = k - 1; + zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1); + i__1 = k - 1; + z__1.r = -1., z__1.i = 0.; + zhemv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1, + &c_b2, &a[k * a_dim1 + 1], &c__1); + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + i__3 = k - 1; + zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k * a_dim1 + 1], & + c__1); + d__1 = z__2.r; + z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + } + kstep = 1; + } else { + +/* 2 x 2 diagonal block */ + +/* Invert the diagonal block. */ + + t = z_abs(&a[k + (k + 1) * a_dim1]); + i__1 = k + k * a_dim1; + ak = a[i__1].r / t; + i__1 = k + 1 + (k + 1) * a_dim1; + akp1 = a[i__1].r / t; + i__1 = k + (k + 1) * a_dim1; + z__1.r = a[i__1].r / t, z__1.i = a[i__1].i / t; + akkp1.r = z__1.r, akkp1.i = z__1.i; + d__ = t * (ak * akp1 - 1.); + i__1 = k + k * a_dim1; + d__1 = akp1 / d__; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = k + 1 + (k + 1) * a_dim1; + d__1 = ak / d__; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = k + (k + 1) * a_dim1; + z__2.r = -akkp1.r, z__2.i = -akkp1.i; + z__1.r = z__2.r / d__, z__1.i = z__2.i / d__; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + +/* Compute columns K and K+1 of the inverse. */ + + if (k > 1) { + i__1 = k - 1; + zcopy_(&i__1, &a[k * a_dim1 + 1], &c__1, &work[1], &c__1); + i__1 = k - 1; + z__1.r = -1., z__1.i = 0.; + zhemv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1, + &c_b2, &a[k * a_dim1 + 1], &c__1); + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + i__3 = k - 1; + zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k * a_dim1 + 1], & + c__1); + d__1 = z__2.r; + z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + i__1 = k + (k + 1) * a_dim1; + i__2 = k + (k + 1) * a_dim1; + i__3 = k - 1; + zdotc_(&z__2, &i__3, &a[k * a_dim1 + 1], &c__1, &a[(k + 1) * + a_dim1 + 1], &c__1); + z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + i__1 = k - 1; + zcopy_(&i__1, &a[(k + 1) * a_dim1 + 1], &c__1, &work[1], & + c__1); + i__1 = k - 1; + z__1.r = -1., z__1.i = 0.; + zhemv_(uplo, &i__1, &z__1, &a[a_offset], lda, &work[1], &c__1, + &c_b2, &a[(k + 1) * a_dim1 + 1], &c__1); + i__1 = k + 1 + (k + 1) * a_dim1; + i__2 = k + 1 + (k + 1) * a_dim1; + i__3 = k - 1; + zdotc_(&z__2, &i__3, &work[1], &c__1, &a[(k + 1) * a_dim1 + 1] + , &c__1); + d__1 = z__2.r; + z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + } + kstep = 2; + } + + if (kstep == 1) { + +/* Interchange rows and columns K and IPIV(K) in the leading */ +/* submatrix A(1:k,1:k) */ + + kp = ipiv[k]; + if (kp != k) { + + if (kp > 1) { + i__1 = kp - 1; + zswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + + i__1 = k - 1; + for (j = kp + 1; j <= i__1; ++j) { + d_cnjg(&z__1, &a[j + k * a_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + i__2 = j + k * a_dim1; + d_cnjg(&z__1, &a[kp + j * a_dim1]); + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = kp + j * a_dim1; + a[i__2].r = temp.r, a[i__2].i = temp.i; +/* L40: */ + } + + i__1 = kp + k * a_dim1; + d_cnjg(&z__1, &a[kp + k * a_dim1]); + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + + i__1 = k + k * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + k * a_dim1; + i__2 = kp + kp * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + kp * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + } + } else { + +/* Interchange rows and columns K and K+1 with -IPIV(K) and */ +/* -IPIV(K+1) in the leading submatrix A(k+1:n,k+1:n) */ + +/* (1) Interchange rows and columns K and -IPIV(K) */ + + kp = -ipiv[k]; + if (kp != k) { + + if (kp > 1) { + i__1 = kp - 1; + zswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + + i__1 = k - 1; + for (j = kp + 1; j <= i__1; ++j) { + d_cnjg(&z__1, &a[j + k * a_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + i__2 = j + k * a_dim1; + d_cnjg(&z__1, &a[kp + j * a_dim1]); + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = kp + j * a_dim1; + a[i__2].r = temp.r, a[i__2].i = temp.i; +/* L50: */ + } + + i__1 = kp + k * a_dim1; + d_cnjg(&z__1, &a[kp + k * a_dim1]); + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + + i__1 = k + k * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + k * a_dim1; + i__2 = kp + kp * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + kp * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + + i__1 = k + (k + 1) * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + (k + 1) * a_dim1; + i__2 = kp + (k + 1) * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + (k + 1) * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + } + +/* (2) Interchange rows and columns K+1 and -IPIV(K+1) */ + + ++k; + kp = -ipiv[k]; + if (kp != k) { + + if (kp > 1) { + i__1 = kp - 1; + zswap_(&i__1, &a[k * a_dim1 + 1], &c__1, &a[kp * a_dim1 + + 1], &c__1); + } + + i__1 = k - 1; + for (j = kp + 1; j <= i__1; ++j) { + d_cnjg(&z__1, &a[j + k * a_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + i__2 = j + k * a_dim1; + d_cnjg(&z__1, &a[kp + j * a_dim1]); + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = kp + j * a_dim1; + a[i__2].r = temp.r, a[i__2].i = temp.i; +/* L60: */ + } + + i__1 = kp + k * a_dim1; + d_cnjg(&z__1, &a[kp + k * a_dim1]); + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + + i__1 = k + k * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + k * a_dim1; + i__2 = kp + kp * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + kp * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + } + } + + ++k; + goto L30; +L70: + + ; + } else { + +/* Compute inv(A) from the factorization A = L*D*L**H. */ + +/* 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; +L80: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L120; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Invert the diagonal block. */ + + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + d__1 = 1. / a[i__2].r; + a[i__1].r = d__1, a[i__1].i = 0.; + +/* Compute column K of the inverse. */ + + if (k < *n) { + i__1 = *n - k; + zcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1); + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zhemv_(uplo, &i__1, &z__1, &a[k + 1 + (k + 1) * a_dim1], lda, + &work[1], &c__1, &c_b2, &a[k + 1 + k * a_dim1], &c__1); + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + i__3 = *n - k; + zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k + 1 + k * a_dim1], + &c__1); + d__1 = z__2.r; + z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + } + kstep = 1; + } else { + +/* 2 x 2 diagonal block */ + +/* Invert the diagonal block. */ + + t = z_abs(&a[k + (k - 1) * a_dim1]); + i__1 = k - 1 + (k - 1) * a_dim1; + ak = a[i__1].r / t; + i__1 = k + k * a_dim1; + akp1 = a[i__1].r / t; + i__1 = k + (k - 1) * a_dim1; + z__1.r = a[i__1].r / t, z__1.i = a[i__1].i / t; + akkp1.r = z__1.r, akkp1.i = z__1.i; + d__ = t * (ak * akp1 - 1.); + i__1 = k - 1 + (k - 1) * a_dim1; + d__1 = akp1 / d__; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = k + k * a_dim1; + d__1 = ak / d__; + a[i__1].r = d__1, a[i__1].i = 0.; + i__1 = k + (k - 1) * a_dim1; + z__2.r = -akkp1.r, z__2.i = -akkp1.i; + z__1.r = z__2.r / d__, z__1.i = z__2.i / d__; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + +/* Compute columns K-1 and K of the inverse. */ + + if (k < *n) { + i__1 = *n - k; + zcopy_(&i__1, &a[k + 1 + k * a_dim1], &c__1, &work[1], &c__1); + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zhemv_(uplo, &i__1, &z__1, &a[k + 1 + (k + 1) * a_dim1], lda, + &work[1], &c__1, &c_b2, &a[k + 1 + k * a_dim1], &c__1); + i__1 = k + k * a_dim1; + i__2 = k + k * a_dim1; + i__3 = *n - k; + zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k + 1 + k * a_dim1], + &c__1); + d__1 = z__2.r; + z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + i__1 = k + (k - 1) * a_dim1; + i__2 = k + (k - 1) * a_dim1; + i__3 = *n - k; + zdotc_(&z__2, &i__3, &a[k + 1 + k * a_dim1], &c__1, &a[k + 1 + + (k - 1) * a_dim1], &c__1); + z__1.r = a[i__2].r - z__2.r, z__1.i = a[i__2].i - z__2.i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + i__1 = *n - k; + zcopy_(&i__1, &a[k + 1 + (k - 1) * a_dim1], &c__1, &work[1], & + c__1); + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zhemv_(uplo, &i__1, &z__1, &a[k + 1 + (k + 1) * a_dim1], lda, + &work[1], &c__1, &c_b2, &a[k + 1 + (k - 1) * a_dim1], + &c__1); + i__1 = k - 1 + (k - 1) * a_dim1; + i__2 = k - 1 + (k - 1) * a_dim1; + i__3 = *n - k; + zdotc_(&z__2, &i__3, &work[1], &c__1, &a[k + 1 + (k - 1) * + a_dim1], &c__1); + d__1 = z__2.r; + z__1.r = a[i__2].r - d__1, z__1.i = a[i__2].i; + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + } + kstep = 2; + } + + if (kstep == 1) { + +/* Interchange rows and columns K and IPIV(K) in the trailing */ +/* submatrix A(k:n,k:n) */ + + kp = ipiv[k]; + if (kp != k) { + + if (kp < *n) { + i__1 = *n - kp; + zswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + + i__1 = kp - 1; + for (j = k + 1; j <= i__1; ++j) { + d_cnjg(&z__1, &a[j + k * a_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + i__2 = j + k * a_dim1; + d_cnjg(&z__1, &a[kp + j * a_dim1]); + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = kp + j * a_dim1; + a[i__2].r = temp.r, a[i__2].i = temp.i; +/* L90: */ + } + + i__1 = kp + k * a_dim1; + d_cnjg(&z__1, &a[kp + k * a_dim1]); + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + + i__1 = k + k * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + k * a_dim1; + i__2 = kp + kp * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + kp * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + } + } 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) */ + +/* (1) Interchange rows and columns K and -IPIV(K) */ + + kp = -ipiv[k]; + if (kp != k) { + + if (kp < *n) { + i__1 = *n - kp; + zswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + + i__1 = kp - 1; + for (j = k + 1; j <= i__1; ++j) { + d_cnjg(&z__1, &a[j + k * a_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + i__2 = j + k * a_dim1; + d_cnjg(&z__1, &a[kp + j * a_dim1]); + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = kp + j * a_dim1; + a[i__2].r = temp.r, a[i__2].i = temp.i; +/* L100: */ + } + + i__1 = kp + k * a_dim1; + d_cnjg(&z__1, &a[kp + k * a_dim1]); + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + + i__1 = k + k * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + k * a_dim1; + i__2 = kp + kp * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + kp * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + + i__1 = k + (k - 1) * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + (k - 1) * a_dim1; + i__2 = kp + (k - 1) * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + (k - 1) * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + } + +/* (2) Interchange rows and columns K-1 and -IPIV(K-1) */ + + --k; + kp = -ipiv[k]; + if (kp != k) { + + if (kp < *n) { + i__1 = *n - kp; + zswap_(&i__1, &a[kp + 1 + k * a_dim1], &c__1, &a[kp + 1 + + kp * a_dim1], &c__1); + } + + i__1 = kp - 1; + for (j = k + 1; j <= i__1; ++j) { + d_cnjg(&z__1, &a[j + k * a_dim1]); + temp.r = z__1.r, temp.i = z__1.i; + i__2 = j + k * a_dim1; + d_cnjg(&z__1, &a[kp + j * a_dim1]); + a[i__2].r = z__1.r, a[i__2].i = z__1.i; + i__2 = kp + j * a_dim1; + a[i__2].r = temp.r, a[i__2].i = temp.i; +/* L110: */ + } + + i__1 = kp + k * a_dim1; + d_cnjg(&z__1, &a[kp + k * a_dim1]); + a[i__1].r = z__1.r, a[i__1].i = z__1.i; + + i__1 = k + k * a_dim1; + temp.r = a[i__1].r, temp.i = a[i__1].i; + i__1 = k + k * a_dim1; + i__2 = kp + kp * a_dim1; + a[i__1].r = a[i__2].r, a[i__1].i = a[i__2].i; + i__1 = kp + kp * a_dim1; + a[i__1].r = temp.r, a[i__1].i = temp.i; + } + } + + --k; + goto L80; +L120: + ; + } + + return 0; + +/* End of ZHETRI_ROOK */ + +} /* zhetri_rook__ */ + diff --git a/lapack-netlib/SRC/zhetrs.c b/lapack-netlib/SRC/zhetrs.c new file mode 100644 index 000000000..245fa4569 --- /dev/null +++ b/lapack-netlib/SRC/zhetrs.c @@ -0,0 +1,962 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHETRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHETRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHETRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHETRS solves a system of linear equations A*X = B with a complex */ +/* > Hermitian matrix A using the factorization A = U*D*U**H or */ +/* > A = L*D*L**H computed by ZHETRF. */ +/* > \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**H; */ +/* > = 'L': Lower triangular, form is A = L*D*L**H. */ +/* > \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 COMPLEX*16 array, dimension (LDA,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by ZHETRF. */ +/* > \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 ZHETRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16HEcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zhetrs_(char *uplo, integer *n, integer *nrhs, + doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, + integer *ldb, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + doublecomplex akm1k; + integer j, k; + doublereal s; + extern logical lsame_(char *, char *); + doublecomplex denom; + extern /* Subroutine */ int zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + logical upper; + extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zswap_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *); + doublecomplex ak, bk; + integer kp; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zdscal_( + integer *, doublereal *, doublecomplex *, integer *), zlacgv_( + integer *, doublecomplex *, integer *); + doublecomplex 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_("ZHETRS", &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**H. */ + +/* 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) { + zswap_(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; + z__1.r = -1., z__1.i = 0.; + zgeru_(&i__1, nrhs, &z__1, &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. */ + + i__1 = k + k * a_dim1; + s = 1. / a[i__1].r; + zdscal_(nrhs, &s, &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) { + zswap_(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; + z__1.r = -1., z__1.i = 0.; + zgeru_(&i__1, nrhs, &z__1, &a[k * a_dim1 + 1], &c__1, &b[k + + b_dim1], ldb, &b[b_dim1 + 1], ldb); + i__1 = k - 2; + z__1.r = -1., z__1.i = 0.; + zgeru_(&i__1, nrhs, &z__1, &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. */ + + i__1 = k - 1 + k * a_dim1; + akm1k.r = a[i__1].r, akm1k.i = a[i__1].i; + z_div(&z__1, &a[k - 1 + (k - 1) * a_dim1], &akm1k); + akm1.r = z__1.r, akm1.i = z__1.i; + d_cnjg(&z__2, &akm1k); + z_div(&z__1, &a[k + k * a_dim1], &z__2); + ak.r = z__1.r, ak.i = z__1.i; + z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i + + akm1.i * ak.r; + z__1.r = z__2.r - 1., z__1.i = z__2.i + 0.; + denom.r = z__1.r, denom.i = z__1.i; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + z_div(&z__1, &b[k - 1 + j * b_dim1], &akm1k); + bkm1.r = z__1.r, bkm1.i = z__1.i; + d_cnjg(&z__2, &akm1k); + z_div(&z__1, &b[k + j * b_dim1], &z__2); + bk.r = z__1.r, bk.i = z__1.i; + i__2 = k - 1 + j * b_dim1; + z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r * + bkm1.i + ak.i * bkm1.r; + z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i; + z_div(&z__1, &z__2, &denom); + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = k + j * b_dim1; + z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r * + bk.i + akm1.i * bk.r; + z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i; + z_div(&z__1, &z__2, &denom); + b[i__2].r = z__1.r, b[i__2].i = z__1.i; +/* L20: */ + } + k += -2; + } + + goto L10; +L30: + +/* Next solve U**H *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**H(K)), where U(K) is the transformation */ +/* stored in column K of A. */ + + if (k > 1) { + zlacgv_(nrhs, &b[k + b_dim1], ldb); + i__1 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset] + , ldb, &a[k * a_dim1 + 1], &c__1, &c_b1, &b[k + + b_dim1], ldb); + zlacgv_(nrhs, &b[k + b_dim1], ldb); + } + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + ++k; + } else { + +/* 2 x 2 diagonal block */ + +/* Multiply by inv(U**H(K+1)), where U(K+1) is the transformation */ +/* stored in columns K and K+1 of A. */ + + if (k > 1) { + zlacgv_(nrhs, &b[k + b_dim1], ldb); + i__1 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset] + , ldb, &a[k * a_dim1 + 1], &c__1, &c_b1, &b[k + + b_dim1], ldb); + zlacgv_(nrhs, &b[k + b_dim1], ldb); + + zlacgv_(nrhs, &b[k + 1 + b_dim1], ldb); + i__1 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset] + , ldb, &a[(k + 1) * a_dim1 + 1], &c__1, &c_b1, &b[k + + 1 + b_dim1], ldb); + zlacgv_(nrhs, &b[k + 1 + b_dim1], ldb); + } + +/* Interchange rows K and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k) { + zswap_(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**H. */ + +/* 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) { + zswap_(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; + z__1.r = -1., z__1.i = 0.; + zgeru_(&i__1, nrhs, &z__1, &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. */ + + i__1 = k + k * a_dim1; + s = 1. / a[i__1].r; + zdscal_(nrhs, &s, &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) { + zswap_(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; + z__1.r = -1., z__1.i = 0.; + zgeru_(&i__1, nrhs, &z__1, &a[k + 2 + k * a_dim1], &c__1, &b[ + k + b_dim1], ldb, &b[k + 2 + b_dim1], ldb); + i__1 = *n - k - 1; + z__1.r = -1., z__1.i = 0.; + zgeru_(&i__1, nrhs, &z__1, &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. */ + + i__1 = k + 1 + k * a_dim1; + akm1k.r = a[i__1].r, akm1k.i = a[i__1].i; + d_cnjg(&z__2, &akm1k); + z_div(&z__1, &a[k + k * a_dim1], &z__2); + akm1.r = z__1.r, akm1.i = z__1.i; + z_div(&z__1, &a[k + 1 + (k + 1) * a_dim1], &akm1k); + ak.r = z__1.r, ak.i = z__1.i; + z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i + + akm1.i * ak.r; + z__1.r = z__2.r - 1., z__1.i = z__2.i + 0.; + denom.r = z__1.r, denom.i = z__1.i; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + d_cnjg(&z__2, &akm1k); + z_div(&z__1, &b[k + j * b_dim1], &z__2); + bkm1.r = z__1.r, bkm1.i = z__1.i; + z_div(&z__1, &b[k + 1 + j * b_dim1], &akm1k); + bk.r = z__1.r, bk.i = z__1.i; + i__2 = k + j * b_dim1; + z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r * + bkm1.i + ak.i * bkm1.r; + z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i; + z_div(&z__1, &z__2, &denom); + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = k + 1 + j * b_dim1; + z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r * + bk.i + akm1.i * bk.r; + z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i; + z_div(&z__1, &z__2, &denom); + b[i__2].r = z__1.r, b[i__2].i = z__1.i; +/* L70: */ + } + k += 2; + } + + goto L60; +L80: + +/* Next solve L**H *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**H(K)), where L(K) is the transformation */ +/* stored in column K of A. */ + + if (k < *n) { + zlacgv_(nrhs, &b[k + b_dim1], ldb); + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 + + b_dim1], ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, & + b[k + b_dim1], ldb); + zlacgv_(nrhs, &b[k + b_dim1], ldb); + } + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + --k; + } else { + +/* 2 x 2 diagonal block */ + +/* Multiply by inv(L**H(K-1)), where L(K-1) is the transformation */ +/* stored in columns K-1 and K of A. */ + + if (k < *n) { + zlacgv_(nrhs, &b[k + b_dim1], ldb); + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 + + b_dim1], ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, & + b[k + b_dim1], ldb); + zlacgv_(nrhs, &b[k + b_dim1], ldb); + + zlacgv_(nrhs, &b[k - 1 + b_dim1], ldb); + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 + + b_dim1], ldb, &a[k + 1 + (k - 1) * a_dim1], &c__1, & + c_b1, &b[k - 1 + b_dim1], ldb); + zlacgv_(nrhs, &b[k - 1 + b_dim1], ldb); + } + +/* Interchange rows K and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + k += -2; + } + + goto L90; +L100: + ; + } + + return 0; + +/* End of ZHETRS */ + +} /* zhetrs_ */ + diff --git a/lapack-netlib/SRC/zhetrs2.c b/lapack-netlib/SRC/zhetrs2.c new file mode 100644 index 000000000..cba7c700a --- /dev/null +++ b/lapack-netlib/SRC/zhetrs2.c @@ -0,0 +1,821 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHETRS2 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHETRS2 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHETRS2( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, */ +/* WORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHETRS2 solves a system of linear equations A*X = B with a complex */ +/* > Hermitian matrix A using the factorization A = U*D*U**H or */ +/* > A = L*D*L**H computed by ZHETRF and converted by ZSYCONV. */ +/* > \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**H; */ +/* > = 'L': Lower triangular, form is A = L*D*L**H. */ +/* > \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 COMPLEX*16 array, dimension (LDA,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by ZHETRF. */ +/* > \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 ZHETRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16HEcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zhetrs2_(char *uplo, integer *n, integer *nrhs, + doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, + integer *ldb, doublecomplex *work, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + doublecomplex akm1k; + integer i__, j, k; + doublereal s; + extern logical lsame_(char *, char *); + doublecomplex denom; + integer iinfo; + logical upper; + extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), ztrsm_(char *, char *, char *, char * + , integer *, integer *, doublecomplex *, doublecomplex *, integer + *, doublecomplex *, integer *); + doublecomplex ak, bk; + integer kp; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zdscal_( + integer *, doublereal *, doublecomplex *, integer *); + doublecomplex akm1, bkm1; + extern /* Subroutine */ int zsyconv_(char *, char *, integer *, + doublecomplex *, integer *, integer *, doublecomplex *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* 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_("ZHETRS2", &i__1, (ftnlen)7); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + +/* Convert A */ + + zsyconv_(uplo, "C", n, &a[a_offset], lda, &ipiv[1], &work[1], &iinfo); + + if (upper) { + +/* Solve A*X = B, where A = U*D*U**H. */ + +/* 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) { + zswap_(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]) { + zswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], + ldb); + } + k += -2; + } + } + +/* Compute (U \P**T * B) -> B [ (U \P**T * B) ] */ + + ztrsm_("L", "U", "N", "U", n, nrhs, &c_b1, &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) { + i__1 = i__ + i__ * a_dim1; + s = 1. / a[i__1].r; + zdscal_(nrhs, &s, &b[i__ + b_dim1], ldb); + } else if (i__ > 1) { + if (ipiv[i__ - 1] == ipiv[i__]) { + i__1 = i__; + akm1k.r = work[i__1].r, akm1k.i = work[i__1].i; + z_div(&z__1, &a[i__ - 1 + (i__ - 1) * a_dim1], &akm1k); + akm1.r = z__1.r, akm1.i = z__1.i; + d_cnjg(&z__2, &akm1k); + z_div(&z__1, &a[i__ + i__ * a_dim1], &z__2); + ak.r = z__1.r, ak.i = z__1.i; + z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * + ak.i + akm1.i * ak.r; + z__1.r = z__2.r - 1., z__1.i = z__2.i + 0.; + denom.r = z__1.r, denom.i = z__1.i; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + z_div(&z__1, &b[i__ - 1 + j * b_dim1], &akm1k); + bkm1.r = z__1.r, bkm1.i = z__1.i; + d_cnjg(&z__2, &akm1k); + z_div(&z__1, &b[i__ + j * b_dim1], &z__2); + bk.r = z__1.r, bk.i = z__1.i; + i__2 = i__ - 1 + j * b_dim1; + z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r + * bkm1.i + ak.i * bkm1.r; + z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i; + z_div(&z__1, &z__2, &denom); + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = i__ + j * b_dim1; + z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = + akm1.r * bk.i + akm1.i * bk.r; + z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i; + z_div(&z__1, &z__2, &denom); + b[i__2].r = z__1.r, b[i__2].i = z__1.i; +/* L15: */ + } + --i__; + } + } + --i__; + } + +/* Compute (U**H \ B) -> B [ U**H \ (D \ (U \P**T * B) ) ] */ + + ztrsm_("L", "U", "C", "U", n, nrhs, &c_b1, &a[a_offset], lda, &b[ + b_offset], ldb); + +/* P * B [ P * (U**H \ (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) { + zswap_(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]) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + k += 2; + } + } + + } else { + +/* Solve A*X = B, where A = L*D*L**H. */ + +/* 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) { + zswap_(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]) { + zswap_(nrhs, &b[k + 1 + b_dim1], ldb, &b[kp + b_dim1], + ldb); + } + k += 2; + } + } + +/* Compute (L \P**T * B) -> B [ (L \P**T * B) ] */ + + ztrsm_("L", "L", "N", "U", n, nrhs, &c_b1, &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) { + i__1 = i__ + i__ * a_dim1; + s = 1. / a[i__1].r; + zdscal_(nrhs, &s, &b[i__ + b_dim1], ldb); + } else { + i__1 = i__; + akm1k.r = work[i__1].r, akm1k.i = work[i__1].i; + d_cnjg(&z__2, &akm1k); + z_div(&z__1, &a[i__ + i__ * a_dim1], &z__2); + akm1.r = z__1.r, akm1.i = z__1.i; + z_div(&z__1, &a[i__ + 1 + (i__ + 1) * a_dim1], &akm1k); + ak.r = z__1.r, ak.i = z__1.i; + z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * + ak.i + akm1.i * ak.r; + z__1.r = z__2.r - 1., z__1.i = z__2.i + 0.; + denom.r = z__1.r, denom.i = z__1.i; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + d_cnjg(&z__2, &akm1k); + z_div(&z__1, &b[i__ + j * b_dim1], &z__2); + bkm1.r = z__1.r, bkm1.i = z__1.i; + z_div(&z__1, &b[i__ + 1 + j * b_dim1], &akm1k); + bk.r = z__1.r, bk.i = z__1.i; + i__2 = i__ + j * b_dim1; + z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r * + bkm1.i + ak.i * bkm1.r; + z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i; + z_div(&z__1, &z__2, &denom); + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = i__ + 1 + j * b_dim1; + z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r * + bk.i + akm1.i * bk.r; + z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i; + z_div(&z__1, &z__2, &denom); + b[i__2].r = z__1.r, b[i__2].i = z__1.i; +/* L25: */ + } + ++i__; + } + ++i__; + } + +/* Compute (L**H \ B) -> B [ L**H \ (D \ (L \P**T * B) ) ] */ + + ztrsm_("L", "L", "C", "U", n, nrhs, &c_b1, &a[a_offset], lda, &b[ + b_offset], ldb); + +/* P * B [ P * (L**H \ (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) { + zswap_(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]) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + k += -2; + } + } + + } + +/* Revert A */ + + zsyconv_(uplo, "R", n, &a[a_offset], lda, &ipiv[1], &work[1], &iinfo); + + return 0; + +/* End of ZHETRS2 */ + +} /* zhetrs2_ */ + diff --git a/lapack-netlib/SRC/zhetrs_3.c b/lapack-netlib/SRC/zhetrs_3.c new file mode 100644 index 000000000..6e5090f3b --- /dev/null +++ b/lapack-netlib/SRC/zhetrs_3.c @@ -0,0 +1,823 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHETRS_3 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHETRS_3 + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHETRS_3( UPLO, N, NRHS, A, LDA, E, IPIV, B, LDB, */ +/* INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), B( LDB, * ), E( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > ZHETRS_3 solves a system of linear equations A * X = B with a complex */ +/* > Hermitian matrix A using the factorization computed */ +/* > by ZHETRF_RK or ZHETRF_BK: */ +/* > */ +/* > A = P*U*D*(U**H)*(P**T) or A = P*L*D*(L**H)*(P**T), */ +/* > */ +/* > where U (or L) is unit upper (or lower) triangular matrix, */ +/* > U**H (or L**H) is the conjugate of U (or L), P is a permutation */ +/* > matrix, P**T is the transpose of P, and D is Hermitian 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**H)*(P**T); */ +/* > = 'L': Lower triangular, form is A = P*L*D*(L**H)*(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 COMPLEX*16 array, dimension (LDA,N) */ +/* > Diagonal of the block diagonal matrix D and factors U or L */ +/* > as computed by ZHETRF_RK and ZHETRF_BK: */ +/* > a) ONLY diagonal elements of the Hermitian block diagonal */ +/* > matrix D on the diagonal of A, i.e. D(k,k) = A(k,k); */ +/* > (superdiagonal (or subdiagonal) elements of D */ +/* > 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 COMPLEX*16 array, dimension (N) */ +/* > On entry, contains the superdiagonal (or subdiagonal) */ +/* > elements of the Hermitian block diagonal matrix D */ +/* > with 1-by-1 or 2-by-2 diagonal blocks, where */ +/* > If UPLO = 'U': E(i) = D(i-1,i),i=2:N, E(1) 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 ZHETRF_RK or ZHETRF_BK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup complex16HEcomputational */ + +/* > \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 zhetrs_3_(char *uplo, integer *n, integer *nrhs, + doublecomplex *a, integer *lda, doublecomplex *e, integer *ipiv, + doublecomplex *b, integer *ldb, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + doublecomplex akm1k; + integer i__, j, k; + doublereal s; + extern logical lsame_(char *, char *); + doublecomplex denom; + logical upper; + extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), ztrsm_(char *, char *, char *, char * + , integer *, integer *, doublecomplex *, doublecomplex *, integer + *, doublecomplex *, integer *); + doublecomplex ak, bk; + integer kp; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zdscal_( + integer *, doublereal *, doublecomplex *, integer *); + doublecomplex 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_("ZHETRS_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**H. */ + +/* 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) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + +/* Compute (U \P**T * B) -> B [ (U \P**T * B) ] */ + + ztrsm_("L", "U", "N", "U", n, nrhs, &c_b1, &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) { + i__1 = i__ + i__ * a_dim1; + s = 1. / a[i__1].r; + zdscal_(nrhs, &s, &b[i__ + b_dim1], ldb); + } else if (i__ > 1) { + i__1 = i__; + akm1k.r = e[i__1].r, akm1k.i = e[i__1].i; + z_div(&z__1, &a[i__ - 1 + (i__ - 1) * a_dim1], &akm1k); + akm1.r = z__1.r, akm1.i = z__1.i; + d_cnjg(&z__2, &akm1k); + z_div(&z__1, &a[i__ + i__ * a_dim1], &z__2); + ak.r = z__1.r, ak.i = z__1.i; + z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * + ak.i + akm1.i * ak.r; + z__1.r = z__2.r - 1., z__1.i = z__2.i + 0.; + denom.r = z__1.r, denom.i = z__1.i; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + z_div(&z__1, &b[i__ - 1 + j * b_dim1], &akm1k); + bkm1.r = z__1.r, bkm1.i = z__1.i; + d_cnjg(&z__2, &akm1k); + z_div(&z__1, &b[i__ + j * b_dim1], &z__2); + bk.r = z__1.r, bk.i = z__1.i; + i__2 = i__ - 1 + j * b_dim1; + z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r * + bkm1.i + ak.i * bkm1.r; + z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i; + z_div(&z__1, &z__2, &denom); + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = i__ + j * b_dim1; + z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r * + bk.i + akm1.i * bk.r; + z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i; + z_div(&z__1, &z__2, &denom); + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } + --i__; + } + --i__; + } + +/* Compute (U**H \ B) -> B [ U**H \ (D \ (U \P**T * B) ) ] */ + + ztrsm_("L", "U", "C", "U", n, nrhs, &c_b1, &a[a_offset], lda, &b[ + b_offset], ldb); + +/* P * B [ P * (U**H \ (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) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + + } else { + +/* Begin Lower */ + +/* Solve A*X = B, where A = L*D*L**H. */ + +/* 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) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + +/* Compute (L \P**T * B) -> B [ (L \P**T * B) ] */ + + ztrsm_("L", "L", "N", "U", n, nrhs, &c_b1, &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) { + i__1 = i__ + i__ * a_dim1; + s = 1. / a[i__1].r; + zdscal_(nrhs, &s, &b[i__ + b_dim1], ldb); + } else if (i__ < *n) { + i__1 = i__; + akm1k.r = e[i__1].r, akm1k.i = e[i__1].i; + d_cnjg(&z__2, &akm1k); + z_div(&z__1, &a[i__ + i__ * a_dim1], &z__2); + akm1.r = z__1.r, akm1.i = z__1.i; + z_div(&z__1, &a[i__ + 1 + (i__ + 1) * a_dim1], &akm1k); + ak.r = z__1.r, ak.i = z__1.i; + z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * + ak.i + akm1.i * ak.r; + z__1.r = z__2.r - 1., z__1.i = z__2.i + 0.; + denom.r = z__1.r, denom.i = z__1.i; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + d_cnjg(&z__2, &akm1k); + z_div(&z__1, &b[i__ + j * b_dim1], &z__2); + bkm1.r = z__1.r, bkm1.i = z__1.i; + z_div(&z__1, &b[i__ + 1 + j * b_dim1], &akm1k); + bk.r = z__1.r, bk.i = z__1.i; + i__2 = i__ + j * b_dim1; + z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r * + bkm1.i + ak.i * bkm1.r; + z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i; + z_div(&z__1, &z__2, &denom); + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = i__ + 1 + j * b_dim1; + z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r * + bk.i + akm1.i * bk.r; + z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i; + z_div(&z__1, &z__2, &denom); + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + } + ++i__; + } + ++i__; + } + +/* Compute (L**H \ B) -> B [ L**H \ (D \ (L \P**T * B) ) ] */ + + ztrsm_("L", "L", "C", "U", n, nrhs, &c_b1, &a[a_offset], lda, &b[ + b_offset], ldb); + +/* P * B [ P * (L**H \ (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) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + +/* END Lower */ + + } + + return 0; + +/* End of ZHETRS_3 */ + +} /* zhetrs_3__ */ + diff --git a/lapack-netlib/SRC/zhetrs_aa.c b/lapack-netlib/SRC/zhetrs_aa.c new file mode 100644 index 000000000..e0ee70bb1 --- /dev/null +++ b/lapack-netlib/SRC/zhetrs_aa.c @@ -0,0 +1,745 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHETRS_AA */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHETRS_AA + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHETRS_AA( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, */ +/* WORK, LWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER N, NRHS, LDA, LDB, LWORK, INFO */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), B( LDB, * ), WORK( * ) */ + + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHETRS_AA solves a system of linear equations A*X = B with a complex */ +/* > hermitian matrix A using the factorization A = U**H*T*U or */ +/* > A = L*T*L**H computed by ZHETRF_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**H*T*U; */ +/* > = 'L': Lower triangular, form is A = L*T*L**H. */ +/* > \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 COMPLEX*16 array, dimension (LDA,N) */ +/* > Details of factors computed by ZHETRF_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 ZHETRF_AA. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 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 complex16HEcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zhetrs_aa_(char *uplo, integer *n, integer *nrhs, + doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, + integer *ldb, doublecomplex *work, integer *lwork, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + + /* Local variables */ + integer k; + extern logical lsame_(char *, char *); + logical upper; + extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zgtsv_(integer *, integer *, + doublecomplex *, doublecomplex *, doublecomplex *, doublecomplex * + , integer *, integer *), ztrsm_(char *, char *, char *, char *, + integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *); + integer kp; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zlacgv_( + integer *, doublecomplex *, integer *), zlacpy_(char *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer * + ); + integer lwkopt; + logical lquery; + + +/* -- LAPACK computational routine (version 3.8.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2017 */ + + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + --work; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + lquery = *lwork == -1; + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*lda < f2cmax(1,*n)) { + *info = -5; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else /* if(complicated condition) */ { +/* Computing MAX */ + i__1 = 1, i__2 = *n * 3 - 2; + if (*lwork < f2cmax(i__1,i__2) && ! lquery) { + *info = -10; + } + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHETRS_AA", &i__1, (ftnlen)9); + return 0; + } else if (lquery) { + lwkopt = *n * 3 - 2; + work[1].r = (doublereal) lwkopt, work[1].i = 0.; + return 0; + } + +/* Quick return if possible */ + + if (*n == 0 || *nrhs == 0) { + return 0; + } + + if (upper) { + +/* Solve A*X = B, where A = U**H*T*U. */ + +/* 1) Forward substitution with U**H */ + + if (*n > 1) { + +/* Pivot, P**T * B -> B */ + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + kp = ipiv[k]; + if (kp != k) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + +/* Compute U**H \ B -> B [ (U**H \P**T * B) ] */ + + i__1 = *n - 1; + ztrsm_("L", "U", "C", "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**H \P**T * B) ] */ + + i__1 = *lda + 1; + zlacpy_("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; + zlacpy_("F", &c__1, &i__1, &a[(a_dim1 << 1) + 1], &i__2, &work[*n + * 2], &c__1); + i__1 = *n - 1; + i__2 = *lda + 1; + zlacpy_("F", &c__1, &i__1, &a[(a_dim1 << 1) + 1], &i__2, &work[1], + &c__1); + i__1 = *n - 1; + zlacgv_(&i__1, &work[1], &c__1); + } + zgtsv_(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**H \P**T * B) ) ] */ + + i__1 = *n - 1; + ztrsm_("L", "U", "N", "U", &i__1, nrhs, &c_b9, &a[(a_dim1 << 1) + + 1], lda, &b[b_dim1 + 2], ldb); + +/* Pivot, P * B [ P * (U**H \ (T \ (U \P**T * B) )) ] */ + + for (k = *n; k >= 1; --k) { + kp = ipiv[k]; + if (kp != k) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + } + + } else { + +/* Solve A*X = B, where A = L*T*L**H. */ + +/* 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) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + +/* Compute L \ B -> B [ (L \P**T * B) ] */ + + i__1 = *n - 1; + ztrsm_("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; + zlacpy_("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; + zlacpy_("F", &c__1, &i__1, &a[a_dim1 + 2], &i__2, &work[1], &c__1); + i__1 = *n - 1; + i__2 = *lda + 1; + zlacpy_("F", &c__1, &i__1, &a[a_dim1 + 2], &i__2, &work[*n * 2], & + c__1); + i__1 = *n - 1; + zlacgv_(&i__1, &work[*n * 2], &c__1); + } + zgtsv_(n, nrhs, &work[1], &work[*n], &work[*n * 2], &b[b_offset], ldb, + info); + +/* 3) Backward substitution with L**H */ + + if (*n > 1) { + +/* Compute L**H \ B -> B [ L**H \ (T \ (L \P**T * B) ) ] */ + + i__1 = *n - 1; + ztrsm_("L", "L", "C", "U", &i__1, nrhs, &c_b9, &a[a_dim1 + 2], + lda, &b[b_dim1 + 2], ldb); + +/* Pivot, P * B [ P * (L**H \ (T \ (L \P**T * B) )) ] */ + + for (k = *n; k >= 1; --k) { + kp = ipiv[k]; + if (kp != k) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + } + } + + } + + return 0; + +/* End of ZHETRS_AA */ + +} /* zhetrs_aa__ */ + diff --git a/lapack-netlib/SRC/zhetrs_aa_2stage.c b/lapack-netlib/SRC/zhetrs_aa_2stage.c new file mode 100644 index 000000000..dcdabc6ac --- /dev/null +++ b/lapack-netlib/SRC/zhetrs_aa_2stage.c @@ -0,0 +1,692 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHETRS_AA_2STAGE */ + +/* @generated from SRC/dsytrs_aa_2stage.f, fortran d -> c, Mon Oct 30 11:59:02 2017 */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHETRS_AA_2STAGE + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHETRS_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( * ) */ +/* COMPLEX*16 A( LDA, * ), TB( * ), B( LDB, * ) */ + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHETRS_AA_2STAGE solves a system of linear equations A*X = B with a */ +/* > hermitian matrix A using the factorization A = U**H*T*U or */ +/* > A = L*T*L**H computed by ZHETRF_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**H*T*U; */ +/* > = 'L': Lower triangular, form is A = L*T*L**H. */ +/* > \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 COMPLEX*16 array, dimension (LDA,N) */ +/* > Details of factors computed by ZHETRF_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 COMPLEX*16 array, dimension (LTB) */ +/* > Details of factors computed by ZHETRF_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 */ +/* > ZHETRF_AA_2STAGE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV2 */ +/* > \verbatim */ +/* > IPIV2 is INTEGER array, dimension (N) */ +/* > Details of the interchanges as computed by */ +/* > ZHETRF_AA_2STAGE. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2017 */ + +/* > \ingroup complex16SYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zhetrs_aa_2stage_(char *uplo, integer *n, integer *nrhs, + doublecomplex *a, integer *lda, doublecomplex *tb, integer *ltb, + integer *ipiv, integer *ipiv2, doublecomplex *b, integer *ldb, + integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1; + + /* Local variables */ + integer ldtb; + extern logical lsame_(char *, char *); + logical upper; + extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *, + integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *); + integer nb; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zgbtrs_( + char *, integer *, integer *, integer *, integer *, doublecomplex + *, integer *, integer *, doublecomplex *, integer *, integer *), zlaswp_(integer *, doublecomplex *, 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_("ZHETRS_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].r; + ldtb = *ltb / *n; + + if (upper) { + +/* Solve A*X = B, where A = U**H*T*U. */ + + if (*n > nb) { + +/* Pivot, P**T * B -> B */ + + i__1 = nb + 1; + zlaswp_(nrhs, &b[b_offset], ldb, &i__1, n, &ipiv[1], &c__1); + +/* Compute (U**H \ B) -> B [ (U**H \P**T * B) ] */ + + i__1 = *n - nb; + ztrsm_("L", "U", "C", "U", &i__1, nrhs, &c_b1, &a[(nb + 1) * + a_dim1 + 1], lda, &b[nb + 1 + b_dim1], ldb); + + } + +/* Compute T \ B -> B [ T \ (U**H \P**T * B) ] */ + + zgbtrs_("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**H \P**T * B) ) ] */ + + i__1 = *n - nb; + ztrsm_("L", "U", "N", "U", &i__1, nrhs, &c_b1, &a[(nb + 1) * + a_dim1 + 1], lda, &b[nb + 1 + b_dim1], ldb); + +/* Pivot, P * B -> B [ P * (U \ (T \ (U**H \P**T * B) )) ] */ + + i__1 = nb + 1; + zlaswp_(nrhs, &b[b_offset], ldb, &i__1, n, &ipiv[1], &c_n1); + + } + + } else { + +/* Solve A*X = B, where A = L*T*L**H. */ + + if (*n > nb) { + +/* Pivot, P**T * B -> B */ + + i__1 = nb + 1; + zlaswp_(nrhs, &b[b_offset], ldb, &i__1, n, &ipiv[1], &c__1); + +/* Compute (L \ B) -> B [ (L \P**T * B) ] */ + + i__1 = *n - nb; + ztrsm_("L", "L", "N", "U", &i__1, nrhs, &c_b1, &a[nb + 1 + a_dim1] + , lda, &b[nb + 1 + b_dim1], ldb); + + } + +/* Compute T \ B -> B [ T \ (L \P**T * B) ] */ + + zgbtrs_("N", n, &nb, &nb, nrhs, &tb[1], &ldtb, &ipiv2[1], &b[b_offset] + , ldb, info); + if (*n > nb) { + +/* Compute (L**H \ B) -> B [ L**H \ (T \ (L \P**T * B) ) ] */ + + i__1 = *n - nb; + ztrsm_("L", "L", "C", "U", &i__1, nrhs, &c_b1, &a[nb + 1 + a_dim1] + , lda, &b[nb + 1 + b_dim1], ldb); + +/* Pivot, P * B -> B [ P * (L**H \ (T \ (L \P**T * B) )) ] */ + + i__1 = nb + 1; + zlaswp_(nrhs, &b[b_offset], ldb, &i__1, n, &ipiv[1], &c_n1); + + } + } + + return 0; + +/* End of ZHETRS_AA_2STAGE */ + +} /* zhetrs_aa_2stage__ */ + diff --git a/lapack-netlib/SRC/zhetrs_rook.c b/lapack-netlib/SRC/zhetrs_rook.c new file mode 100644 index 000000000..576ae36ab --- /dev/null +++ b/lapack-netlib/SRC/zhetrs_rook.c @@ -0,0 +1,1000 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHETRS_ROOK computes the solution to a system of linear equations A * X = B for HE matrices usi +ng factorization obtained with one of the bounded diagonal pivoting methods (f2cmax 2 interchanges) */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHETRS_ROOK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHETRS_ROOK( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDA, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* COMPLEX A( LDA, * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHETRS_ROOK solves a system of linear equations A*X = B with a complex */ +/* > Hermitian matrix A using the factorization A = U*D*U**H or */ +/* > A = L*D*L**H computed by ZHETRF_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**H; */ +/* > = 'L': Lower triangular, form is A = L*D*L**H. */ +/* > \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 COMPLEX*16 array, dimension (LDA,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by ZHETRF_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 ZHETRF_ROOK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date November 2013 */ + +/* > \ingroup complex16HEcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > November 2013, Igor Kozachenko, */ +/* > Computer Science Division, */ +/* > University of California, Berkeley */ +/* > */ +/* > September 2007, Sven Hammarling, Nicholas J. Higham, Craig Lucas, */ +/* > School of Mathematics, */ +/* > University of Manchester */ +/* > */ +/* > \endverbatim */ + +/* ===================================================================== */ +/* Subroutine */ int zhetrs_rook_(char *uplo, integer *n, integer *nrhs, + doublecomplex *a, integer *lda, integer *ipiv, doublecomplex *b, + integer *ldb, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + doublecomplex akm1k; + integer j, k; + doublereal s; + extern logical lsame_(char *, char *); + doublecomplex denom; + extern /* Subroutine */ int zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + logical upper; + extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zswap_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *); + doublecomplex ak, bk; + integer kp; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zdscal_( + integer *, doublereal *, doublecomplex *, integer *), zlacgv_( + integer *, doublecomplex *, integer *); + doublecomplex akm1, bkm1; + + +/* -- LAPACK computational routine (version 3.5.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* November 2013 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --ipiv; + 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_("ZHETRS_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**H. */ + +/* 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) { + zswap_(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; + z__1.r = -1., z__1.i = 0.; + zgeru_(&i__1, nrhs, &z__1, &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. */ + + i__1 = k + k * a_dim1; + s = 1. / a[i__1].r; + zdscal_(nrhs, &s, &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) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + + kp = -ipiv[k - 1]; + if (kp != k - 1) { + zswap_(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; + z__1.r = -1., z__1.i = 0.; + zgeru_(&i__1, nrhs, &z__1, &a[k * a_dim1 + 1], &c__1, &b[k + + b_dim1], ldb, &b[b_dim1 + 1], ldb); + i__1 = k - 2; + z__1.r = -1., z__1.i = 0.; + zgeru_(&i__1, nrhs, &z__1, &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. */ + + i__1 = k - 1 + k * a_dim1; + akm1k.r = a[i__1].r, akm1k.i = a[i__1].i; + z_div(&z__1, &a[k - 1 + (k - 1) * a_dim1], &akm1k); + akm1.r = z__1.r, akm1.i = z__1.i; + d_cnjg(&z__2, &akm1k); + z_div(&z__1, &a[k + k * a_dim1], &z__2); + ak.r = z__1.r, ak.i = z__1.i; + z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i + + akm1.i * ak.r; + z__1.r = z__2.r - 1., z__1.i = z__2.i + 0.; + denom.r = z__1.r, denom.i = z__1.i; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + z_div(&z__1, &b[k - 1 + j * b_dim1], &akm1k); + bkm1.r = z__1.r, bkm1.i = z__1.i; + d_cnjg(&z__2, &akm1k); + z_div(&z__1, &b[k + j * b_dim1], &z__2); + bk.r = z__1.r, bk.i = z__1.i; + i__2 = k - 1 + j * b_dim1; + z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r * + bkm1.i + ak.i * bkm1.r; + z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i; + z_div(&z__1, &z__2, &denom); + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = k + j * b_dim1; + z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r * + bk.i + akm1.i * bk.r; + z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i; + z_div(&z__1, &z__2, &denom); + b[i__2].r = z__1.r, b[i__2].i = z__1.i; +/* L20: */ + } + k += -2; + } + + goto L10; +L30: + +/* Next solve U**H *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**H(K)), where U(K) is the transformation */ +/* stored in column K of A. */ + + if (k > 1) { + zlacgv_(nrhs, &b[k + b_dim1], ldb); + i__1 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset] + , ldb, &a[k * a_dim1 + 1], &c__1, &c_b1, &b[k + + b_dim1], ldb); + zlacgv_(nrhs, &b[k + b_dim1], ldb); + } + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + ++k; + } else { + +/* 2 x 2 diagonal block */ + +/* Multiply by inv(U**H(K+1)), where U(K+1) is the transformation */ +/* stored in columns K and K+1 of A. */ + + if (k > 1) { + zlacgv_(nrhs, &b[k + b_dim1], ldb); + i__1 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset] + , ldb, &a[k * a_dim1 + 1], &c__1, &c_b1, &b[k + + b_dim1], ldb); + zlacgv_(nrhs, &b[k + b_dim1], ldb); + + zlacgv_(nrhs, &b[k + 1 + b_dim1], ldb); + i__1 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset] + , ldb, &a[(k + 1) * a_dim1 + 1], &c__1, &c_b1, &b[k + + 1 + b_dim1], ldb); + zlacgv_(nrhs, &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) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + + kp = -ipiv[k + 1]; + if (kp != k + 1) { + zswap_(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**H. */ + +/* 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) { + zswap_(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; + z__1.r = -1., z__1.i = 0.; + zgeru_(&i__1, nrhs, &z__1, &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. */ + + i__1 = k + k * a_dim1; + s = 1. / a[i__1].r; + zdscal_(nrhs, &s, &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) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + + kp = -ipiv[k + 1]; + if (kp != k + 1) { + zswap_(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; + z__1.r = -1., z__1.i = 0.; + zgeru_(&i__1, nrhs, &z__1, &a[k + 2 + k * a_dim1], &c__1, &b[ + k + b_dim1], ldb, &b[k + 2 + b_dim1], ldb); + i__1 = *n - k - 1; + z__1.r = -1., z__1.i = 0.; + zgeru_(&i__1, nrhs, &z__1, &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. */ + + i__1 = k + 1 + k * a_dim1; + akm1k.r = a[i__1].r, akm1k.i = a[i__1].i; + d_cnjg(&z__2, &akm1k); + z_div(&z__1, &a[k + k * a_dim1], &z__2); + akm1.r = z__1.r, akm1.i = z__1.i; + z_div(&z__1, &a[k + 1 + (k + 1) * a_dim1], &akm1k); + ak.r = z__1.r, ak.i = z__1.i; + z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i + + akm1.i * ak.r; + z__1.r = z__2.r - 1., z__1.i = z__2.i + 0.; + denom.r = z__1.r, denom.i = z__1.i; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + d_cnjg(&z__2, &akm1k); + z_div(&z__1, &b[k + j * b_dim1], &z__2); + bkm1.r = z__1.r, bkm1.i = z__1.i; + z_div(&z__1, &b[k + 1 + j * b_dim1], &akm1k); + bk.r = z__1.r, bk.i = z__1.i; + i__2 = k + j * b_dim1; + z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r * + bkm1.i + ak.i * bkm1.r; + z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i; + z_div(&z__1, &z__2, &denom); + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = k + 1 + j * b_dim1; + z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r * + bk.i + akm1.i * bk.r; + z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i; + z_div(&z__1, &z__2, &denom); + b[i__2].r = z__1.r, b[i__2].i = z__1.i; +/* L70: */ + } + k += 2; + } + + goto L60; +L80: + +/* Next solve L**H *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**H(K)), where L(K) is the transformation */ +/* stored in column K of A. */ + + if (k < *n) { + zlacgv_(nrhs, &b[k + b_dim1], ldb); + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 + + b_dim1], ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, & + b[k + b_dim1], ldb); + zlacgv_(nrhs, &b[k + b_dim1], ldb); + } + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + --k; + } else { + +/* 2 x 2 diagonal block */ + +/* Multiply by inv(L**H(K-1)), where L(K-1) is the transformation */ +/* stored in columns K-1 and K of A. */ + + if (k < *n) { + zlacgv_(nrhs, &b[k + b_dim1], ldb); + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 + + b_dim1], ldb, &a[k + 1 + k * a_dim1], &c__1, &c_b1, & + b[k + b_dim1], ldb); + zlacgv_(nrhs, &b[k + b_dim1], ldb); + + zlacgv_(nrhs, &b[k - 1 + b_dim1], ldb); + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 + + b_dim1], ldb, &a[k + 1 + (k - 1) * a_dim1], &c__1, & + c_b1, &b[k - 1 + b_dim1], ldb); + zlacgv_(nrhs, &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) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + + kp = -ipiv[k - 1]; + if (kp != k - 1) { + zswap_(nrhs, &b[k - 1 + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + + k += -2; + } + + goto L90; +L100: + ; + } + + return 0; + +/* End of ZHETRS_ROOK */ + +} /* zhetrs_rook__ */ + diff --git a/lapack-netlib/SRC/zhfrk.c b/lapack-netlib/SRC/zhfrk.c new file mode 100644 index 000000000..2722c59a7 --- /dev/null +++ b/lapack-netlib/SRC/zhfrk.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 ZHFRK performs a Hermitian rank-k operation for matrix in RFP format. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHFRK + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHFRK( TRANSR, UPLO, TRANS, N, K, ALPHA, A, LDA, BETA, */ +/* C ) */ + +/* DOUBLE PRECISION ALPHA, BETA */ +/* INTEGER K, LDA, N */ +/* CHARACTER TRANS, TRANSR, UPLO */ +/* COMPLEX*16 A( LDA, * ), C( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Level 3 BLAS like routine for C in RFP Format. */ +/* > */ +/* > ZHFRK performs one of the Hermitian rank--k operations */ +/* > */ +/* > C := alpha*A*A**H + beta*C, */ +/* > */ +/* > or */ +/* > */ +/* > C := alpha*A**H*A + beta*C, */ +/* > */ +/* > where alpha and beta are real scalars, C is an n--by--n Hermitian */ +/* > matrix and A is an n--by--k matrix in the first case and a k--by--n */ +/* > matrix in the second case. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANSR */ +/* > \verbatim */ +/* > TRANSR is CHARACTER*1 */ +/* > = 'N': The Normal Form of RFP A is stored; */ +/* > = 'C': The Conjugate-transpose Form of RFP A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > On entry, UPLO specifies whether the upper or lower */ +/* > triangular part of the array C is to be referenced as */ +/* > follows: */ +/* > */ +/* > UPLO = 'U' or 'u' Only the upper triangular part of C */ +/* > is to be referenced. */ +/* > */ +/* > UPLO = 'L' or 'l' Only the lower triangular part of C */ +/* > is to be referenced. */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is CHARACTER*1 */ +/* > On entry, TRANS specifies the operation to be performed as */ +/* > follows: */ +/* > */ +/* > TRANS = 'N' or 'n' C := alpha*A*A**H + beta*C. */ +/* > */ +/* > TRANS = 'C' or 'c' C := alpha*A**H*A + beta*C. */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > On entry, N specifies the order of the matrix C. N must be */ +/* > at least zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] K */ +/* > \verbatim */ +/* > K is INTEGER */ +/* > On entry with TRANS = 'N' or 'n', K specifies the number */ +/* > of columns of the matrix A, and on entry with */ +/* > TRANS = 'C' or 'c', K specifies the number of rows of the */ +/* > matrix A. K must be at least zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ALPHA */ +/* > \verbatim */ +/* > ALPHA is DOUBLE PRECISION */ +/* > On entry, ALPHA specifies the scalar alpha. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,ka) */ +/* > where KA */ +/* > is K when TRANS = 'N' or 'n', and is N otherwise. Before */ +/* > entry with TRANS = 'N' or 'n', the leading N--by--K part of */ +/* > the array A must contain the matrix A, otherwise the leading */ +/* > K--by--N part of the array A must contain the matrix A. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > On entry, LDA specifies the first dimension of A as declared */ +/* > in the calling (sub) program. When TRANS = 'N' or 'n' */ +/* > then LDA must be at least f2cmax( 1, n ), otherwise LDA must */ +/* > be at least f2cmax( 1, k ). */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION */ +/* > On entry, BETA specifies the scalar beta. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] C */ +/* > \verbatim */ +/* > C is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > On entry, the matrix A in RFP Format. RFP Format is */ +/* > described by TRANSR, UPLO and N. Note that the imaginary */ +/* > parts of the diagonal elements need not be set, they are */ +/* > assumed to be zero, and on exit they are set to zero. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup complex16OTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zhfrk_(char *transr, char *uplo, char *trans, integer *n, + integer *k, doublereal *alpha, doublecomplex *a, integer *lda, + doublereal *beta, doublecomplex *c__) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2; + doublecomplex z__1; + + /* Local variables */ + integer info, j; + doublecomplex cbeta; + logical normaltransr; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int zgemm_(char *, char *, integer *, integer *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *), zherk_(char *, char *, integer *, + integer *, doublereal *, doublecomplex *, integer *, doublereal *, + doublecomplex *, integer *); + integer nrowa; + logical lower; + integer n1, n2; + doublecomplex calpha; + integer nk; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + logical nisodd, notrans; + + +/* -- LAPACK computational routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --c__; + + /* Function Body */ + info = 0; + normaltransr = lsame_(transr, "N"); + lower = lsame_(uplo, "L"); + notrans = lsame_(trans, "N"); + + if (notrans) { + nrowa = *n; + } else { + nrowa = *k; + } + + if (! normaltransr && ! lsame_(transr, "C")) { + info = -1; + } else if (! lower && ! lsame_(uplo, "U")) { + info = -2; + } else if (! notrans && ! lsame_(trans, "C")) { + info = -3; + } else if (*n < 0) { + info = -4; + } else if (*k < 0) { + info = -5; + } else if (*lda < f2cmax(1,nrowa)) { + info = -8; + } + if (info != 0) { + i__1 = -info; + xerbla_("ZHFRK ", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible. */ + +/* The quick return case: ((ALPHA.EQ.0).AND.(BETA.NE.ZERO)) is not */ +/* done (it is in ZHERK for example) and left in the general case. */ + + if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) { + return 0; + } + + if (*alpha == 0. && *beta == 0.) { + i__1 = *n * (*n + 1) / 2; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + c__[i__2].r = 0., c__[i__2].i = 0.; + } + return 0; + } + + z__1.r = *alpha, z__1.i = 0.; + calpha.r = z__1.r, calpha.i = z__1.i; + z__1.r = *beta, z__1.i = 0.; + cbeta.r = z__1.r, cbeta.i = z__1.i; + +/* C is N-by-N. */ +/* If N is odd, set NISODD = .TRUE., and N1 and N2. */ +/* If N is even, NISODD = .FALSE., and NK. */ + + if (*n % 2 == 0) { + nisodd = FALSE_; + nk = *n / 2; + } else { + nisodd = TRUE_; + if (lower) { + n2 = *n / 2; + n1 = *n - n2; + } else { + n1 = *n / 2; + n2 = *n - n1; + } + } + + if (nisodd) { + +/* N is odd */ + + if (normaltransr) { + +/* N is odd and TRANSR = 'N' */ + + if (lower) { + +/* N is odd, TRANSR = 'N', and UPLO = 'L' */ + + if (notrans) { + +/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' */ + + zherk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[1], n); + zherk_("U", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda, + beta, &c__[*n + 1], n); + zgemm_("N", "C", &n2, &n1, k, &calpha, &a[n1 + 1 + a_dim1] + , lda, &a[a_dim1 + 1], lda, &cbeta, &c__[n1 + 1], + n); + + } else { + +/* N is odd, TRANSR = 'N', UPLO = 'L', and TRANS = 'C' */ + + zherk_("L", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[1], n); + zherk_("U", "C", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1], + lda, beta, &c__[*n + 1], n) + ; + zgemm_("C", "N", &n2, &n1, k, &calpha, &a[(n1 + 1) * + a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, & + c__[n1 + 1], n); + + } + + } else { + +/* N is odd, TRANSR = 'N', and UPLO = 'U' */ + + if (notrans) { + +/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' */ + + zherk_("L", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[n2 + 1], n); + zherk_("U", "N", &n2, k, alpha, &a[n2 + a_dim1], lda, + beta, &c__[n1 + 1], n); + zgemm_("N", "C", &n1, &n2, k, &calpha, &a[a_dim1 + 1], + lda, &a[n2 + a_dim1], lda, &cbeta, &c__[1], n); + + } else { + +/* N is odd, TRANSR = 'N', UPLO = 'U', and TRANS = 'C' */ + + zherk_("L", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[n2 + 1], n); + zherk_("U", "C", &n2, k, alpha, &a[n2 * a_dim1 + 1], lda, + beta, &c__[n1 + 1], n); + zgemm_("C", "N", &n1, &n2, k, &calpha, &a[a_dim1 + 1], + lda, &a[n2 * a_dim1 + 1], lda, &cbeta, &c__[1], n); + + } + + } + + } else { + +/* N is odd, and TRANSR = 'C' */ + + if (lower) { + +/* N is odd, TRANSR = 'C', and UPLO = 'L' */ + + if (notrans) { + +/* N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'N' */ + + zherk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[1], &n1); + zherk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda, + beta, &c__[2], &n1); + zgemm_("N", "C", &n1, &n2, k, &calpha, &a[a_dim1 + 1], + lda, &a[n1 + 1 + a_dim1], lda, &cbeta, &c__[n1 * + n1 + 1], &n1); + + } else { + +/* N is odd, TRANSR = 'C', UPLO = 'L', and TRANS = 'C' */ + + zherk_("U", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[1], &n1); + zherk_("L", "C", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1], + lda, beta, &c__[2], &n1); + zgemm_("C", "N", &n1, &n2, k, &calpha, &a[a_dim1 + 1], + lda, &a[(n1 + 1) * a_dim1 + 1], lda, &cbeta, &c__[ + n1 * n1 + 1], &n1); + + } + + } else { + +/* N is odd, TRANSR = 'C', and UPLO = 'U' */ + + if (notrans) { + +/* N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'N' */ + + zherk_("U", "N", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[n2 * n2 + 1], &n2); + zherk_("L", "N", &n2, k, alpha, &a[n1 + 1 + a_dim1], lda, + beta, &c__[n1 * n2 + 1], &n2); + zgemm_("N", "C", &n2, &n1, k, &calpha, &a[n1 + 1 + a_dim1] + , lda, &a[a_dim1 + 1], lda, &cbeta, &c__[1], &n2); + + } else { + +/* N is odd, TRANSR = 'C', UPLO = 'U', and TRANS = 'C' */ + + zherk_("U", "C", &n1, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[n2 * n2 + 1], &n2); + zherk_("L", "C", &n2, k, alpha, &a[(n1 + 1) * a_dim1 + 1], + lda, beta, &c__[n1 * n2 + 1], &n2); + zgemm_("C", "N", &n2, &n1, k, &calpha, &a[(n1 + 1) * + a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, & + c__[1], &n2); + + } + + } + + } + + } else { + +/* N is even */ + + if (normaltransr) { + +/* N is even and TRANSR = 'N' */ + + if (lower) { + +/* N is even, TRANSR = 'N', and UPLO = 'L' */ + + if (notrans) { + +/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'N' */ + + i__1 = *n + 1; + zherk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[2], &i__1); + i__1 = *n + 1; + zherk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, + beta, &c__[1], &i__1); + i__1 = *n + 1; + zgemm_("N", "C", &nk, &nk, k, &calpha, &a[nk + 1 + a_dim1] + , lda, &a[a_dim1 + 1], lda, &cbeta, &c__[nk + 2], + &i__1); + + } else { + +/* N is even, TRANSR = 'N', UPLO = 'L', and TRANS = 'C' */ + + i__1 = *n + 1; + zherk_("L", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[2], &i__1); + i__1 = *n + 1; + zherk_("U", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], + lda, beta, &c__[1], &i__1); + i__1 = *n + 1; + zgemm_("C", "N", &nk, &nk, k, &calpha, &a[(nk + 1) * + a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, & + c__[nk + 2], &i__1); + + } + + } else { + +/* N is even, TRANSR = 'N', and UPLO = 'U' */ + + if (notrans) { + +/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'N' */ + + i__1 = *n + 1; + zherk_("L", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[nk + 2], &i__1); + i__1 = *n + 1; + zherk_("U", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, + beta, &c__[nk + 1], &i__1); + i__1 = *n + 1; + zgemm_("N", "C", &nk, &nk, k, &calpha, &a[a_dim1 + 1], + lda, &a[nk + 1 + a_dim1], lda, &cbeta, &c__[1], & + i__1); + + } else { + +/* N is even, TRANSR = 'N', UPLO = 'U', and TRANS = 'C' */ + + i__1 = *n + 1; + zherk_("L", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[nk + 2], &i__1); + i__1 = *n + 1; + zherk_("U", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], + lda, beta, &c__[nk + 1], &i__1); + i__1 = *n + 1; + zgemm_("C", "N", &nk, &nk, k, &calpha, &a[a_dim1 + 1], + lda, &a[(nk + 1) * a_dim1 + 1], lda, &cbeta, &c__[ + 1], &i__1); + + } + + } + + } else { + +/* N is even, and TRANSR = 'C' */ + + if (lower) { + +/* N is even, TRANSR = 'C', and UPLO = 'L' */ + + if (notrans) { + +/* N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'N' */ + + zherk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[nk + 1], &nk); + zherk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, + beta, &c__[1], &nk); + zgemm_("N", "C", &nk, &nk, k, &calpha, &a[a_dim1 + 1], + lda, &a[nk + 1 + a_dim1], lda, &cbeta, &c__[(nk + + 1) * nk + 1], &nk); + + } else { + +/* N is even, TRANSR = 'C', UPLO = 'L', and TRANS = 'C' */ + + zherk_("U", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[nk + 1], &nk); + zherk_("L", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], + lda, beta, &c__[1], &nk); + zgemm_("C", "N", &nk, &nk, k, &calpha, &a[a_dim1 + 1], + lda, &a[(nk + 1) * a_dim1 + 1], lda, &cbeta, &c__[ + (nk + 1) * nk + 1], &nk); + + } + + } else { + +/* N is even, TRANSR = 'C', and UPLO = 'U' */ + + if (notrans) { + +/* N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'N' */ + + zherk_("U", "N", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[nk * (nk + 1) + 1], &nk); + zherk_("L", "N", &nk, k, alpha, &a[nk + 1 + a_dim1], lda, + beta, &c__[nk * nk + 1], &nk); + zgemm_("N", "C", &nk, &nk, k, &calpha, &a[nk + 1 + a_dim1] + , lda, &a[a_dim1 + 1], lda, &cbeta, &c__[1], &nk); + + } else { + +/* N is even, TRANSR = 'C', UPLO = 'U', and TRANS = 'C' */ + + zherk_("U", "C", &nk, k, alpha, &a[a_dim1 + 1], lda, beta, + &c__[nk * (nk + 1) + 1], &nk); + zherk_("L", "C", &nk, k, alpha, &a[(nk + 1) * a_dim1 + 1], + lda, beta, &c__[nk * nk + 1], &nk); + zgemm_("C", "N", &nk, &nk, k, &calpha, &a[(nk + 1) * + a_dim1 + 1], lda, &a[a_dim1 + 1], lda, &cbeta, & + c__[1], &nk); + + } + + } + + } + + } + + return 0; + +/* End of ZHFRK */ + +} /* zhfrk_ */ + diff --git a/lapack-netlib/SRC/zhgeqz.c b/lapack-netlib/SRC/zhgeqz.c new file mode 100644 index 000000000..a2dfb1616 --- /dev/null +++ b/lapack-netlib/SRC/zhgeqz.c @@ -0,0 +1,1634 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHGEQZ */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHGEQZ + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, */ +/* ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, */ +/* RWORK, INFO ) */ + +/* CHARACTER COMPQ, COMPZ, JOB */ +/* INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N */ +/* DOUBLE PRECISION RWORK( * ) */ +/* COMPLEX*16 ALPHA( * ), BETA( * ), H( LDH, * ), */ +/* $ Q( LDQ, * ), T( LDT, * ), WORK( * ), */ +/* $ Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHGEQZ computes the eigenvalues of a complex matrix pair (H,T), */ +/* > where H is an upper Hessenberg matrix and T is upper triangular, */ +/* > using the single-shift QZ method. */ +/* > Matrix pairs of this type are produced by the reduction to */ +/* > generalized upper Hessenberg form of a complex matrix pair (A,B): */ +/* > */ +/* > A = Q1*H*Z1**H, B = Q1*T*Z1**H, */ +/* > */ +/* > as computed by ZGGHRD. */ +/* > */ +/* > If JOB='S', then the Hessenberg-triangular pair (H,T) is */ +/* > also reduced to generalized Schur form, */ +/* > */ +/* > H = Q*S*Z**H, T = Q*P*Z**H, */ +/* > */ +/* > where Q and Z are unitary matrices and S and P are upper triangular. */ +/* > */ +/* > Optionally, the unitary matrix Q from the generalized Schur */ +/* > factorization may be postmultiplied into an input matrix Q1, and the */ +/* > unitary matrix Z may be postmultiplied into an input matrix Z1. */ +/* > If Q1 and Z1 are the unitary matrices from ZGGHRD that reduced */ +/* > the matrix pair (A,B) to generalized Hessenberg form, then the output */ +/* > matrices Q1*Q and Z1*Z are the unitary factors from the generalized */ +/* > Schur factorization of (A,B): */ +/* > */ +/* > A = (Q1*Q)*S*(Z1*Z)**H, B = (Q1*Q)*P*(Z1*Z)**H. */ +/* > */ +/* > To avoid overflow, eigenvalues of the matrix pair (H,T) */ +/* > (equivalently, of (A,B)) are computed as a pair of complex values */ +/* > (alpha,beta). If beta is nonzero, lambda = alpha / beta is an */ +/* > eigenvalue of the generalized nonsymmetric eigenvalue problem (GNEP) */ +/* > A*x = lambda*B*x */ +/* > and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the */ +/* > alternate form of the GNEP */ +/* > mu*A*y = B*y. */ +/* > The values of alpha and beta for the i-th eigenvalue can be read */ +/* > directly from the generalized Schur form: alpha = S(i,i), */ +/* > beta = P(i,i). */ +/* > */ +/* > Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix */ +/* > Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973), */ +/* > pp. 241--256. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOB */ +/* > \verbatim */ +/* > JOB is CHARACTER*1 */ +/* > = 'E': Compute eigenvalues only; */ +/* > = 'S': Computer eigenvalues and the Schur form. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COMPQ */ +/* > \verbatim */ +/* > COMPQ is CHARACTER*1 */ +/* > = 'N': Left Schur vectors (Q) are not computed; */ +/* > = 'I': Q is initialized to the unit matrix and the matrix Q */ +/* > of left Schur vectors of (H,T) is returned; */ +/* > = 'V': Q must contain a unitary matrix Q1 on entry and */ +/* > the product Q1*Q is returned. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COMPZ */ +/* > \verbatim */ +/* > COMPZ is CHARACTER*1 */ +/* > = 'N': Right Schur vectors (Z) are not computed; */ +/* > = 'I': Q is initialized to the unit matrix and the matrix Z */ +/* > of right Schur vectors of (H,T) is returned; */ +/* > = 'V': Z must contain a unitary matrix Z1 on entry and */ +/* > the product Z1*Z is returned. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices H, T, Q, and Z. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILO */ +/* > \verbatim */ +/* > ILO is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHI */ +/* > \verbatim */ +/* > IHI is INTEGER */ +/* > ILO and IHI mark the rows and columns of H which are in */ +/* > Hessenberg form. It is assumed that A is already upper */ +/* > triangular in rows and columns 1:ILO-1 and IHI+1:N. */ +/* > If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] H */ +/* > \verbatim */ +/* > H is COMPLEX*16 array, dimension (LDH, N) */ +/* > On entry, the N-by-N upper Hessenberg matrix H. */ +/* > On exit, if JOB = 'S', H contains the upper triangular */ +/* > matrix S from the generalized Schur factorization. */ +/* > If JOB = 'E', the diagonal of H matches that of S, but */ +/* > the rest of H is unspecified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > The leading dimension of the array H. LDH >= f2cmax( 1, N ). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] T */ +/* > \verbatim */ +/* > T is COMPLEX*16 array, dimension (LDT, N) */ +/* > On entry, the N-by-N upper triangular matrix T. */ +/* > On exit, if JOB = 'S', T contains the upper triangular */ +/* > matrix P from the generalized Schur factorization. */ +/* > If JOB = 'E', the diagonal of T matches that of P, but */ +/* > the rest of T is unspecified. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDT */ +/* > \verbatim */ +/* > LDT is INTEGER */ +/* > The leading dimension of the array T. LDT >= f2cmax( 1, N ). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] ALPHA */ +/* > \verbatim */ +/* > ALPHA is COMPLEX*16 array, dimension (N) */ +/* > The complex scalars alpha that define the eigenvalues of */ +/* > GNEP. ALPHA(i) = S(i,i) in the generalized Schur */ +/* > factorization. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BETA */ +/* > \verbatim */ +/* > BETA is COMPLEX*16 array, dimension (N) */ +/* > The real non-negative scalars beta that define the */ +/* > eigenvalues of GNEP. BETA(i) = P(i,i) in the generalized */ +/* > Schur factorization. */ +/* > */ +/* > Together, the quantities alpha = ALPHA(j) and beta = BETA(j) */ +/* > represent the j-th eigenvalue of the matrix pair (A,B), in */ +/* > one of the forms lambda = alpha/beta or mu = beta/alpha. */ +/* > Since either lambda or mu may overflow, they should not, */ +/* > in general, be computed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Q */ +/* > \verbatim */ +/* > Q is COMPLEX*16 array, dimension (LDQ, N) */ +/* > On entry, if COMPQ = 'V', the unitary matrix Q1 used in the */ +/* > reduction of (A,B) to generalized Hessenberg form. */ +/* > On exit, if COMPQ = 'I', the unitary matrix of left Schur */ +/* > vectors of (H,T), and if COMPQ = 'V', the unitary matrix of */ +/* > left Schur vectors of (A,B). */ +/* > Not referenced if COMPQ = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDQ */ +/* > \verbatim */ +/* > LDQ is INTEGER */ +/* > The leading dimension of the array Q. LDQ >= 1. */ +/* > If COMPQ='V' or 'I', then LDQ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX*16 array, dimension (LDZ, N) */ +/* > On entry, if COMPZ = 'V', the unitary matrix Z1 used in the */ +/* > reduction of (A,B) to generalized Hessenberg form. */ +/* > On exit, if COMPZ = 'I', the unitary matrix of right Schur */ +/* > vectors of (H,T), and if COMPZ = 'V', the unitary matrix of */ +/* > right Schur vectors of (A,B). */ +/* > Not referenced if COMPZ = 'N'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1. */ +/* > If COMPZ='V' or 'I', then LDZ >= N. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO >= 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,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] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > = 1,...,N: the QZ iteration did not converge. (H,T) is not */ +/* > in Schur form, but ALPHA(i) and BETA(i), */ +/* > i=INFO+1,...,N should be correct. */ +/* > = N+1,...,2*N: the shift calculation failed. (H,T) is not */ +/* > in Schur form, but ALPHA(i) and BETA(i), */ +/* > i=INFO-N+1,...,N should be correct. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup complex16GEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > We assume that complex ABS works as long as its value is less than */ +/* > overflow. */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zhgeqz_(char *job, char *compq, char *compz, integer *n, + integer *ilo, integer *ihi, doublecomplex *h__, integer *ldh, + doublecomplex *t, integer *ldt, doublecomplex *alpha, doublecomplex * + beta, doublecomplex *q, integer *ldq, doublecomplex *z__, integer * + ldz, doublecomplex *work, integer *lwork, doublereal *rwork, integer * + info) +{ + /* System generated locals */ + integer h_dim1, h_offset, q_dim1, q_offset, t_dim1, t_offset, z_dim1, + z_offset, i__1, i__2, i__3, i__4, i__5, i__6; + doublereal d__1, d__2, d__3, d__4, d__5, d__6; + doublecomplex z__1, z__2, z__3, z__4, z__5, z__6, z__7; + + /* Local variables */ + doublereal absb, atol, btol, temp; + extern /* Subroutine */ int zrot_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *, doublereal *, doublecomplex *); + doublereal temp2, c__; + integer j; + doublecomplex s, x, y; + extern logical lsame_(char *, char *); + doublecomplex ctemp; + integer iiter, ilast, jiter; + doublereal anorm, bnorm; + integer maxit; + doublecomplex shift; + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *); + doublereal tempr; + doublecomplex ctemp2, ctemp3; + logical ilazr2; + integer jc, in; + doublereal ascale, bscale; + doublecomplex u12; + extern doublereal dlamch_(char *); + integer jr; + doublecomplex signbc; + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublecomplex eshift; + logical ilschr; + integer icompq, ilastm; + extern /* Double Complex */ VOID zladiv_(doublecomplex *, doublecomplex *, + doublecomplex *); + integer ischur; + extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *, + doublereal *); + logical ilazro; + integer icompz, ifirst; + extern /* Subroutine */ int zlartg_(doublecomplex *, doublecomplex *, + doublereal *, doublecomplex *, doublecomplex *); + integer ifrstm; + extern /* Subroutine */ int zlaset_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *); + integer istart; + logical lquery; + doublecomplex ad11, ad12, ad21, ad22; + integer jch; + logical ilq, ilz; + doublereal ulp; + doublecomplex abi12, abi22; + + +/* -- 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 JOB, COMPQ, COMPZ */ + + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + t_dim1 = *ldt; + t_offset = 1 + t_dim1 * 1; + t -= t_offset; + --alpha; + --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; + --work; + --rwork; + + /* Function Body */ + if (lsame_(job, "E")) { + ilschr = FALSE_; + ischur = 1; + } else if (lsame_(job, "S")) { + ilschr = TRUE_; + ischur = 2; + } else { + ilschr = TRUE_; + ischur = 0; + } + + if (lsame_(compq, "N")) { + ilq = FALSE_; + icompq = 1; + } else if (lsame_(compq, "V")) { + ilq = TRUE_; + icompq = 2; + } else if (lsame_(compq, "I")) { + ilq = TRUE_; + icompq = 3; + } else { + ilq = TRUE_; + icompq = 0; + } + + if (lsame_(compz, "N")) { + ilz = FALSE_; + icompz = 1; + } else if (lsame_(compz, "V")) { + ilz = TRUE_; + icompz = 2; + } else if (lsame_(compz, "I")) { + ilz = TRUE_; + icompz = 3; + } else { + ilz = TRUE_; + icompz = 0; + } + +/* Check Argument Values */ + + *info = 0; + i__1 = f2cmax(1,*n); + work[1].r = (doublereal) i__1, work[1].i = 0.; + lquery = *lwork == -1; + if (ischur == 0) { + *info = -1; + } else if (icompq == 0) { + *info = -2; + } else if (icompz == 0) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*ilo < 1) { + *info = -5; + } else if (*ihi > *n || *ihi < *ilo - 1) { + *info = -6; + } else if (*ldh < *n) { + *info = -8; + } else if (*ldt < *n) { + *info = -10; + } else if (*ldq < 1 || ilq && *ldq < *n) { + *info = -14; + } else if (*ldz < 1 || ilz && *ldz < *n) { + *info = -16; + } else if (*lwork < f2cmax(1,*n) && ! lquery) { + *info = -18; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHGEQZ", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + +/* WORK( 1 ) = CMPLX( 1 ) */ + if (*n <= 0) { + work[1].r = 1., work[1].i = 0.; + return 0; + } + +/* Initialize Q and Z */ + + if (icompq == 3) { + zlaset_("Full", n, n, &c_b1, &c_b2, &q[q_offset], ldq); + } + if (icompz == 3) { + zlaset_("Full", n, n, &c_b1, &c_b2, &z__[z_offset], ldz); + } + +/* Machine Constants */ + + in = *ihi + 1 - *ilo; + safmin = dlamch_("S"); + ulp = dlamch_("E") * dlamch_("B"); + anorm = zlanhs_("F", &in, &h__[*ilo + *ilo * h_dim1], ldh, &rwork[1]); + bnorm = zlanhs_("F", &in, &t[*ilo + *ilo * t_dim1], ldt, &rwork[1]); +/* Computing MAX */ + d__1 = safmin, d__2 = ulp * anorm; + atol = f2cmax(d__1,d__2); +/* Computing MAX */ + d__1 = safmin, d__2 = ulp * bnorm; + btol = f2cmax(d__1,d__2); + ascale = 1. / f2cmax(safmin,anorm); + bscale = 1. / f2cmax(safmin,bnorm); + + +/* Set Eigenvalues IHI+1:N */ + + i__1 = *n; + for (j = *ihi + 1; j <= i__1; ++j) { + absb = z_abs(&t[j + j * t_dim1]); + if (absb > safmin) { + i__2 = j + j * t_dim1; + z__2.r = t[i__2].r / absb, z__2.i = t[i__2].i / absb; + d_cnjg(&z__1, &z__2); + signbc.r = z__1.r, signbc.i = z__1.i; + i__2 = j + j * t_dim1; + t[i__2].r = absb, t[i__2].i = 0.; + if (ilschr) { + i__2 = j - 1; + zscal_(&i__2, &signbc, &t[j * t_dim1 + 1], &c__1); + zscal_(&j, &signbc, &h__[j * h_dim1 + 1], &c__1); + } else { + zscal_(&c__1, &signbc, &h__[j + j * h_dim1], &c__1); + } + if (ilz) { + zscal_(n, &signbc, &z__[j * z_dim1 + 1], &c__1); + } + } else { + i__2 = j + j * t_dim1; + t[i__2].r = 0., t[i__2].i = 0.; + } + i__2 = j; + i__3 = j + j * h_dim1; + alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i; + i__2 = j; + i__3 = j + j * t_dim1; + beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i; +/* L10: */ + } + +/* If IHI < ILO, skip QZ steps */ + + if (*ihi < *ilo) { + goto L190; + } + +/* MAIN QZ ITERATION LOOP */ + +/* Initialize dynamic indices */ + +/* Eigenvalues ILAST+1:N have been found. */ +/* Column operations modify rows IFRSTM:whatever */ +/* Row operations modify columns whatever:ILASTM */ + +/* If only eigenvalues are being computed, then */ +/* IFRSTM is the row of the last splitting row above row ILAST; */ +/* this is always at least ILO. */ +/* IITER counts iterations since the last eigenvalue was found, */ +/* to tell when to use an extraordinary shift. */ +/* MAXIT is the maximum number of QZ sweeps allowed. */ + + ilast = *ihi; + if (ilschr) { + ifrstm = 1; + ilastm = *n; + } else { + ifrstm = *ilo; + ilastm = *ihi; + } + iiter = 0; + eshift.r = 0., eshift.i = 0.; + maxit = (*ihi - *ilo + 1) * 30; + + i__1 = maxit; + for (jiter = 1; jiter <= i__1; ++jiter) { + +/* Check for too many iterations. */ + + if (jiter > maxit) { + goto L180; + } + +/* Split the matrix if possible. */ + +/* Two tests: */ +/* 1: H(j,j-1)=0 or j=ILO */ +/* 2: T(j,j)=0 */ + +/* Special case: j=ILAST */ + + if (ilast == *ilo) { + goto L60; + } else { + i__2 = ilast + (ilast - 1) * h_dim1; + if ((d__1 = h__[i__2].r, abs(d__1)) + (d__2 = d_imag(&h__[ilast + + (ilast - 1) * h_dim1]), abs(d__2)) <= atol) { + i__2 = ilast + (ilast - 1) * h_dim1; + h__[i__2].r = 0., h__[i__2].i = 0.; + goto L60; + } + } + + if (z_abs(&t[ilast + ilast * t_dim1]) <= btol) { + i__2 = ilast + ilast * t_dim1; + t[i__2].r = 0., t[i__2].i = 0.; + goto L50; + } + +/* General case: j= i__2; --j) { + +/* Test 1: for H(j,j-1)=0 or j=ILO */ + + if (j == *ilo) { + ilazro = TRUE_; + } else { + i__3 = j + (j - 1) * h_dim1; + if ((d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(&h__[j + + (j - 1) * h_dim1]), abs(d__2)) <= atol) { + i__3 = j + (j - 1) * h_dim1; + h__[i__3].r = 0., h__[i__3].i = 0.; + ilazro = TRUE_; + } else { + ilazro = FALSE_; + } + } + +/* Test 2: for T(j,j)=0 */ + + if (z_abs(&t[j + j * t_dim1]) < btol) { + i__3 = j + j * t_dim1; + t[i__3].r = 0., t[i__3].i = 0.; + +/* Test 1a: Check for 2 consecutive small subdiagonals in A */ + + ilazr2 = FALSE_; + if (! ilazro) { + i__3 = j + (j - 1) * h_dim1; + i__4 = j + 1 + j * h_dim1; + i__5 = j + j * h_dim1; + if (((d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(& + h__[j + (j - 1) * h_dim1]), abs(d__2))) * (ascale + * ((d__3 = h__[i__4].r, abs(d__3)) + (d__4 = + d_imag(&h__[j + 1 + j * h_dim1]), abs(d__4)))) <= + ((d__5 = h__[i__5].r, abs(d__5)) + (d__6 = d_imag( + &h__[j + j * h_dim1]), abs(d__6))) * (ascale * + atol)) { + ilazr2 = TRUE_; + } + } + +/* If both tests pass (1 & 2), i.e., the leading diagonal */ +/* element of B in the block is zero, split a 1x1 block off */ +/* at the top. (I.e., at the J-th row/column) The leading */ +/* diagonal element of the remainder can also be zero, so */ +/* this may have to be done repeatedly. */ + + if (ilazro || ilazr2) { + i__3 = ilast - 1; + for (jch = j; jch <= i__3; ++jch) { + i__4 = jch + jch * h_dim1; + ctemp.r = h__[i__4].r, ctemp.i = h__[i__4].i; + zlartg_(&ctemp, &h__[jch + 1 + jch * h_dim1], &c__, & + s, &h__[jch + jch * h_dim1]); + i__4 = jch + 1 + jch * h_dim1; + h__[i__4].r = 0., h__[i__4].i = 0.; + i__4 = ilastm - jch; + zrot_(&i__4, &h__[jch + (jch + 1) * h_dim1], ldh, & + h__[jch + 1 + (jch + 1) * h_dim1], ldh, &c__, + &s); + i__4 = ilastm - jch; + zrot_(&i__4, &t[jch + (jch + 1) * t_dim1], ldt, &t[ + jch + 1 + (jch + 1) * t_dim1], ldt, &c__, &s); + if (ilq) { + d_cnjg(&z__1, &s); + zrot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1) + * q_dim1 + 1], &c__1, &c__, &z__1); + } + if (ilazr2) { + i__4 = jch + (jch - 1) * h_dim1; + i__5 = jch + (jch - 1) * h_dim1; + z__1.r = c__ * h__[i__5].r, z__1.i = c__ * h__[ + i__5].i; + h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; + } + ilazr2 = FALSE_; + i__4 = jch + 1 + (jch + 1) * t_dim1; + if ((d__1 = t[i__4].r, abs(d__1)) + (d__2 = d_imag(&t[ + jch + 1 + (jch + 1) * t_dim1]), abs(d__2)) >= + btol) { + if (jch + 1 >= ilast) { + goto L60; + } else { + ifirst = jch + 1; + goto L70; + } + } + i__4 = jch + 1 + (jch + 1) * t_dim1; + t[i__4].r = 0., t[i__4].i = 0.; +/* L20: */ + } + goto L50; + } else { + +/* Only test 2 passed -- chase the zero to T(ILAST,ILAST) */ +/* Then process as in the case T(ILAST,ILAST)=0 */ + + i__3 = ilast - 1; + for (jch = j; jch <= i__3; ++jch) { + i__4 = jch + (jch + 1) * t_dim1; + ctemp.r = t[i__4].r, ctemp.i = t[i__4].i; + zlartg_(&ctemp, &t[jch + 1 + (jch + 1) * t_dim1], & + c__, &s, &t[jch + (jch + 1) * t_dim1]); + i__4 = jch + 1 + (jch + 1) * t_dim1; + t[i__4].r = 0., t[i__4].i = 0.; + if (jch < ilastm - 1) { + i__4 = ilastm - jch - 1; + zrot_(&i__4, &t[jch + (jch + 2) * t_dim1], ldt, & + t[jch + 1 + (jch + 2) * t_dim1], ldt, & + c__, &s); + } + i__4 = ilastm - jch + 2; + zrot_(&i__4, &h__[jch + (jch - 1) * h_dim1], ldh, & + h__[jch + 1 + (jch - 1) * h_dim1], ldh, &c__, + &s); + if (ilq) { + d_cnjg(&z__1, &s); + zrot_(n, &q[jch * q_dim1 + 1], &c__1, &q[(jch + 1) + * q_dim1 + 1], &c__1, &c__, &z__1); + } + i__4 = jch + 1 + jch * h_dim1; + ctemp.r = h__[i__4].r, ctemp.i = h__[i__4].i; + zlartg_(&ctemp, &h__[jch + 1 + (jch - 1) * h_dim1], & + c__, &s, &h__[jch + 1 + jch * h_dim1]); + i__4 = jch + 1 + (jch - 1) * h_dim1; + h__[i__4].r = 0., h__[i__4].i = 0.; + i__4 = jch + 1 - ifrstm; + zrot_(&i__4, &h__[ifrstm + jch * h_dim1], &c__1, &h__[ + ifrstm + (jch - 1) * h_dim1], &c__1, &c__, &s) + ; + i__4 = jch - ifrstm; + zrot_(&i__4, &t[ifrstm + jch * t_dim1], &c__1, &t[ + ifrstm + (jch - 1) * t_dim1], &c__1, &c__, &s) + ; + if (ilz) { + zrot_(n, &z__[jch * z_dim1 + 1], &c__1, &z__[(jch + - 1) * z_dim1 + 1], &c__1, &c__, &s); + } +/* L30: */ + } + goto L50; + } + } else if (ilazro) { + +/* Only test 1 passed -- work on J:ILAST */ + + ifirst = j; + goto L70; + } + +/* Neither test passed -- try next J */ + +/* L40: */ + } + +/* (Drop-through is "impossible") */ + + *info = (*n << 1) + 1; + goto L210; + +/* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a */ +/* 1x1 block. */ + +L50: + i__2 = ilast + ilast * h_dim1; + ctemp.r = h__[i__2].r, ctemp.i = h__[i__2].i; + zlartg_(&ctemp, &h__[ilast + (ilast - 1) * h_dim1], &c__, &s, &h__[ + ilast + ilast * h_dim1]); + i__2 = ilast + (ilast - 1) * h_dim1; + h__[i__2].r = 0., h__[i__2].i = 0.; + i__2 = ilast - ifrstm; + zrot_(&i__2, &h__[ifrstm + ilast * h_dim1], &c__1, &h__[ifrstm + ( + ilast - 1) * h_dim1], &c__1, &c__, &s); + i__2 = ilast - ifrstm; + zrot_(&i__2, &t[ifrstm + ilast * t_dim1], &c__1, &t[ifrstm + (ilast - + 1) * t_dim1], &c__1, &c__, &s); + if (ilz) { + zrot_(n, &z__[ilast * z_dim1 + 1], &c__1, &z__[(ilast - 1) * + z_dim1 + 1], &c__1, &c__, &s); + } + +/* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHA and BETA */ + +L60: + absb = z_abs(&t[ilast + ilast * t_dim1]); + if (absb > safmin) { + i__2 = ilast + ilast * t_dim1; + z__2.r = t[i__2].r / absb, z__2.i = t[i__2].i / absb; + d_cnjg(&z__1, &z__2); + signbc.r = z__1.r, signbc.i = z__1.i; + i__2 = ilast + ilast * t_dim1; + t[i__2].r = absb, t[i__2].i = 0.; + if (ilschr) { + i__2 = ilast - ifrstm; + zscal_(&i__2, &signbc, &t[ifrstm + ilast * t_dim1], &c__1); + i__2 = ilast + 1 - ifrstm; + zscal_(&i__2, &signbc, &h__[ifrstm + ilast * h_dim1], &c__1); + } else { + zscal_(&c__1, &signbc, &h__[ilast + ilast * h_dim1], &c__1); + } + if (ilz) { + zscal_(n, &signbc, &z__[ilast * z_dim1 + 1], &c__1); + } + } else { + i__2 = ilast + ilast * t_dim1; + t[i__2].r = 0., t[i__2].i = 0.; + } + i__2 = ilast; + i__3 = ilast + ilast * h_dim1; + alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i; + i__2 = ilast; + i__3 = ilast + ilast * t_dim1; + beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i; + +/* Go to next block -- exit if finished. */ + + --ilast; + if (ilast < *ilo) { + goto L190; + } + +/* Reset counters */ + + iiter = 0; + eshift.r = 0., eshift.i = 0.; + if (! ilschr) { + ilastm = ilast; + if (ifrstm > ilast) { + ifrstm = *ilo; + } + } + goto L160; + +/* QZ step */ + +/* This iteration only involves rows/columns IFIRST:ILAST. We */ +/* assume IFIRST < ILAST, and that the diagonal of B is non-zero. */ + +L70: + ++iiter; + if (! ilschr) { + ifrstm = ifirst; + } + +/* Compute the Shift. */ + +/* At this point, IFIRST < ILAST, and the diagonal elements of */ +/* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in */ +/* magnitude) */ + + if (iiter / 10 * 10 != iiter) { + +/* The Wilkinson shift (AEP p.512), i.e., the eigenvalue of */ +/* the bottom-right 2x2 block of A inv(B) which is nearest to */ +/* the bottom-right element. */ + +/* We factor B as U*D, where U has unit diagonals, and */ +/* compute (A*inv(D))*inv(U). */ + + i__2 = ilast - 1 + ilast * t_dim1; + z__2.r = bscale * t[i__2].r, z__2.i = bscale * t[i__2].i; + i__3 = ilast + ilast * t_dim1; + z__3.r = bscale * t[i__3].r, z__3.i = bscale * t[i__3].i; + z_div(&z__1, &z__2, &z__3); + u12.r = z__1.r, u12.i = z__1.i; + i__2 = ilast - 1 + (ilast - 1) * h_dim1; + z__2.r = ascale * h__[i__2].r, z__2.i = ascale * h__[i__2].i; + i__3 = ilast - 1 + (ilast - 1) * t_dim1; + z__3.r = bscale * t[i__3].r, z__3.i = bscale * t[i__3].i; + z_div(&z__1, &z__2, &z__3); + ad11.r = z__1.r, ad11.i = z__1.i; + i__2 = ilast + (ilast - 1) * h_dim1; + z__2.r = ascale * h__[i__2].r, z__2.i = ascale * h__[i__2].i; + i__3 = ilast - 1 + (ilast - 1) * t_dim1; + z__3.r = bscale * t[i__3].r, z__3.i = bscale * t[i__3].i; + z_div(&z__1, &z__2, &z__3); + ad21.r = z__1.r, ad21.i = z__1.i; + i__2 = ilast - 1 + ilast * h_dim1; + z__2.r = ascale * h__[i__2].r, z__2.i = ascale * h__[i__2].i; + i__3 = ilast + ilast * t_dim1; + z__3.r = bscale * t[i__3].r, z__3.i = bscale * t[i__3].i; + z_div(&z__1, &z__2, &z__3); + ad12.r = z__1.r, ad12.i = z__1.i; + i__2 = ilast + ilast * h_dim1; + z__2.r = ascale * h__[i__2].r, z__2.i = ascale * h__[i__2].i; + i__3 = ilast + ilast * t_dim1; + z__3.r = bscale * t[i__3].r, z__3.i = bscale * t[i__3].i; + z_div(&z__1, &z__2, &z__3); + ad22.r = z__1.r, ad22.i = z__1.i; + z__2.r = u12.r * ad21.r - u12.i * ad21.i, z__2.i = u12.r * ad21.i + + u12.i * ad21.r; + z__1.r = ad22.r - z__2.r, z__1.i = ad22.i - z__2.i; + abi22.r = z__1.r, abi22.i = z__1.i; + z__2.r = u12.r * ad11.r - u12.i * ad11.i, z__2.i = u12.r * ad11.i + + u12.i * ad11.r; + z__1.r = ad12.r - z__2.r, z__1.i = ad12.i - z__2.i; + abi12.r = z__1.r, abi12.i = z__1.i; + + shift.r = abi22.r, shift.i = abi22.i; + z_sqrt(&z__2, &abi12); + z_sqrt(&z__3, &ad21); + z__1.r = z__2.r * z__3.r - z__2.i * z__3.i, z__1.i = z__2.r * + z__3.i + z__2.i * z__3.r; + ctemp.r = z__1.r, ctemp.i = z__1.i; + temp = (d__1 = ctemp.r, abs(d__1)) + (d__2 = d_imag(&ctemp), abs( + d__2)); + if (ctemp.r != 0. || ctemp.i != 0.) { + z__2.r = ad11.r - shift.r, z__2.i = ad11.i - shift.i; + z__1.r = z__2.r * .5, z__1.i = z__2.i * .5; + x.r = z__1.r, x.i = z__1.i; + temp2 = (d__1 = x.r, abs(d__1)) + (d__2 = d_imag(&x), abs( + d__2)); +/* Computing MAX */ + d__3 = temp, d__4 = (d__1 = x.r, abs(d__1)) + (d__2 = d_imag(& + x), abs(d__2)); + temp = f2cmax(d__3,d__4); + z__5.r = x.r / temp, z__5.i = x.i / temp; + pow_zi(&z__4, &z__5, &c__2); + z__7.r = ctemp.r / temp, z__7.i = ctemp.i / temp; + pow_zi(&z__6, &z__7, &c__2); + z__3.r = z__4.r + z__6.r, z__3.i = z__4.i + z__6.i; + z_sqrt(&z__2, &z__3); + z__1.r = temp * z__2.r, z__1.i = temp * z__2.i; + y.r = z__1.r, y.i = z__1.i; + if (temp2 > 0.) { + z__1.r = x.r / temp2, z__1.i = x.i / temp2; + z__2.r = x.r / temp2, z__2.i = x.i / temp2; + if (z__1.r * y.r + d_imag(&z__2) * d_imag(&y) < 0.) { + z__3.r = -y.r, z__3.i = -y.i; + y.r = z__3.r, y.i = z__3.i; + } + } + z__4.r = x.r + y.r, z__4.i = x.i + y.i; + zladiv_(&z__3, &ctemp, &z__4); + z__2.r = ctemp.r * z__3.r - ctemp.i * z__3.i, z__2.i = + ctemp.r * z__3.i + ctemp.i * z__3.r; + z__1.r = shift.r - z__2.r, z__1.i = shift.i - z__2.i; + shift.r = z__1.r, shift.i = z__1.i; + } + } else { + +/* Exceptional shift. Chosen for no particularly good reason. */ + + i__2 = ilast + ilast * t_dim1; + if (iiter / 20 * 20 == iiter && bscale * ((d__1 = t[i__2].r, abs( + d__1)) + (d__2 = d_imag(&t[ilast + ilast * t_dim1]), abs( + d__2))) > safmin) { + i__2 = ilast + ilast * h_dim1; + z__3.r = ascale * h__[i__2].r, z__3.i = ascale * h__[i__2].i; + i__3 = ilast + ilast * t_dim1; + z__4.r = bscale * t[i__3].r, z__4.i = bscale * t[i__3].i; + z_div(&z__2, &z__3, &z__4); + z__1.r = eshift.r + z__2.r, z__1.i = eshift.i + z__2.i; + eshift.r = z__1.r, eshift.i = z__1.i; + } else { + i__2 = ilast + (ilast - 1) * h_dim1; + z__3.r = ascale * h__[i__2].r, z__3.i = ascale * h__[i__2].i; + i__3 = ilast - 1 + (ilast - 1) * t_dim1; + z__4.r = bscale * t[i__3].r, z__4.i = bscale * t[i__3].i; + z_div(&z__2, &z__3, &z__4); + z__1.r = eshift.r + z__2.r, z__1.i = eshift.i + z__2.i; + eshift.r = z__1.r, eshift.i = z__1.i; + } + shift.r = eshift.r, shift.i = eshift.i; + } + +/* Now check for two consecutive small subdiagonals. */ + + i__2 = ifirst + 1; + for (j = ilast - 1; j >= i__2; --j) { + istart = j; + i__3 = j + j * h_dim1; + z__2.r = ascale * h__[i__3].r, z__2.i = ascale * h__[i__3].i; + i__4 = j + j * t_dim1; + z__4.r = bscale * t[i__4].r, z__4.i = bscale * t[i__4].i; + z__3.r = shift.r * z__4.r - shift.i * z__4.i, z__3.i = shift.r * + z__4.i + shift.i * z__4.r; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + ctemp.r = z__1.r, ctemp.i = z__1.i; + temp = (d__1 = ctemp.r, abs(d__1)) + (d__2 = d_imag(&ctemp), abs( + d__2)); + i__3 = j + 1 + j * h_dim1; + temp2 = ascale * ((d__1 = h__[i__3].r, abs(d__1)) + (d__2 = + d_imag(&h__[j + 1 + j * h_dim1]), abs(d__2))); + tempr = f2cmax(temp,temp2); + if (tempr < 1. && tempr != 0.) { + temp /= tempr; + temp2 /= tempr; + } + i__3 = j + (j - 1) * h_dim1; + if (((d__1 = h__[i__3].r, abs(d__1)) + (d__2 = d_imag(&h__[j + (j + - 1) * h_dim1]), abs(d__2))) * temp2 <= temp * atol) { + goto L90; + } +/* L80: */ + } + + istart = ifirst; + i__2 = ifirst + ifirst * h_dim1; + z__2.r = ascale * h__[i__2].r, z__2.i = ascale * h__[i__2].i; + i__3 = ifirst + ifirst * t_dim1; + z__4.r = bscale * t[i__3].r, z__4.i = bscale * t[i__3].i; + z__3.r = shift.r * z__4.r - shift.i * z__4.i, z__3.i = shift.r * + z__4.i + shift.i * z__4.r; + z__1.r = z__2.r - z__3.r, z__1.i = z__2.i - z__3.i; + ctemp.r = z__1.r, ctemp.i = z__1.i; +L90: + +/* Do an implicit-shift QZ sweep. */ + +/* Initial Q */ + + i__2 = istart + 1 + istart * h_dim1; + z__1.r = ascale * h__[i__2].r, z__1.i = ascale * h__[i__2].i; + ctemp2.r = z__1.r, ctemp2.i = z__1.i; + zlartg_(&ctemp, &ctemp2, &c__, &s, &ctemp3); + +/* Sweep */ + + i__2 = ilast - 1; + for (j = istart; j <= i__2; ++j) { + if (j > istart) { + i__3 = j + (j - 1) * h_dim1; + ctemp.r = h__[i__3].r, ctemp.i = h__[i__3].i; + zlartg_(&ctemp, &h__[j + 1 + (j - 1) * h_dim1], &c__, &s, & + h__[j + (j - 1) * h_dim1]); + i__3 = j + 1 + (j - 1) * h_dim1; + h__[i__3].r = 0., h__[i__3].i = 0.; + } + + i__3 = ilastm; + for (jc = j; jc <= i__3; ++jc) { + i__4 = j + jc * h_dim1; + z__2.r = c__ * h__[i__4].r, z__2.i = c__ * h__[i__4].i; + i__5 = j + 1 + jc * h_dim1; + z__3.r = s.r * h__[i__5].r - s.i * h__[i__5].i, z__3.i = s.r * + h__[i__5].i + s.i * h__[i__5].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__4 = j + 1 + jc * h_dim1; + d_cnjg(&z__4, &s); + z__3.r = -z__4.r, z__3.i = -z__4.i; + i__5 = j + jc * h_dim1; + z__2.r = z__3.r * h__[i__5].r - z__3.i * h__[i__5].i, z__2.i = + z__3.r * h__[i__5].i + z__3.i * h__[i__5].r; + i__6 = j + 1 + jc * h_dim1; + z__5.r = c__ * h__[i__6].r, z__5.i = c__ * h__[i__6].i; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; + h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; + i__4 = j + jc * h_dim1; + h__[i__4].r = ctemp.r, h__[i__4].i = ctemp.i; + i__4 = j + jc * t_dim1; + z__2.r = c__ * t[i__4].r, z__2.i = c__ * t[i__4].i; + i__5 = j + 1 + jc * t_dim1; + z__3.r = s.r * t[i__5].r - s.i * t[i__5].i, z__3.i = s.r * t[ + i__5].i + s.i * t[i__5].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + ctemp2.r = z__1.r, ctemp2.i = z__1.i; + i__4 = j + 1 + jc * t_dim1; + d_cnjg(&z__4, &s); + z__3.r = -z__4.r, z__3.i = -z__4.i; + i__5 = j + jc * t_dim1; + z__2.r = z__3.r * t[i__5].r - z__3.i * t[i__5].i, z__2.i = + z__3.r * t[i__5].i + z__3.i * t[i__5].r; + i__6 = j + 1 + jc * t_dim1; + z__5.r = c__ * t[i__6].r, z__5.i = c__ * t[i__6].i; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; + t[i__4].r = z__1.r, t[i__4].i = z__1.i; + i__4 = j + jc * t_dim1; + t[i__4].r = ctemp2.r, t[i__4].i = ctemp2.i; +/* L100: */ + } + if (ilq) { + i__3 = *n; + for (jr = 1; jr <= i__3; ++jr) { + i__4 = jr + j * q_dim1; + z__2.r = c__ * q[i__4].r, z__2.i = c__ * q[i__4].i; + d_cnjg(&z__4, &s); + i__5 = jr + (j + 1) * q_dim1; + z__3.r = z__4.r * q[i__5].r - z__4.i * q[i__5].i, z__3.i = + z__4.r * q[i__5].i + z__4.i * q[i__5].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__4 = jr + (j + 1) * q_dim1; + z__3.r = -s.r, z__3.i = -s.i; + i__5 = jr + j * q_dim1; + z__2.r = z__3.r * q[i__5].r - z__3.i * q[i__5].i, z__2.i = + z__3.r * q[i__5].i + z__3.i * q[i__5].r; + i__6 = jr + (j + 1) * q_dim1; + z__4.r = c__ * q[i__6].r, z__4.i = c__ * q[i__6].i; + z__1.r = z__2.r + z__4.r, z__1.i = z__2.i + z__4.i; + q[i__4].r = z__1.r, q[i__4].i = z__1.i; + i__4 = jr + j * q_dim1; + q[i__4].r = ctemp.r, q[i__4].i = ctemp.i; +/* L110: */ + } + } + + i__3 = j + 1 + (j + 1) * t_dim1; + ctemp.r = t[i__3].r, ctemp.i = t[i__3].i; + zlartg_(&ctemp, &t[j + 1 + j * t_dim1], &c__, &s, &t[j + 1 + (j + + 1) * t_dim1]); + i__3 = j + 1 + j * t_dim1; + t[i__3].r = 0., t[i__3].i = 0.; + +/* Computing MIN */ + i__4 = j + 2; + i__3 = f2cmin(i__4,ilast); + for (jr = ifrstm; jr <= i__3; ++jr) { + i__4 = jr + (j + 1) * h_dim1; + z__2.r = c__ * h__[i__4].r, z__2.i = c__ * h__[i__4].i; + i__5 = jr + j * h_dim1; + z__3.r = s.r * h__[i__5].r - s.i * h__[i__5].i, z__3.i = s.r * + h__[i__5].i + s.i * h__[i__5].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__4 = jr + j * h_dim1; + d_cnjg(&z__4, &s); + z__3.r = -z__4.r, z__3.i = -z__4.i; + i__5 = jr + (j + 1) * h_dim1; + z__2.r = z__3.r * h__[i__5].r - z__3.i * h__[i__5].i, z__2.i = + z__3.r * h__[i__5].i + z__3.i * h__[i__5].r; + i__6 = jr + j * h_dim1; + z__5.r = c__ * h__[i__6].r, z__5.i = c__ * h__[i__6].i; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; + h__[i__4].r = z__1.r, h__[i__4].i = z__1.i; + i__4 = jr + (j + 1) * h_dim1; + h__[i__4].r = ctemp.r, h__[i__4].i = ctemp.i; +/* L120: */ + } + i__3 = j; + for (jr = ifrstm; jr <= i__3; ++jr) { + i__4 = jr + (j + 1) * t_dim1; + z__2.r = c__ * t[i__4].r, z__2.i = c__ * t[i__4].i; + i__5 = jr + j * t_dim1; + z__3.r = s.r * t[i__5].r - s.i * t[i__5].i, z__3.i = s.r * t[ + i__5].i + s.i * t[i__5].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__4 = jr + j * t_dim1; + d_cnjg(&z__4, &s); + z__3.r = -z__4.r, z__3.i = -z__4.i; + i__5 = jr + (j + 1) * t_dim1; + z__2.r = z__3.r * t[i__5].r - z__3.i * t[i__5].i, z__2.i = + z__3.r * t[i__5].i + z__3.i * t[i__5].r; + i__6 = jr + j * t_dim1; + z__5.r = c__ * t[i__6].r, z__5.i = c__ * t[i__6].i; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; + t[i__4].r = z__1.r, t[i__4].i = z__1.i; + i__4 = jr + (j + 1) * t_dim1; + t[i__4].r = ctemp.r, t[i__4].i = ctemp.i; +/* L130: */ + } + if (ilz) { + i__3 = *n; + for (jr = 1; jr <= i__3; ++jr) { + i__4 = jr + (j + 1) * z_dim1; + z__2.r = c__ * z__[i__4].r, z__2.i = c__ * z__[i__4].i; + i__5 = jr + j * z_dim1; + z__3.r = s.r * z__[i__5].r - s.i * z__[i__5].i, z__3.i = + s.r * z__[i__5].i + s.i * z__[i__5].r; + z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; + ctemp.r = z__1.r, ctemp.i = z__1.i; + i__4 = jr + j * z_dim1; + d_cnjg(&z__4, &s); + z__3.r = -z__4.r, z__3.i = -z__4.i; + i__5 = jr + (j + 1) * z_dim1; + z__2.r = z__3.r * z__[i__5].r - z__3.i * z__[i__5].i, + z__2.i = z__3.r * z__[i__5].i + z__3.i * z__[i__5] + .r; + i__6 = jr + j * z_dim1; + z__5.r = c__ * z__[i__6].r, z__5.i = c__ * z__[i__6].i; + z__1.r = z__2.r + z__5.r, z__1.i = z__2.i + z__5.i; + z__[i__4].r = z__1.r, z__[i__4].i = z__1.i; + i__4 = jr + (j + 1) * z_dim1; + z__[i__4].r = ctemp.r, z__[i__4].i = ctemp.i; +/* L140: */ + } + } +/* L150: */ + } + +L160: + +/* L170: */ + ; + } + +/* Drop-through = non-convergence */ + +L180: + *info = ilast; + goto L210; + +/* Successful completion of all QZ steps */ + +L190: + +/* Set Eigenvalues 1:ILO-1 */ + + i__1 = *ilo - 1; + for (j = 1; j <= i__1; ++j) { + absb = z_abs(&t[j + j * t_dim1]); + if (absb > safmin) { + i__2 = j + j * t_dim1; + z__2.r = t[i__2].r / absb, z__2.i = t[i__2].i / absb; + d_cnjg(&z__1, &z__2); + signbc.r = z__1.r, signbc.i = z__1.i; + i__2 = j + j * t_dim1; + t[i__2].r = absb, t[i__2].i = 0.; + if (ilschr) { + i__2 = j - 1; + zscal_(&i__2, &signbc, &t[j * t_dim1 + 1], &c__1); + zscal_(&j, &signbc, &h__[j * h_dim1 + 1], &c__1); + } else { + zscal_(&c__1, &signbc, &h__[j + j * h_dim1], &c__1); + } + if (ilz) { + zscal_(n, &signbc, &z__[j * z_dim1 + 1], &c__1); + } + } else { + i__2 = j + j * t_dim1; + t[i__2].r = 0., t[i__2].i = 0.; + } + i__2 = j; + i__3 = j + j * h_dim1; + alpha[i__2].r = h__[i__3].r, alpha[i__2].i = h__[i__3].i; + i__2 = j; + i__3 = j + j * t_dim1; + beta[i__2].r = t[i__3].r, beta[i__2].i = t[i__3].i; +/* L200: */ + } + +/* Normal Termination */ + + *info = 0; + +/* Exit (other than argument error) -- return optimal workspace size */ + +L210: + z__1.r = (doublereal) (*n), z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + return 0; + +/* End of ZHGEQZ */ + +} /* zhgeqz_ */ + diff --git a/lapack-netlib/SRC/zhpcon.c b/lapack-netlib/SRC/zhpcon.c new file mode 100644 index 000000000..99ac729b1 --- /dev/null +++ b/lapack-netlib/SRC/zhpcon.c @@ -0,0 +1,628 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHPCON */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHPCON + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N */ +/* DOUBLE PRECISION ANORM, RCOND */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 AP( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHPCON estimates the reciprocal of the condition number of a complex */ +/* > Hermitian packed matrix A using the factorization A = U*D*U**H or */ +/* > A = L*D*L**H computed by ZHPTRF. */ +/* > */ +/* > An estimate is obtained for norm(inv(A)), and the reciprocal of the */ +/* > condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))). */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > Specifies whether the details of the factorization are stored */ +/* > as an upper or lower triangular matrix. */ +/* > = 'U': Upper triangular, form is A = U*D*U**H; */ +/* > = 'L': Lower triangular, form is A = L*D*L**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by ZHPTRF, stored as a */ +/* > packed triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by ZHPTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ANORM */ +/* > \verbatim */ +/* > ANORM is DOUBLE PRECISION */ +/* > The 1-norm of the original matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > The reciprocal of the condition number of the matrix A, */ +/* > computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an */ +/* > estimate of the 1-norm of inv(A) computed in this routine. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zhpcon_(char *uplo, integer *n, doublecomplex *ap, + integer *ipiv, doublereal *anorm, doublereal *rcond, doublecomplex * + work, integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + + /* Local variables */ + integer kase, i__; + extern logical lsame_(char *, char *); + integer isave[3]; + logical upper; + extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *, + doublecomplex *, doublereal *, integer *, integer *); + integer ip; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal ainvnm; + extern /* Subroutine */ int zhptrs_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *); + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --work; + --ipiv; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*anorm < 0.) { + *info = -5; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHPCON", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + *rcond = 0.; + if (*n == 0) { + *rcond = 1.; + return 0; + } else if (*anorm <= 0.) { + return 0; + } + +/* Check that the diagonal matrix D is nonsingular. */ + + if (upper) { + +/* Upper triangular storage: examine D from bottom to top */ + + ip = *n * (*n + 1) / 2; + for (i__ = *n; i__ >= 1; --i__) { + i__1 = ip; + if (ipiv[i__] > 0 && (ap[i__1].r == 0. && ap[i__1].i == 0.)) { + return 0; + } + ip -= i__; +/* L10: */ + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + ip = 1; + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ip; + if (ipiv[i__] > 0 && (ap[i__2].r == 0. && ap[i__2].i == 0.)) { + return 0; + } + ip = ip + *n - i__ + 1; +/* L20: */ + } + } + +/* Estimate the 1-norm of the inverse. */ + + kase = 0; +L30: + zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + +/* Multiply by inv(L*D*L**H) or inv(U*D*U**H). */ + + zhptrs_(uplo, n, &c__1, &ap[1], &ipiv[1], &work[1], n, info); + goto L30; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + *rcond = 1. / ainvnm / *anorm; + } + + return 0; + +/* End of ZHPCON */ + +} /* zhpcon_ */ + diff --git a/lapack-netlib/SRC/zhpev.c b/lapack-netlib/SRC/zhpev.c new file mode 100644 index 000000000..48a6858ce --- /dev/null +++ b/lapack-netlib/SRC/zhpev.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 ZHPEV computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER m +atrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHPEV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, RWORK, */ +/* INFO ) */ + +/* CHARACTER JOBZ, UPLO */ +/* INTEGER INFO, LDZ, N */ +/* DOUBLE PRECISION RWORK( * ), W( * ) */ +/* COMPLEX*16 AP( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHPEV computes all the eigenvalues and, optionally, eigenvectors of a */ +/* > complex Hermitian matrix in packed storage. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBZ */ +/* > \verbatim */ +/* > JOBZ is CHARACTER*1 */ +/* > = 'N': Compute eigenvalues only; */ +/* > = 'V': Compute eigenvalues and eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the Hermitian matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* > */ +/* > On exit, AP is overwritten by values generated during the */ +/* > reduction to tridiagonal form. If UPLO = 'U', the diagonal */ +/* > and first superdiagonal of the tridiagonal matrix T overwrite */ +/* > the corresponding elements of A, and if UPLO = 'L', the */ +/* > diagonal and first subdiagonal of T overwrite the */ +/* > corresponding elements of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is DOUBLE PRECISION array, dimension (N) */ +/* > If INFO = 0, the eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX*16 array, dimension (LDZ, N) */ +/* > If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */ +/* > eigenvectors of the matrix A, with the i-th column of Z */ +/* > holding the eigenvector associated with W(i). */ +/* > If JOBZ = 'N', then Z is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1, and if */ +/* > JOBZ = 'V', LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (f2cmax(1, 2*N-1)) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (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. */ +/* > > 0: if INFO = i, the algorithm failed to converge; i */ +/* > off-diagonal elements of an intermediate tridiagonal */ +/* > form did not converge to zero. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHEReigen */ + +/* ===================================================================== */ +/* Subroutine */ int zhpev_(char *jobz, char *uplo, integer *n, doublecomplex + *ap, doublereal *w, doublecomplex *z__, integer *ldz, doublecomplex * + work, doublereal *rwork, integer *info) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1; + doublereal d__1; + + /* Local variables */ + integer inde; + doublereal anrm; + integer imax; + doublereal rmin, rmax; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + doublereal sigma; + extern logical lsame_(char *, char *); + integer iinfo; + logical wantz; + extern doublereal dlamch_(char *); + integer iscale; + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zdscal_( + integer *, doublereal *, doublecomplex *, integer *); + doublereal bignum; + integer indtau; + extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *, + integer *); + extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *, + doublereal *); + integer indrwk, indwrk; + doublereal smlnum; + extern /* Subroutine */ int zhptrd_(char *, integer *, doublecomplex *, + doublereal *, doublereal *, doublecomplex *, integer *), + zsteqr_(char *, integer *, doublereal *, doublereal *, + doublecomplex *, integer *, doublereal *, integer *), + zupgtr_(char *, integer *, doublecomplex *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *); + doublereal eps; + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --rwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (lsame_(uplo, "L") || lsame_(uplo, + "U"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -7; + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHPEV ", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + w[1] = ap[1].r; + rwork[1] = 1.; + if (wantz) { + i__1 = z_dim1 + 1; + z__[i__1].r = 1., z__[i__1].i = 0.; + } + return 0; + } + +/* Get machine constants. */ + + safmin = dlamch_("Safe minimum"); + eps = dlamch_("Precision"); + smlnum = safmin / eps; + bignum = 1. / smlnum; + rmin = sqrt(smlnum); + rmax = sqrt(bignum); + +/* Scale matrix to allowable range, if necessary. */ + + anrm = zlanhp_("M", uplo, n, &ap[1], &rwork[1]); + iscale = 0; + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + i__1 = *n * (*n + 1) / 2; + zdscal_(&i__1, &sigma, &ap[1], &c__1); + } + +/* Call ZHPTRD to reduce Hermitian packed matrix to tridiagonal form. */ + + inde = 1; + indtau = 1; + zhptrd_(uplo, n, &ap[1], &w[1], &rwork[inde], &work[indtau], &iinfo); + +/* For eigenvalues only, call DSTERF. For eigenvectors, first call */ +/* ZUPGTR to generate the orthogonal matrix, then call ZSTEQR. */ + + if (! wantz) { + dsterf_(n, &w[1], &rwork[inde], info); + } else { + indwrk = indtau + *n; + zupgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &work[ + indwrk], &iinfo); + indrwk = inde + *n; + zsteqr_(jobz, n, &w[1], &rwork[inde], &z__[z_offset], ldz, &rwork[ + indrwk], info); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + + if (iscale == 1) { + if (*info == 0) { + imax = *n; + } else { + imax = *info - 1; + } + d__1 = 1. / sigma; + dscal_(&imax, &d__1, &w[1], &c__1); + } + + return 0; + +/* End of ZHPEV */ + +} /* zhpev_ */ + diff --git a/lapack-netlib/SRC/zhpevd.c b/lapack-netlib/SRC/zhpevd.c new file mode 100644 index 000000000..01a77d887 --- /dev/null +++ b/lapack-netlib/SRC/zhpevd.c @@ -0,0 +1,797 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief ZHPEVD computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER +matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHPEVD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, */ +/* RWORK, LRWORK, IWORK, LIWORK, INFO ) */ + +/* CHARACTER JOBZ, UPLO */ +/* INTEGER INFO, LDZ, LIWORK, LRWORK, LWORK, N */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION RWORK( * ), W( * ) */ +/* COMPLEX*16 AP( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHPEVD computes all the eigenvalues and, optionally, eigenvectors of */ +/* > a complex Hermitian matrix A in packed storage. If eigenvectors are */ +/* > desired, it uses a divide and conquer algorithm. */ +/* > */ +/* > The divide and conquer algorithm makes very mild assumptions about */ +/* > floating point arithmetic. It will work on machines with a guard */ +/* > digit in add/subtract, or on those binary machines without guard */ +/* > digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ +/* > Cray-2. It could conceivably fail on hexadecimal or decimal machines */ +/* > without guard digits, but we know of none. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBZ */ +/* > \verbatim */ +/* > JOBZ is CHARACTER*1 */ +/* > = 'N': Compute eigenvalues only; */ +/* > = 'V': Compute eigenvalues and eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the Hermitian matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* > */ +/* > On exit, AP is overwritten by values generated during the */ +/* > reduction to tridiagonal form. If UPLO = 'U', the diagonal */ +/* > and first superdiagonal of the tridiagonal matrix T overwrite */ +/* > the corresponding elements of A, and if UPLO = 'L', the */ +/* > diagonal and first subdiagonal of T overwrite the */ +/* > corresponding elements of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is DOUBLE PRECISION array, dimension (N) */ +/* > If INFO = 0, the eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX*16 array, dimension (LDZ, N) */ +/* > If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */ +/* > eigenvectors of the matrix A, with the i-th column of Z */ +/* > holding the eigenvector associated with W(i). */ +/* > If JOBZ = 'N', then Z is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1, and if */ +/* > JOBZ = 'V', LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the required LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of array WORK. */ +/* > If N <= 1, LWORK must be at least 1. */ +/* > If JOBZ = 'N' and N > 1, LWORK must be at least N. */ +/* > If JOBZ = 'V' and N > 1, LWORK must be at least 2*N. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the required sizes of the WORK, RWORK and */ +/* > IWORK arrays, returns these values as the first entries of */ +/* > the WORK, RWORK and IWORK arrays, and no error message */ +/* > related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK)) */ +/* > On exit, if INFO = 0, RWORK(1) returns the required LRWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LRWORK */ +/* > \verbatim */ +/* > LRWORK is INTEGER */ +/* > The dimension of array RWORK. */ +/* > If N <= 1, LRWORK must be at least 1. */ +/* > If JOBZ = 'N' and N > 1, LRWORK must be at least N. */ +/* > If JOBZ = 'V' and N > 1, LRWORK must be at least */ +/* > 1 + 5*N + 2*N**2. */ +/* > */ +/* > If LRWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the required sizes of the WORK, RWORK */ +/* > and IWORK arrays, returns these values as the first entries */ +/* > of the WORK, RWORK and IWORK arrays, and no error message */ +/* > related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */ +/* > On exit, if INFO = 0, IWORK(1) returns the required LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of array IWORK. */ +/* > If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. */ +/* > If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. */ +/* > */ +/* > If LIWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the required sizes of the WORK, RWORK */ +/* > and IWORK arrays, returns these values as the first entries */ +/* > of the WORK, RWORK and IWORK arrays, and no error message */ +/* > related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: if INFO = i, the algorithm failed to converge; i */ +/* > off-diagonal elements of an intermediate tridiagonal */ +/* > form did not converge to zero. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup complex16OTHEReigen */ + +/* ===================================================================== */ +/* Subroutine */ int zhpevd_(char *jobz, char *uplo, integer *n, + doublecomplex *ap, doublereal *w, doublecomplex *z__, integer *ldz, + doublecomplex *work, integer *lwork, doublereal *rwork, integer * + lrwork, integer *iwork, integer *liwork, integer *info) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1; + doublereal d__1; + + /* Local variables */ + integer inde; + doublereal anrm; + integer imax; + doublereal rmin, rmax; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + doublereal sigma; + extern logical lsame_(char *, char *); + integer iinfo, lwmin, llrwk, llwrk; + logical wantz; + extern doublereal dlamch_(char *); + integer iscale; + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zdscal_( + integer *, doublereal *, doublecomplex *, integer *); + doublereal bignum; + integer indtau; + extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *, + integer *); + extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *, + doublereal *); + extern /* Subroutine */ int zstedc_(char *, integer *, doublereal *, + doublereal *, doublecomplex *, integer *, doublecomplex *, + integer *, doublereal *, integer *, integer *, integer *, integer + *); + integer indrwk, indwrk, liwmin, lrwmin; + doublereal smlnum; + extern /* Subroutine */ int zhptrd_(char *, integer *, doublecomplex *, + doublereal *, doublereal *, doublecomplex *, integer *); + logical lquery; + extern /* Subroutine */ int zupmtr_(char *, char *, char *, integer *, + integer *, doublecomplex *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, integer *); + doublereal eps; + + +/* -- LAPACK driver routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --rwork; + --iwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1; + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (lsame_(uplo, "L") || lsame_(uplo, + "U"))) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -7; + } + + if (*info == 0) { + if (*n <= 1) { + lwmin = 1; + liwmin = 1; + lrwmin = 1; + } else { + if (wantz) { + lwmin = *n << 1; +/* Computing 2nd power */ + i__1 = *n; + lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1); + liwmin = *n * 5 + 3; + } else { + lwmin = *n; + lrwmin = *n; + liwmin = 1; + } + } + work[1].r = (doublereal) lwmin, work[1].i = 0.; + rwork[1] = (doublereal) lrwmin; + iwork[1] = liwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -9; + } else if (*lrwork < lrwmin && ! lquery) { + *info = -11; + } else if (*liwork < liwmin && ! lquery) { + *info = -13; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHPEVD", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + + if (*n == 1) { + w[1] = ap[1].r; + if (wantz) { + i__1 = z_dim1 + 1; + z__[i__1].r = 1., z__[i__1].i = 0.; + } + return 0; + } + +/* Get machine constants. */ + + safmin = dlamch_("Safe minimum"); + eps = dlamch_("Precision"); + smlnum = safmin / eps; + bignum = 1. / smlnum; + rmin = sqrt(smlnum); + rmax = sqrt(bignum); + +/* Scale matrix to allowable range, if necessary. */ + + anrm = zlanhp_("M", uplo, n, &ap[1], &rwork[1]); + iscale = 0; + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + i__1 = *n * (*n + 1) / 2; + zdscal_(&i__1, &sigma, &ap[1], &c__1); + } + +/* Call ZHPTRD to reduce Hermitian packed matrix to tridiagonal form. */ + + inde = 1; + indtau = 1; + indrwk = inde + *n; + indwrk = indtau + *n; + llwrk = *lwork - indwrk + 1; + llrwk = *lrwork - indrwk + 1; + zhptrd_(uplo, n, &ap[1], &w[1], &rwork[inde], &work[indtau], &iinfo); + +/* For eigenvalues only, call DSTERF. For eigenvectors, first call */ +/* ZUPGTR to generate the orthogonal matrix, then call ZSTEDC. */ + + if (! wantz) { + dsterf_(n, &w[1], &rwork[inde], info); + } else { + zstedc_("I", n, &w[1], &rwork[inde], &z__[z_offset], ldz, &work[ + indwrk], &llwrk, &rwork[indrwk], &llrwk, &iwork[1], liwork, + info); + zupmtr_("L", uplo, "N", n, n, &ap[1], &work[indtau], &z__[z_offset], + ldz, &work[indwrk], &iinfo); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + + if (iscale == 1) { + if (*info == 0) { + imax = *n; + } else { + imax = *info - 1; + } + d__1 = 1. / sigma; + dscal_(&imax, &d__1, &w[1], &c__1); + } + + work[1].r = (doublereal) lwmin, work[1].i = 0.; + rwork[1] = (doublereal) lrwmin; + iwork[1] = liwmin; + return 0; + +/* End of ZHPEVD */ + +} /* zhpevd_ */ + diff --git a/lapack-netlib/SRC/zhpevx.c b/lapack-netlib/SRC/zhpevx.c new file mode 100644 index 000000000..e26af0473 --- /dev/null +++ b/lapack-netlib/SRC/zhpevx.c @@ -0,0 +1,950 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief ZHPEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for OTHER +matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHPEVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, */ +/* ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, */ +/* IFAIL, INFO ) */ + +/* CHARACTER JOBZ, RANGE, UPLO */ +/* INTEGER IL, INFO, IU, LDZ, M, N */ +/* DOUBLE PRECISION ABSTOL, VL, VU */ +/* INTEGER IFAIL( * ), IWORK( * ) */ +/* DOUBLE PRECISION RWORK( * ), W( * ) */ +/* COMPLEX*16 AP( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHPEVX computes selected eigenvalues and, optionally, eigenvectors */ +/* > of a complex Hermitian matrix A in packed storage. */ +/* > Eigenvalues/vectors can be selected by specifying either a range of */ +/* > values or a range of indices for the desired eigenvalues. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOBZ */ +/* > \verbatim */ +/* > JOBZ is CHARACTER*1 */ +/* > = 'N': Compute eigenvalues only; */ +/* > = 'V': Compute eigenvalues and eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RANGE */ +/* > \verbatim */ +/* > RANGE is CHARACTER*1 */ +/* > = 'A': all eigenvalues will be found; */ +/* > = 'V': all eigenvalues in the half-open interval (VL,VU] */ +/* > will be found; */ +/* > = 'I': the IL-th through IU-th eigenvalues will be found. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the Hermitian matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* > */ +/* > On exit, AP is overwritten by values generated during the */ +/* > reduction to tridiagonal form. If UPLO = 'U', the diagonal */ +/* > and first superdiagonal of the tridiagonal matrix T overwrite */ +/* > the corresponding elements of A, and if UPLO = 'L', the */ +/* > diagonal and first subdiagonal of T overwrite the */ +/* > corresponding elements of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VL */ +/* > \verbatim */ +/* > VL is DOUBLE PRECISION */ +/* > If RANGE='V', the lower bound of the interval to */ +/* > be searched for eigenvalues. VL < VU. */ +/* > Not referenced if RANGE = 'A' or 'I'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VU */ +/* > \verbatim */ +/* > VU is DOUBLE PRECISION */ +/* > If RANGE='V', the upper bound of the interval to */ +/* > be searched for eigenvalues. VL < VU. */ +/* > Not referenced if RANGE = 'A' or 'I'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IL */ +/* > \verbatim */ +/* > IL is INTEGER */ +/* > If RANGE='I', the index of the */ +/* > smallest eigenvalue to be returned. */ +/* > 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ +/* > Not referenced if RANGE = 'A' or 'V'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IU */ +/* > \verbatim */ +/* > IU is INTEGER */ +/* > If RANGE='I', the index of the */ +/* > largest eigenvalue to be returned. */ +/* > 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ +/* > Not referenced if RANGE = 'A' or 'V'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ABSTOL */ +/* > \verbatim */ +/* > ABSTOL is DOUBLE PRECISION */ +/* > The absolute error tolerance for the eigenvalues. */ +/* > An approximate eigenvalue is accepted as converged */ +/* > when it is determined to lie in an interval [a,b] */ +/* > of width less than or equal to */ +/* > */ +/* > ABSTOL + EPS * f2cmax( |a|,|b| ) , */ +/* > */ +/* > where EPS is the machine precision. If ABSTOL is less than */ +/* > or equal to zero, then EPS*|T| will be used in its place, */ +/* > where |T| is the 1-norm of the tridiagonal matrix obtained */ +/* > by reducing AP to tridiagonal form. */ +/* > */ +/* > Eigenvalues will be computed most accurately when ABSTOL is */ +/* > set to twice the underflow threshold 2*DLAMCH('S'), not zero. */ +/* > If this routine returns with INFO>0, indicating that some */ +/* > eigenvectors did not converge, try setting ABSTOL to */ +/* > 2*DLAMCH('S'). */ +/* > */ +/* > See "Computing Small Singular Values of Bidiagonal Matrices */ +/* > with Guaranteed High Relative Accuracy," by Demmel and */ +/* > Kahan, LAPACK Working Note #3. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The total number of eigenvalues found. 0 <= M <= N. */ +/* > If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is DOUBLE PRECISION array, dimension (N) */ +/* > If INFO = 0, the selected eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX*16 array, dimension (LDZ, f2cmax(1,M)) */ +/* > If JOBZ = 'V', then if INFO = 0, the first M columns of Z */ +/* > contain the orthonormal eigenvectors of the matrix A */ +/* > corresponding to the selected eigenvalues, with the i-th */ +/* > column of Z holding the eigenvector associated with W(i). */ +/* > If an eigenvector fails to converge, then that column of Z */ +/* > contains the latest approximation to the eigenvector, and */ +/* > the index of the eigenvector is returned in IFAIL. */ +/* > If JOBZ = 'N', then Z is not referenced. */ +/* > Note: the user must ensure that at least f2cmax(1,M) columns are */ +/* > supplied in the array Z; if RANGE = 'V', the exact value of M */ +/* > is not known in advance and an upper bound must be used. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1, and if */ +/* > JOBZ = 'V', LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (7*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (5*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IFAIL */ +/* > \verbatim */ +/* > IFAIL is INTEGER array, dimension (N) */ +/* > If JOBZ = 'V', then if INFO = 0, the first M elements of */ +/* > IFAIL are zero. If INFO > 0, then IFAIL contains the */ +/* > indices of the eigenvectors that failed to converge. */ +/* > If JOBZ = 'N', then IFAIL is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ +/* > Their indices are stored in array IFAIL. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16OTHEReigen */ + +/* ===================================================================== */ +/* Subroutine */ int zhpevx_(char *jobz, char *range, char *uplo, integer *n, + doublecomplex *ap, doublereal *vl, doublereal *vu, integer *il, + integer *iu, doublereal *abstol, integer *m, doublereal *w, + doublecomplex *z__, integer *ldz, doublecomplex *work, doublereal * + rwork, integer *iwork, integer *ifail, integer *info) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1, i__2; + doublereal d__1, d__2; + + /* Local variables */ + integer indd, inde; + doublereal anrm; + integer imax; + doublereal rmin, rmax; + logical test; + integer itmp1, i__, j, indee; + extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, + integer *); + doublereal sigma; + extern logical lsame_(char *, char *); + integer iinfo; + char order[1]; + extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + logical wantz; + extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + integer jj; + extern doublereal dlamch_(char *); + logical alleig, indeig; + integer iscale, indibl; + logical valeig; + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zdscal_( + integer *, doublereal *, doublecomplex *, integer *); + doublereal abstll, bignum; + integer indiwk, indisp, indtau; + extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *, + integer *), dstebz_(char *, char *, integer *, doublereal *, + doublereal *, integer *, integer *, doublereal *, doublereal *, + doublereal *, integer *, integer *, doublereal *, integer *, + integer *, doublereal *, integer *, integer *); + extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *, + doublereal *); + integer indrwk, indwrk, nsplit; + doublereal smlnum; + extern /* Subroutine */ int zhptrd_(char *, integer *, doublecomplex *, + doublereal *, doublereal *, doublecomplex *, integer *), + zstein_(integer *, doublereal *, doublereal *, integer *, + doublereal *, integer *, integer *, doublecomplex *, integer *, + doublereal *, integer *, integer *, integer *), zsteqr_(char *, + integer *, doublereal *, doublereal *, doublecomplex *, integer *, + doublereal *, integer *), zupgtr_(char *, integer *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *), zupmtr_(char *, char *, char + *, integer *, integer *, doublecomplex *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *); + doublereal eps, vll, vuu, tmp1; + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --rwork; + --iwork; + --ifail; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + alleig = lsame_(range, "A"); + valeig = lsame_(range, "V"); + indeig = lsame_(range, "I"); + + *info = 0; + if (! (wantz || lsame_(jobz, "N"))) { + *info = -1; + } else if (! (alleig || valeig || indeig)) { + *info = -2; + } else if (! (lsame_(uplo, "L") || lsame_(uplo, + "U"))) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else { + if (valeig) { + if (*n > 0 && *vu <= *vl) { + *info = -7; + } + } else if (indeig) { + if (*il < 1 || *il > f2cmax(1,*n)) { + *info = -8; + } else if (*iu < f2cmin(*n,*il) || *iu > *n) { + *info = -9; + } + } + } + if (*info == 0) { + if (*ldz < 1 || wantz && *ldz < *n) { + *info = -14; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHPEVX", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + *m = 0; + if (*n == 0) { + return 0; + } + + if (*n == 1) { + if (alleig || indeig) { + *m = 1; + w[1] = ap[1].r; + } else { + if (*vl < ap[1].r && *vu >= ap[1].r) { + *m = 1; + w[1] = ap[1].r; + } + } + if (wantz) { + i__1 = z_dim1 + 1; + z__[i__1].r = 1., z__[i__1].i = 0.; + } + return 0; + } + +/* Get machine constants. */ + + safmin = dlamch_("Safe minimum"); + eps = dlamch_("Precision"); + smlnum = safmin / eps; + bignum = 1. / smlnum; + rmin = sqrt(smlnum); +/* Computing MIN */ + d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin)); + rmax = f2cmin(d__1,d__2); + +/* Scale matrix to allowable range, if necessary. */ + + iscale = 0; + abstll = *abstol; + if (valeig) { + vll = *vl; + vuu = *vu; + } else { + vll = 0.; + vuu = 0.; + } + anrm = zlanhp_("M", uplo, n, &ap[1], &rwork[1]); + if (anrm > 0. && anrm < rmin) { + iscale = 1; + sigma = rmin / anrm; + } else if (anrm > rmax) { + iscale = 1; + sigma = rmax / anrm; + } + if (iscale == 1) { + i__1 = *n * (*n + 1) / 2; + zdscal_(&i__1, &sigma, &ap[1], &c__1); + if (*abstol > 0.) { + abstll = *abstol * sigma; + } + if (valeig) { + vll = *vl * sigma; + vuu = *vu * sigma; + } + } + +/* Call ZHPTRD to reduce Hermitian packed matrix to tridiagonal form. */ + + indd = 1; + inde = indd + *n; + indrwk = inde + *n; + indtau = 1; + indwrk = indtau + *n; + zhptrd_(uplo, n, &ap[1], &rwork[indd], &rwork[inde], &work[indtau], & + iinfo); + +/* If all eigenvalues are desired and ABSTOL is less than or equal */ +/* to zero, then call DSTERF or ZUPGTR and ZSTEQR. If this fails */ +/* for some eigenvalue, then try DSTEBZ. */ + + test = FALSE_; + if (indeig) { + if (*il == 1 && *iu == *n) { + test = TRUE_; + } + } + if ((alleig || test) && *abstol <= 0.) { + dcopy_(n, &rwork[indd], &c__1, &w[1], &c__1); + indee = indrwk + (*n << 1); + if (! wantz) { + i__1 = *n - 1; + dcopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1); + dsterf_(n, &w[1], &rwork[indee], info); + } else { + zupgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, & + work[indwrk], &iinfo); + i__1 = *n - 1; + dcopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1); + zsteqr_(jobz, n, &w[1], &rwork[indee], &z__[z_offset], ldz, & + rwork[indrwk], info); + if (*info == 0) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + ifail[i__] = 0; +/* L10: */ + } + } + } + if (*info == 0) { + *m = *n; + goto L20; + } + *info = 0; + } + +/* Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN. */ + + if (wantz) { + *(unsigned char *)order = 'B'; + } else { + *(unsigned char *)order = 'E'; + } + indibl = 1; + indisp = indibl + *n; + indiwk = indisp + *n; + dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], & + rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], & + rwork[indrwk], &iwork[indiwk], info); + + if (wantz) { + zstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], & + iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[ + indiwk], &ifail[1], info); + +/* Apply unitary matrix used in reduction to tridiagonal */ +/* form to eigenvectors returned by ZSTEIN. */ + + indwrk = indtau + *n; + zupmtr_("L", uplo, "N", n, m, &ap[1], &work[indtau], &z__[z_offset], + ldz, &work[indwrk], &iinfo); + } + +/* If matrix was scaled, then rescale eigenvalues appropriately. */ + +L20: + if (iscale == 1) { + if (*info == 0) { + imax = *m; + } else { + imax = *info - 1; + } + d__1 = 1. / sigma; + dscal_(&imax, &d__1, &w[1], &c__1); + } + +/* If eigenvalues are not in order, then sort them, along with */ +/* eigenvectors. */ + + if (wantz) { + i__1 = *m - 1; + for (j = 1; j <= i__1; ++j) { + i__ = 0; + tmp1 = w[j]; + i__2 = *m; + for (jj = j + 1; jj <= i__2; ++jj) { + if (w[jj] < tmp1) { + i__ = jj; + tmp1 = w[jj]; + } +/* L30: */ + } + + if (i__ != 0) { + itmp1 = iwork[indibl + i__ - 1]; + w[i__] = w[j]; + iwork[indibl + i__ - 1] = iwork[indibl + j - 1]; + w[j] = tmp1; + iwork[indibl + j - 1] = itmp1; + zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], + &c__1); + if (*info != 0) { + itmp1 = ifail[i__]; + ifail[i__] = ifail[j]; + ifail[j] = itmp1; + } + } +/* L40: */ + } + } + + return 0; + +/* End of ZHPEVX */ + +} /* zhpevx_ */ + diff --git a/lapack-netlib/SRC/zhpgst.c b/lapack-netlib/SRC/zhpgst.c new file mode 100644 index 000000000..6898e4866 --- /dev/null +++ b/lapack-netlib/SRC/zhpgst.c @@ -0,0 +1,739 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHPGST */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHPGST + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHPGST( ITYPE, UPLO, N, AP, BP, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, ITYPE, N */ +/* COMPLEX*16 AP( * ), BP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHPGST reduces a complex Hermitian-definite generalized */ +/* > eigenproblem to standard form, using packed storage. */ +/* > */ +/* > If ITYPE = 1, the problem is A*x = lambda*B*x, */ +/* > and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H) */ +/* > */ +/* > If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */ +/* > B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L. */ +/* > */ +/* > B must have been previously factorized as U**H*U or L*L**H by ZPPTRF. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ITYPE */ +/* > \verbatim */ +/* > ITYPE is INTEGER */ +/* > = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H); */ +/* > = 2 or 3: compute U*A*U**H or L**H*A*L. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored and B is factored as */ +/* > U**H*U; */ +/* > = 'L': Lower triangle of A is stored and B is factored as */ +/* > L*L**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the Hermitian matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > */ +/* > On exit, if INFO = 0, the transformed matrix, stored in the */ +/* > same format as A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BP */ +/* > \verbatim */ +/* > BP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > The triangular factor from the Cholesky factorization of B, */ +/* > stored in the same format as A, as returned by ZPPTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zhpgst_(integer *itype, char *uplo, integer *n, + doublecomplex *ap, doublecomplex *bp, integer *info) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4; + doublereal d__1, d__2; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + extern /* Subroutine */ int zhpr2_(char *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *); + integer j, k; + extern logical lsame_(char *, char *); + extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + logical upper; + integer j1, k1; + extern /* Subroutine */ int zhpmv_(char *, integer *, doublecomplex *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *), zaxpy_(integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *), ztpmv_(char *, char *, char *, integer *, + doublecomplex *, doublecomplex *, integer *), ztpsv_(char *, char *, char *, integer *, doublecomplex * + , doublecomplex *, integer *); + integer jj, kk; + doublecomplex ct; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zdscal_( + integer *, doublereal *, doublecomplex *, integer *); + doublereal ajj; + integer j1j1; + doublereal akk; + integer k1k1; + doublereal bjj, bkk; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --bp; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (*itype < 1 || *itype > 3) { + *info = -1; + } else if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHPGST", &i__1, (ftnlen)6); + return 0; + } + + if (*itype == 1) { + if (upper) { + +/* Compute inv(U**H)*A*inv(U) */ + +/* J1 and JJ are the indices of A(1,j) and A(j,j) */ + + jj = 0; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + j1 = jj + 1; + jj += j; + +/* Compute the j-th column of the upper triangle of A */ + + i__2 = jj; + i__3 = jj; + d__1 = ap[i__3].r; + ap[i__2].r = d__1, ap[i__2].i = 0.; + i__2 = jj; + bjj = bp[i__2].r; + ztpsv_(uplo, "Conjugate transpose", "Non-unit", &j, &bp[1], & + ap[j1], &c__1); + i__2 = j - 1; + z__1.r = -1., z__1.i = 0.; + zhpmv_(uplo, &i__2, &z__1, &ap[1], &bp[j1], &c__1, &c_b1, &ap[ + j1], &c__1); + i__2 = j - 1; + d__1 = 1. / bjj; + zdscal_(&i__2, &d__1, &ap[j1], &c__1); + i__2 = jj; + i__3 = jj; + i__4 = j - 1; + zdotc_(&z__3, &i__4, &ap[j1], &c__1, &bp[j1], &c__1); + z__2.r = ap[i__3].r - z__3.r, z__2.i = ap[i__3].i - z__3.i; + z__1.r = z__2.r / bjj, z__1.i = z__2.i / bjj; + ap[i__2].r = z__1.r, ap[i__2].i = z__1.i; +/* L10: */ + } + } else { + +/* Compute inv(L)*A*inv(L**H) */ + +/* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1) */ + + kk = 1; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + k1k1 = kk + *n - k + 1; + +/* Update the lower triangle of A(k:n,k:n) */ + + i__2 = kk; + akk = ap[i__2].r; + i__2 = kk; + bkk = bp[i__2].r; +/* Computing 2nd power */ + d__1 = bkk; + akk /= d__1 * d__1; + i__2 = kk; + ap[i__2].r = akk, ap[i__2].i = 0.; + if (k < *n) { + i__2 = *n - k; + d__1 = 1. / bkk; + zdscal_(&i__2, &d__1, &ap[kk + 1], &c__1); + d__1 = akk * -.5; + ct.r = d__1, ct.i = 0.; + i__2 = *n - k; + zaxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) + ; + i__2 = *n - k; + z__1.r = -1., z__1.i = 0.; + zhpr2_(uplo, &i__2, &z__1, &ap[kk + 1], &c__1, &bp[kk + 1] + , &c__1, &ap[k1k1]); + i__2 = *n - k; + zaxpy_(&i__2, &ct, &bp[kk + 1], &c__1, &ap[kk + 1], &c__1) + ; + i__2 = *n - k; + ztpsv_(uplo, "No transpose", "Non-unit", &i__2, &bp[k1k1], + &ap[kk + 1], &c__1); + } + kk = k1k1; +/* L20: */ + } + } + } else { + if (upper) { + +/* Compute U*A*U**H */ + +/* K1 and KK are the indices of A(1,k) and A(k,k) */ + + kk = 0; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + k1 = kk + 1; + kk += k; + +/* Update the upper triangle of A(1:k,1:k) */ + + i__2 = kk; + akk = ap[i__2].r; + i__2 = kk; + bkk = bp[i__2].r; + i__2 = k - 1; + ztpmv_(uplo, "No transpose", "Non-unit", &i__2, &bp[1], &ap[ + k1], &c__1); + d__1 = akk * .5; + ct.r = d__1, ct.i = 0.; + i__2 = k - 1; + zaxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); + i__2 = k - 1; + zhpr2_(uplo, &i__2, &c_b1, &ap[k1], &c__1, &bp[k1], &c__1, & + ap[1]); + i__2 = k - 1; + zaxpy_(&i__2, &ct, &bp[k1], &c__1, &ap[k1], &c__1); + i__2 = k - 1; + zdscal_(&i__2, &bkk, &ap[k1], &c__1); + i__2 = kk; +/* Computing 2nd power */ + d__2 = bkk; + d__1 = akk * (d__2 * d__2); + ap[i__2].r = d__1, ap[i__2].i = 0.; +/* L30: */ + } + } else { + +/* Compute L**H *A*L */ + +/* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1) */ + + jj = 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + j1j1 = jj + *n - j + 1; + +/* Compute the j-th column of the lower triangle of A */ + + i__2 = jj; + ajj = ap[i__2].r; + i__2 = jj; + bjj = bp[i__2].r; + i__2 = jj; + d__1 = ajj * bjj; + i__3 = *n - j; + zdotc_(&z__2, &i__3, &ap[jj + 1], &c__1, &bp[jj + 1], &c__1); + z__1.r = d__1 + z__2.r, z__1.i = z__2.i; + ap[i__2].r = z__1.r, ap[i__2].i = z__1.i; + i__2 = *n - j; + zdscal_(&i__2, &bjj, &ap[jj + 1], &c__1); + i__2 = *n - j; + zhpmv_(uplo, &i__2, &c_b1, &ap[j1j1], &bp[jj + 1], &c__1, & + c_b1, &ap[jj + 1], &c__1); + i__2 = *n - j + 1; + ztpmv_(uplo, "Conjugate transpose", "Non-unit", &i__2, &bp[jj] + , &ap[jj], &c__1); + jj = j1j1; +/* L40: */ + } + } + } + return 0; + +/* End of ZHPGST */ + +} /* zhpgst_ */ + diff --git a/lapack-netlib/SRC/zhpgv.c b/lapack-netlib/SRC/zhpgv.c new file mode 100644 index 000000000..8fcaa9591 --- /dev/null +++ b/lapack-netlib/SRC/zhpgv.c @@ -0,0 +1,694 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHPGV */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHPGV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, */ +/* RWORK, INFO ) */ + +/* CHARACTER JOBZ, UPLO */ +/* INTEGER INFO, ITYPE, LDZ, N */ +/* DOUBLE PRECISION RWORK( * ), W( * ) */ +/* COMPLEX*16 AP( * ), BP( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHPGV computes all the eigenvalues and, optionally, the eigenvectors */ +/* > of a complex generalized Hermitian-definite eigenproblem, of the form */ +/* > A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. */ +/* > Here A and B are assumed to be Hermitian, stored in packed format, */ +/* > and B is also positive definite. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ITYPE */ +/* > \verbatim */ +/* > ITYPE is INTEGER */ +/* > Specifies the problem type to be solved: */ +/* > = 1: A*x = (lambda)*B*x */ +/* > = 2: A*B*x = (lambda)*x */ +/* > = 3: B*A*x = (lambda)*x */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBZ */ +/* > \verbatim */ +/* > JOBZ is CHARACTER*1 */ +/* > = 'N': Compute eigenvalues only; */ +/* > = 'V': Compute eigenvalues and eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangles of A and B are stored; */ +/* > = 'L': Lower triangles of A and B are stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the Hermitian matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* > */ +/* > On exit, the contents of AP are destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] BP */ +/* > \verbatim */ +/* > BP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the Hermitian matrix */ +/* > B, packed columnwise in a linear array. The j-th column of B */ +/* > is stored in the array BP as follows: */ +/* > if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */ +/* > */ +/* > On exit, the triangular factor U or L from the Cholesky */ +/* > factorization B = U**H*U or B = L*L**H, in the same storage */ +/* > format as B. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is DOUBLE PRECISION array, dimension (N) */ +/* > If INFO = 0, the eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX*16 array, dimension (LDZ, N) */ +/* > If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */ +/* > eigenvectors. The eigenvectors are normalized as follows: */ +/* > if ITYPE = 1 or 2, Z**H*B*Z = I; */ +/* > if ITYPE = 3, Z**H*inv(B)*Z = I. */ +/* > If JOBZ = 'N', then Z is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1, and if */ +/* > JOBZ = 'V', LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (f2cmax(1, 2*N-1)) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (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 */ +/* > > 0: ZPPTRF or ZHPEV returned an error code: */ +/* > <= N: if INFO = i, ZHPEV failed to converge; */ +/* > i off-diagonal elements of an intermediate */ +/* > tridiagonal form did not convergeto zero; */ +/* > > N: if INFO = N + i, for 1 <= i <= n, then the leading */ +/* > minor of order i of B is not positive definite. */ +/* > The factorization of B could not be completed and */ +/* > no eigenvalues or eigenvectors were computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHEReigen */ + +/* ===================================================================== */ +/* Subroutine */ int zhpgv_(integer *itype, char *jobz, char *uplo, integer * + n, doublecomplex *ap, doublecomplex *bp, doublereal *w, doublecomplex + *z__, integer *ldz, doublecomplex *work, doublereal *rwork, integer * + info) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1; + + /* Local variables */ + integer neig, j; + extern logical lsame_(char *, char *); + char trans[1]; + logical upper; + extern /* Subroutine */ int zhpev_(char *, char *, integer *, + doublecomplex *, doublereal *, doublecomplex *, integer *, + doublecomplex *, doublereal *, integer *); + logical wantz; + extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *, + doublecomplex *, doublecomplex *, integer *), ztpsv_(char *, char *, char *, integer *, doublecomplex * + , doublecomplex *, integer *), xerbla_( + char *, integer *, ftnlen), zhpgst_(integer *, char *, integer *, + doublecomplex *, doublecomplex *, integer *), zpptrf_( + char *, integer *, doublecomplex *, integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --bp; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --rwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + upper = lsame_(uplo, "U"); + + *info = 0; + if (*itype < 1 || *itype > 3) { + *info = -1; + } else if (! (wantz || lsame_(jobz, "N"))) { + *info = -2; + } else if (! (upper || lsame_(uplo, "L"))) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -9; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHPGV ", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Form a Cholesky factorization of B. */ + + zpptrf_(uplo, n, &bp[1], info); + if (*info != 0) { + *info = *n + *info; + return 0; + } + +/* Transform problem to standard eigenvalue problem and solve. */ + + zhpgst_(itype, uplo, n, &ap[1], &bp[1], info); + zhpev_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], & + rwork[1], info); + + if (wantz) { + +/* Backtransform eigenvectors to the original problem. */ + + neig = *n; + if (*info > 0) { + neig = *info - 1; + } + if (*itype == 1 || *itype == 2) { + +/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */ +/* backtransform eigenvectors: x = inv(L)**H *y or inv(U)*y */ + + if (upper) { + *(unsigned char *)trans = 'N'; + } else { + *(unsigned char *)trans = 'C'; + } + + i__1 = neig; + for (j = 1; j <= i__1; ++j) { + ztpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + + 1], &c__1); +/* L10: */ + } + + } else if (*itype == 3) { + +/* For B*A*x=(lambda)*x; */ +/* backtransform eigenvectors: x = L*y or U**H *y */ + + if (upper) { + *(unsigned char *)trans = 'C'; + } else { + *(unsigned char *)trans = 'N'; + } + + i__1 = neig; + for (j = 1; j <= i__1; ++j) { + ztpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + + 1], &c__1); +/* L20: */ + } + } + } + return 0; + +/* End of ZHPGV */ + +} /* zhpgv_ */ + diff --git a/lapack-netlib/SRC/zhpgvd.c b/lapack-netlib/SRC/zhpgvd.c new file mode 100644 index 000000000..0a9b36e3a --- /dev/null +++ b/lapack-netlib/SRC/zhpgvd.c @@ -0,0 +1,817 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHPGVD */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHPGVD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK, */ +/* LWORK, RWORK, LRWORK, IWORK, LIWORK, INFO ) */ + +/* CHARACTER JOBZ, UPLO */ +/* INTEGER INFO, ITYPE, LDZ, LIWORK, LRWORK, LWORK, N */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION RWORK( * ), W( * ) */ +/* COMPLEX*16 AP( * ), BP( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHPGVD computes all the eigenvalues and, optionally, the eigenvectors */ +/* > of a complex generalized Hermitian-definite eigenproblem, of the form */ +/* > A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */ +/* > B are assumed to be Hermitian, stored in packed format, and B is also */ +/* > positive definite. */ +/* > If eigenvectors are desired, it uses a divide and conquer algorithm. */ +/* > */ +/* > The divide and conquer algorithm makes very mild assumptions about */ +/* > floating point arithmetic. It will work on machines with a guard */ +/* > digit in add/subtract, or on those binary machines without guard */ +/* > digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ +/* > Cray-2. It could conceivably fail on hexadecimal or decimal machines */ +/* > without guard digits, but we know of none. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ITYPE */ +/* > \verbatim */ +/* > ITYPE is INTEGER */ +/* > Specifies the problem type to be solved: */ +/* > = 1: A*x = (lambda)*B*x */ +/* > = 2: A*B*x = (lambda)*x */ +/* > = 3: B*A*x = (lambda)*x */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBZ */ +/* > \verbatim */ +/* > JOBZ is CHARACTER*1 */ +/* > = 'N': Compute eigenvalues only; */ +/* > = 'V': Compute eigenvalues and eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangles of A and B are stored; */ +/* > = 'L': Lower triangles of A and B are stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the Hermitian matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* > */ +/* > On exit, the contents of AP are destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] BP */ +/* > \verbatim */ +/* > BP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the Hermitian matrix */ +/* > B, packed columnwise in a linear array. The j-th column of B */ +/* > is stored in the array BP as follows: */ +/* > if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */ +/* > */ +/* > On exit, the triangular factor U or L from the Cholesky */ +/* > factorization B = U**H*U or B = L*L**H, in the same storage */ +/* > format as B. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is DOUBLE PRECISION array, dimension (N) */ +/* > If INFO = 0, the eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX*16 array, dimension (LDZ, N) */ +/* > If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */ +/* > eigenvectors. The eigenvectors are normalized as follows: */ +/* > if ITYPE = 1 or 2, Z**H*B*Z = I; */ +/* > if ITYPE = 3, Z**H*inv(B)*Z = I. */ +/* > If JOBZ = 'N', then Z is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1, and if */ +/* > JOBZ = 'V', LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the required LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > If N <= 1, LWORK >= 1. */ +/* > If JOBZ = 'N' and N > 1, LWORK >= N. */ +/* > If JOBZ = 'V' and N > 1, LWORK >= 2*N. */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the routine */ +/* > only calculates the required sizes of the WORK, RWORK and */ +/* > IWORK arrays, returns these values as the first entries of */ +/* > the WORK, RWORK and IWORK arrays, and no error message */ +/* > related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK)) */ +/* > On exit, if INFO = 0, RWORK(1) returns the required LRWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LRWORK */ +/* > \verbatim */ +/* > LRWORK is INTEGER */ +/* > The dimension of array RWORK. */ +/* > If N <= 1, LRWORK >= 1. */ +/* > If JOBZ = 'N' and N > 1, LRWORK >= N. */ +/* > If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2. */ +/* > */ +/* > If LRWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the required sizes of the WORK, RWORK */ +/* > and IWORK arrays, returns these values as the first entries */ +/* > of the WORK, RWORK and IWORK arrays, and no error message */ +/* > related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */ +/* > On exit, if INFO = 0, IWORK(1) returns the required LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of array IWORK. */ +/* > If JOBZ = 'N' or N <= 1, LIWORK >= 1. */ +/* > If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */ +/* > */ +/* > If LIWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the required sizes of the WORK, RWORK */ +/* > and IWORK arrays, returns these values as the first entries */ +/* > of the WORK, RWORK and IWORK arrays, and no error message */ +/* > related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: ZPPTRF or ZHPEVD returned an error code: */ +/* > <= N: if INFO = i, ZHPEVD failed to converge; */ +/* > i off-diagonal elements of an intermediate */ +/* > tridiagonal form did not convergeto zero; */ +/* > > N: if INFO = N + i, for 1 <= i <= n, then the leading */ +/* > minor of order i of B is not positive definite. */ +/* > The factorization of B could not be completed and */ +/* > no eigenvalues or eigenvectors were computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHEReigen */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ + +/* ===================================================================== */ +/* Subroutine */ int zhpgvd_(integer *itype, char *jobz, char *uplo, integer * + n, doublecomplex *ap, doublecomplex *bp, doublereal *w, doublecomplex + *z__, integer *ldz, doublecomplex *work, integer *lwork, doublereal * + rwork, integer *lrwork, integer *iwork, integer *liwork, integer * + info) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1; + doublereal d__1, d__2; + + /* Local variables */ + integer neig, j; + extern logical lsame_(char *, char *); + integer lwmin; + char trans[1]; + logical upper, wantz; + extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *, + doublecomplex *, doublecomplex *, integer *), ztpsv_(char *, char *, char *, integer *, doublecomplex * + , doublecomplex *, integer *), xerbla_( + char *, integer *, ftnlen); + integer liwmin; + extern /* Subroutine */ int zhpevd_(char *, char *, integer *, + doublecomplex *, doublereal *, doublecomplex *, integer *, + doublecomplex *, integer *, doublereal *, integer *, integer *, + integer *, integer *); + integer lrwmin; + extern /* Subroutine */ int zhpgst_(integer *, char *, integer *, + doublecomplex *, doublecomplex *, integer *); + logical lquery; + extern /* Subroutine */ int zpptrf_(char *, integer *, doublecomplex *, + integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --bp; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --rwork; + --iwork; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + upper = lsame_(uplo, "U"); + lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1; + + *info = 0; + if (*itype < 1 || *itype > 3) { + *info = -1; + } else if (! (wantz || lsame_(jobz, "N"))) { + *info = -2; + } else if (! (upper || lsame_(uplo, "L"))) { + *info = -3; + } else if (*n < 0) { + *info = -4; + } else if (*ldz < 1 || wantz && *ldz < *n) { + *info = -9; + } + + if (*info == 0) { + if (*n <= 1) { + lwmin = 1; + liwmin = 1; + lrwmin = 1; + } else { + if (wantz) { + lwmin = *n << 1; +/* Computing 2nd power */ + i__1 = *n; + lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1); + liwmin = *n * 5 + 3; + } else { + lwmin = *n; + lrwmin = *n; + liwmin = 1; + } + } + + work[1].r = (doublereal) lwmin, work[1].i = 0.; + rwork[1] = (doublereal) lrwmin; + iwork[1] = liwmin; + if (*lwork < lwmin && ! lquery) { + *info = -11; + } else if (*lrwork < lrwmin && ! lquery) { + *info = -13; + } else if (*liwork < liwmin && ! lquery) { + *info = -15; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHPGVD", &i__1, (ftnlen)6); + return 0; + } else if (lquery) { + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Form a Cholesky factorization of B. */ + + zpptrf_(uplo, n, &bp[1], info); + if (*info != 0) { + *info = *n + *info; + return 0; + } + +/* Transform problem to standard eigenvalue problem and solve. */ + + zhpgst_(itype, uplo, n, &ap[1], &bp[1], info); + zhpevd_(jobz, uplo, n, &ap[1], &w[1], &z__[z_offset], ldz, &work[1], + lwork, &rwork[1], lrwork, &iwork[1], liwork, info); +/* Computing MAX */ + d__1 = (doublereal) lwmin, d__2 = work[1].r; + lwmin = (integer) f2cmax(d__1,d__2); +/* Computing MAX */ + d__1 = (doublereal) lrwmin; + lrwmin = (integer) f2cmax(d__1,rwork[1]); +/* Computing MAX */ + d__1 = (doublereal) liwmin, d__2 = (doublereal) iwork[1]; + liwmin = (integer) f2cmax(d__1,d__2); + + if (wantz) { + +/* Backtransform eigenvectors to the original problem. */ + + neig = *n; + if (*info > 0) { + neig = *info - 1; + } + if (*itype == 1 || *itype == 2) { + +/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */ +/* backtransform eigenvectors: x = inv(L)**H *y or inv(U)*y */ + + if (upper) { + *(unsigned char *)trans = 'N'; + } else { + *(unsigned char *)trans = 'C'; + } + + i__1 = neig; + for (j = 1; j <= i__1; ++j) { + ztpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + + 1], &c__1); +/* L10: */ + } + + } else if (*itype == 3) { + +/* For B*A*x=(lambda)*x; */ +/* backtransform eigenvectors: x = L*y or U**H *y */ + + if (upper) { + *(unsigned char *)trans = 'C'; + } else { + *(unsigned char *)trans = 'N'; + } + + i__1 = neig; + for (j = 1; j <= i__1; ++j) { + ztpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + + 1], &c__1); +/* L20: */ + } + } + } + + work[1].r = (doublereal) lwmin, work[1].i = 0.; + rwork[1] = (doublereal) lrwmin; + iwork[1] = liwmin; + return 0; + +/* End of ZHPGVD */ + +} /* zhpgvd_ */ + diff --git a/lapack-netlib/SRC/zhpgvx.c b/lapack-netlib/SRC/zhpgvx.c new file mode 100644 index 000000000..f9778101c --- /dev/null +++ b/lapack-netlib/SRC/zhpgvx.c @@ -0,0 +1,832 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHPGVX */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHPGVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU, */ +/* IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, */ +/* IWORK, IFAIL, INFO ) */ + +/* CHARACTER JOBZ, RANGE, UPLO */ +/* INTEGER IL, INFO, ITYPE, IU, LDZ, M, N */ +/* DOUBLE PRECISION ABSTOL, VL, VU */ +/* INTEGER IFAIL( * ), IWORK( * ) */ +/* DOUBLE PRECISION RWORK( * ), W( * ) */ +/* COMPLEX*16 AP( * ), BP( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHPGVX computes selected eigenvalues and, optionally, eigenvectors */ +/* > of a complex generalized Hermitian-definite eigenproblem, of the form */ +/* > A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and */ +/* > B are assumed to be Hermitian, stored in packed format, and B is also */ +/* > positive definite. Eigenvalues and eigenvectors can be selected by */ +/* > specifying either a range of values or a range of indices for the */ +/* > desired eigenvalues. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] ITYPE */ +/* > \verbatim */ +/* > ITYPE is INTEGER */ +/* > Specifies the problem type to be solved: */ +/* > = 1: A*x = (lambda)*B*x */ +/* > = 2: A*B*x = (lambda)*x */ +/* > = 3: B*A*x = (lambda)*x */ +/* > \endverbatim */ +/* > */ +/* > \param[in] JOBZ */ +/* > \verbatim */ +/* > JOBZ is CHARACTER*1 */ +/* > = 'N': Compute eigenvalues only; */ +/* > = 'V': Compute eigenvalues and eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RANGE */ +/* > \verbatim */ +/* > RANGE is CHARACTER*1 */ +/* > = 'A': all eigenvalues will be found; */ +/* > = 'V': all eigenvalues in the half-open interval (VL,VU] */ +/* > will be found; */ +/* > = 'I': the IL-th through IU-th eigenvalues will be found. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangles of A and B are stored; */ +/* > = 'L': Lower triangles of A and B are stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrices A and B. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the Hermitian matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* > */ +/* > On exit, the contents of AP are destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] BP */ +/* > \verbatim */ +/* > BP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the Hermitian matrix */ +/* > B, packed columnwise in a linear array. The j-th column of B */ +/* > is stored in the array BP as follows: */ +/* > if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n. */ +/* > */ +/* > On exit, the triangular factor U or L from the Cholesky */ +/* > factorization B = U**H*U or B = L*L**H, in the same storage */ +/* > format as B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VL */ +/* > \verbatim */ +/* > VL is DOUBLE PRECISION */ +/* > */ +/* > If RANGE='V', the lower bound of the interval to */ +/* > be searched for eigenvalues. VL < VU. */ +/* > Not referenced if RANGE = 'A' or 'I'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] VU */ +/* > \verbatim */ +/* > VU is DOUBLE PRECISION */ +/* > */ +/* > If RANGE='V', the upper bound of the interval to */ +/* > be searched for eigenvalues. VL < VU. */ +/* > Not referenced if RANGE = 'A' or 'I'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IL */ +/* > \verbatim */ +/* > IL is INTEGER */ +/* > */ +/* > If RANGE='I', the index of the */ +/* > smallest eigenvalue to be returned. */ +/* > 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ +/* > Not referenced if RANGE = 'A' or 'V'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IU */ +/* > \verbatim */ +/* > IU is INTEGER */ +/* > */ +/* > If RANGE='I', the index of the */ +/* > largest eigenvalue to be returned. */ +/* > 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */ +/* > Not referenced if RANGE = 'A' or 'V'. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ABSTOL */ +/* > \verbatim */ +/* > ABSTOL is DOUBLE PRECISION */ +/* > The absolute error tolerance for the eigenvalues. */ +/* > An approximate eigenvalue is accepted as converged */ +/* > when it is determined to lie in an interval [a,b] */ +/* > of width less than or equal to */ +/* > */ +/* > ABSTOL + EPS * f2cmax( |a|,|b| ) , */ +/* > */ +/* > where EPS is the machine precision. If ABSTOL is less than */ +/* > or equal to zero, then EPS*|T| will be used in its place, */ +/* > where |T| is the 1-norm of the tridiagonal matrix obtained */ +/* > by reducing AP to tridiagonal form. */ +/* > */ +/* > Eigenvalues will be computed most accurately when ABSTOL is */ +/* > set to twice the underflow threshold 2*DLAMCH('S'), not zero. */ +/* > If this routine returns with INFO>0, indicating that some */ +/* > eigenvectors did not converge, try setting ABSTOL to */ +/* > 2*DLAMCH('S'). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The total number of eigenvalues found. 0 <= M <= N. */ +/* > If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is DOUBLE PRECISION array, dimension (N) */ +/* > On normal exit, the first M elements contain the selected */ +/* > eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX*16 array, dimension (LDZ, N) */ +/* > If JOBZ = 'N', then Z is not referenced. */ +/* > If JOBZ = 'V', then if INFO = 0, the first M columns of Z */ +/* > contain the orthonormal eigenvectors of the matrix A */ +/* > corresponding to the selected eigenvalues, with the i-th */ +/* > column of Z holding the eigenvector associated with W(i). */ +/* > The eigenvectors are normalized as follows: */ +/* > if ITYPE = 1 or 2, Z**H*B*Z = I; */ +/* > if ITYPE = 3, Z**H*inv(B)*Z = I. */ +/* > */ +/* > If an eigenvector fails to converge, then that column of Z */ +/* > contains the latest approximation to the eigenvector, and the */ +/* > index of the eigenvector is returned in IFAIL. */ +/* > Note: the user must ensure that at least f2cmax(1,M) columns are */ +/* > supplied in the array Z; if RANGE = 'V', the exact value of M */ +/* > is not known in advance and an upper bound must be used. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. LDZ >= 1, and if */ +/* > JOBZ = 'V', LDZ >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (7*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (5*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IFAIL */ +/* > \verbatim */ +/* > IFAIL is INTEGER array, dimension (N) */ +/* > If JOBZ = 'V', then if INFO = 0, the first M elements of */ +/* > IFAIL are zero. If INFO > 0, then IFAIL contains the */ +/* > indices of the eigenvectors that failed to converge. */ +/* > If JOBZ = 'N', then IFAIL is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: ZPPTRF or ZHPEVX returned an error code: */ +/* > <= N: if INFO = i, ZHPEVX failed to converge; */ +/* > i eigenvectors failed to converge. Their indices */ +/* > are stored in array IFAIL. */ +/* > > N: if INFO = N + i, for 1 <= i <= n, then the leading */ +/* > minor of order i of B is not positive definite. */ +/* > The factorization of B could not be completed and */ +/* > no eigenvalues or eigenvectors were computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16OTHEReigen */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */ + +/* ===================================================================== */ +/* Subroutine */ int zhpgvx_(integer *itype, char *jobz, char *range, char * + uplo, integer *n, doublecomplex *ap, doublecomplex *bp, doublereal * + vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, + integer *m, doublereal *w, doublecomplex *z__, integer *ldz, + doublecomplex *work, doublereal *rwork, integer *iwork, integer * + ifail, integer *info) +{ + /* System generated locals */ + integer z_dim1, z_offset, i__1; + + /* Local variables */ + integer j; + extern logical lsame_(char *, char *); + char trans[1]; + logical upper, wantz; + extern /* Subroutine */ int ztpmv_(char *, char *, char *, integer *, + doublecomplex *, doublecomplex *, integer *), ztpsv_(char *, char *, char *, integer *, doublecomplex * + , doublecomplex *, integer *); + logical alleig, indeig, valeig; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zhpgst_( + integer *, char *, integer *, doublecomplex *, doublecomplex *, + integer *), zhpevx_(char *, char *, char *, integer *, + doublecomplex *, doublereal *, doublereal *, integer *, integer *, + doublereal *, integer *, doublereal *, doublecomplex *, integer * + , doublecomplex *, doublereal *, integer *, integer *, integer *), zpptrf_(char *, integer *, doublecomplex + *, integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --bp; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + --rwork; + --iwork; + --ifail; + + /* Function Body */ + wantz = lsame_(jobz, "V"); + upper = lsame_(uplo, "U"); + alleig = lsame_(range, "A"); + valeig = lsame_(range, "V"); + indeig = lsame_(range, "I"); + + *info = 0; + if (*itype < 1 || *itype > 3) { + *info = -1; + } else if (! (wantz || lsame_(jobz, "N"))) { + *info = -2; + } else if (! (alleig || valeig || indeig)) { + *info = -3; + } else if (! (upper || lsame_(uplo, "L"))) { + *info = -4; + } else if (*n < 0) { + *info = -5; + } else { + if (valeig) { + if (*n > 0 && *vu <= *vl) { + *info = -9; + } + } else if (indeig) { + if (*il < 1) { + *info = -10; + } else if (*iu < f2cmin(*n,*il) || *iu > *n) { + *info = -11; + } + } + } + if (*info == 0) { + if (*ldz < 1 || wantz && *ldz < *n) { + *info = -16; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHPGVX", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Form a Cholesky factorization of B. */ + + zpptrf_(uplo, n, &bp[1], info); + if (*info != 0) { + *info = *n + *info; + return 0; + } + +/* Transform problem to standard eigenvalue problem and solve. */ + + zhpgst_(itype, uplo, n, &ap[1], &bp[1], info); + zhpevx_(jobz, range, uplo, n, &ap[1], vl, vu, il, iu, abstol, m, &w[1], & + z__[z_offset], ldz, &work[1], &rwork[1], &iwork[1], &ifail[1], + info); + + if (wantz) { + +/* Backtransform eigenvectors to the original problem. */ + + if (*info > 0) { + *m = *info - 1; + } + if (*itype == 1 || *itype == 2) { + +/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */ +/* backtransform eigenvectors: x = inv(L)**H *y or inv(U)*y */ + + if (upper) { + *(unsigned char *)trans = 'N'; + } else { + *(unsigned char *)trans = 'C'; + } + + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + ztpsv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + + 1], &c__1); +/* L10: */ + } + + } else if (*itype == 3) { + +/* For B*A*x=(lambda)*x; */ +/* backtransform eigenvectors: x = L*y or U**H *y */ + + if (upper) { + *(unsigned char *)trans = 'C'; + } else { + *(unsigned char *)trans = 'N'; + } + + i__1 = *m; + for (j = 1; j <= i__1; ++j) { + ztpmv_(uplo, trans, "Non-unit", n, &bp[1], &z__[j * z_dim1 + + 1], &c__1); +/* L20: */ + } + } + } + + return 0; + +/* End of ZHPGVX */ + +} /* zhpgvx_ */ + diff --git a/lapack-netlib/SRC/zhprfs.c b/lapack-netlib/SRC/zhprfs.c new file mode 100644 index 000000000..137db0542 --- /dev/null +++ b/lapack-netlib/SRC/zhprfs.c @@ -0,0 +1,908 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHPRFS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHPRFS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, */ +/* FERR, BERR, WORK, RWORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDB, LDX, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * ) */ +/* COMPLEX*16 AFP( * ), AP( * ), B( LDB, * ), WORK( * ), */ +/* $ X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHPRFS improves the computed solution to a system of linear */ +/* > equations when the coefficient matrix is Hermitian indefinite */ +/* > and packed, and provides error bounds and backward error estimates */ +/* > for the solution. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > The upper or lower triangle of the Hermitian matrix A, packed */ +/* > columnwise in a linear array. The j-th column of A is stored */ +/* > in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AFP */ +/* > \verbatim */ +/* > AFP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > The factored form of the matrix A. AFP contains the block */ +/* > diagonal matrix D and the multipliers used to obtain the */ +/* > factor U or L from the factorization A = U*D*U**H or */ +/* > A = L*D*L**H as computed by ZHPTRF, stored as a packed */ +/* > triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by ZHPTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > The right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (LDX,NRHS) */ +/* > On entry, the solution matrix X, as computed by ZHPTRS. */ +/* > On exit, the improved solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* > \par Internal Parameters: */ +/* ========================= */ +/* > */ +/* > \verbatim */ +/* > ITMAX is the maximum number of steps of iterative refinement. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zhprfs_(char *uplo, integer *n, integer *nrhs, + doublecomplex *ap, doublecomplex *afp, integer *ipiv, doublecomplex * + b, integer *ldb, doublecomplex *x, integer *ldx, doublereal *ferr, + doublereal *berr, doublecomplex *work, doublereal *rwork, integer * + info) +{ + /* System generated locals */ + integer 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, d__4; + doublecomplex z__1; + + /* Local variables */ + integer kase; + doublereal safe1, safe2; + integer i__, j, k; + doublereal s; + extern logical lsame_(char *, char *); + integer isave[3], count; + logical upper; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zhpmv_(char *, integer *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, integer *), zaxpy_( + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *), zlacn2_(integer *, doublecomplex *, + doublecomplex *, doublereal *, integer *, integer *); + integer ik, kk; + extern doublereal dlamch_(char *); + doublereal xk; + integer nz; + doublereal safmin; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal lstres; + extern /* Subroutine */ int zhptrs_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *); + doublereal eps; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --afp; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --rwork; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < f2cmax(1,*n)) { + *info = -8; + } else if (*ldx < f2cmax(1,*n)) { + *info = -10; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHPRFS", &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; + } + +/* 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) { + + count = 1; + lstres = 3.; +L20: + +/* Loop until stopping criterion is satisfied. */ + +/* Compute residual R = B - A * X */ + + zcopy_(n, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1); + z__1.r = -1., z__1.i = 0.; + zhpmv_(uplo, n, &z__1, &ap[1], &x[j * x_dim1 + 1], &c__1, &c_b1, & + work[1], &c__1); + +/* Compute componentwise relative backward error from formula */ + +/* f2cmax(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) ) */ + +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. If the i-th component of the denominator is less */ +/* than SAFE2, then SAFE1 is added to the i-th components of the */ +/* numerator and denominator before dividing. */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + rwork[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[ + i__ + j * b_dim1]), abs(d__2)); +/* L30: */ + } + +/* Compute abs(A)*abs(X) + abs(B). */ + + kk = 1; + if (upper) { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + i__3 = k + j * x_dim1; + xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j * + x_dim1]), abs(d__2)); + ik = kk; + i__3 = k - 1; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = ik; + rwork[i__] += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 = + d_imag(&ap[ik]), abs(d__2))) * xk; + i__4 = ik; + i__5 = i__ + j * x_dim1; + s += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 = d_imag(&ap[ + ik]), abs(d__2))) * ((d__3 = x[i__5].r, abs(d__3)) + + (d__4 = d_imag(&x[i__ + j * x_dim1]), abs(d__4) + )); + ++ik; +/* L40: */ + } + i__3 = kk + k - 1; + rwork[k] = rwork[k] + (d__1 = ap[i__3].r, abs(d__1)) * xk + s; + kk += k; +/* L50: */ + } + } else { + i__2 = *n; + for (k = 1; k <= i__2; ++k) { + s = 0.; + i__3 = k + j * x_dim1; + xk = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = d_imag(&x[k + j * + x_dim1]), abs(d__2)); + i__3 = kk; + rwork[k] += (d__1 = ap[i__3].r, abs(d__1)) * xk; + ik = kk + 1; + i__3 = *n; + for (i__ = k + 1; i__ <= i__3; ++i__) { + i__4 = ik; + rwork[i__] += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 = + d_imag(&ap[ik]), abs(d__2))) * xk; + i__4 = ik; + i__5 = i__ + j * x_dim1; + s += ((d__1 = ap[i__4].r, abs(d__1)) + (d__2 = d_imag(&ap[ + ik]), abs(d__2))) * ((d__3 = x[i__5].r, abs(d__3)) + + (d__4 = d_imag(&x[i__ + j * x_dim1]), abs(d__4) + )); + ++ik; +/* L60: */ + } + rwork[k] += s; + kk += *n - k + 1; +/* L70: */ + } + } + s = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (rwork[i__] > safe2) { +/* Computing MAX */ + i__3 = i__; + d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 = + d_imag(&work[i__]), abs(d__2))) / rwork[i__]; + s = f2cmax(d__3,d__4); + } else { +/* Computing MAX */ + i__3 = i__; + d__3 = s, d__4 = ((d__1 = work[i__3].r, abs(d__1)) + (d__2 = + d_imag(&work[i__]), abs(d__2)) + safe1) / (rwork[i__] + + safe1); + s = f2cmax(d__3,d__4); + } +/* L80: */ + } + berr[j] = s; + +/* Test stopping criterion. Continue iterating if */ +/* 1) The residual BERR(J) is larger than machine epsilon, and */ +/* 2) BERR(J) decreased by at least a factor of 2 during the */ +/* last iteration, and */ +/* 3) At most ITMAX iterations tried. */ + + if (berr[j] > eps && berr[j] * 2. <= lstres && count <= 5) { + +/* Update solution and try again. */ + + zhptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info); + zaxpy_(n, &c_b1, &work[1], &c__1, &x[j * x_dim1 + 1], &c__1); + lstres = berr[j]; + ++count; + goto L20; + } + +/* Bound error from formula */ + +/* norm(X - XTRUE) / norm(X) .le. FERR = */ +/* norm( abs(inv(A))* */ +/* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X) */ + +/* where */ +/* norm(Z) is the magnitude of the largest component of Z */ +/* inv(A) is the inverse of A */ +/* abs(Z) is the componentwise absolute value of the matrix or */ +/* vector Z */ +/* NZ is the maximum number of nonzeros in any row of A, plus 1 */ +/* EPS is machine epsilon */ + +/* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B)) */ +/* is incremented by SAFE1 if the i-th component of */ +/* abs(A)*abs(X) + abs(B) is less than SAFE2. */ + +/* Use ZLACN2 to estimate the infinity-norm of the matrix */ +/* inv(A) * diag(W), */ +/* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (rwork[i__] > safe2) { + i__3 = i__; + rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 = + d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__] + ; + } else { + i__3 = i__; + rwork[i__] = (d__1 = work[i__3].r, abs(d__1)) + (d__2 = + d_imag(&work[i__]), abs(d__2)) + nz * eps * rwork[i__] + + safe1; + } +/* L90: */ + } + + kase = 0; +L100: + zlacn2_(n, &work[*n + 1], &work[1], &ferr[j], &kase, isave); + if (kase != 0) { + if (kase == 1) { + +/* Multiply by diag(W)*inv(A**H). */ + + zhptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__; + z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4] + * work[i__5].i; + work[i__3].r = z__1.r, work[i__3].i = z__1.i; +/* L110: */ + } + } else if (kase == 2) { + +/* Multiply by inv(A)*diag(W). */ + + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + i__4 = i__; + i__5 = i__; + z__1.r = rwork[i__4] * work[i__5].r, z__1.i = rwork[i__4] + * work[i__5].i; + work[i__3].r = z__1.r, work[i__3].i = z__1.i; +/* L120: */ + } + zhptrs_(uplo, n, &c__1, &afp[1], &ipiv[1], &work[1], n, info); + } + goto L100; + } + +/* Normalize error. */ + + lstres = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ + j * x_dim1; + d__3 = lstres, d__4 = (d__1 = x[i__3].r, abs(d__1)) + (d__2 = + d_imag(&x[i__ + j * x_dim1]), abs(d__2)); + lstres = f2cmax(d__3,d__4); +/* L130: */ + } + if (lstres != 0.) { + ferr[j] /= lstres; + } + +/* L140: */ + } + + return 0; + +/* End of ZHPRFS */ + +} /* zhprfs_ */ + diff --git a/lapack-netlib/SRC/zhpsv.c b/lapack-netlib/SRC/zhpsv.c new file mode 100644 index 000000000..58b0cba01 --- /dev/null +++ b/lapack-netlib/SRC/zhpsv.c @@ -0,0 +1,615 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief ZHPSV computes the solution to system of linear equations A * X = B for OTHER matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHPSV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 AP( * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHPSV computes the solution to a complex system of linear equations */ +/* > A * X = B, */ +/* > where A is an N-by-N Hermitian matrix stored in packed format and X */ +/* > and B are N-by-NRHS matrices. */ +/* > */ +/* > The diagonal pivoting method is used to factor A as */ +/* > A = U * D * U**H, if UPLO = 'U', or */ +/* > A = L * D * L**H, if UPLO = 'L', */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, D is Hermitian and block diagonal with 1-by-1 */ +/* > and 2-by-2 diagonal blocks. The factored form of A is then used to */ +/* > solve the system of equations A * X = B. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrix B. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the Hermitian matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > See below for further details. */ +/* > */ +/* > On exit, the block diagonal matrix D and the multipliers used */ +/* > to obtain the factor U or L from the factorization */ +/* > A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as */ +/* > a packed triangular matrix in the same storage format as A. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D, as */ +/* > determined by ZHPTRF. If IPIV(k) > 0, then rows and columns */ +/* > k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1 */ +/* > diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, */ +/* > then rows and columns k-1 and -IPIV(k) were interchanged and */ +/* > D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and */ +/* > IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and */ +/* > -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2 */ +/* > diagonal block. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > On entry, the N-by-NRHS right hand side matrix B. */ +/* > On exit, if INFO = 0, the N-by-NRHS solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, D(i,i) is exactly zero. The factorization */ +/* > has been completed, but the block diagonal matrix D is */ +/* > exactly singular, so the solution could not be */ +/* > computed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERsolve */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The packed storage scheme is illustrated by the following example */ +/* > when N = 4, UPLO = 'U': */ +/* > */ +/* > Two-dimensional storage of the Hermitian matrix A: */ +/* > */ +/* > a11 a12 a13 a14 */ +/* > a22 a23 a24 */ +/* > a33 a34 (aij = conjg(aji)) */ +/* > a44 */ +/* > */ +/* > Packed storage of the upper triangle of A: */ +/* > */ +/* > AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zhpsv_(char *uplo, integer *n, integer *nrhs, + doublecomplex *ap, integer *ipiv, doublecomplex *b, integer *ldb, + integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1; + + /* Local variables */ + extern logical lsame_(char *, char *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zhptrf_( + char *, integer *, doublecomplex *, integer *, integer *), + zhptrs_(char *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHPSV ", &i__1, (ftnlen)6); + return 0; + } + +/* Compute the factorization A = U*D*U**H or A = L*D*L**H. */ + + zhptrf_(uplo, n, &ap[1], &ipiv[1], info); + if (*info == 0) { + +/* Solve the system A*X = B, overwriting B with X. */ + + zhptrs_(uplo, n, nrhs, &ap[1], &ipiv[1], &b[b_offset], ldb, info); + + } + return 0; + +/* End of ZHPSV */ + +} /* zhpsv_ */ + diff --git a/lapack-netlib/SRC/zhpsvx.c b/lapack-netlib/SRC/zhpsvx.c new file mode 100644 index 000000000..1e308bb19 --- /dev/null +++ b/lapack-netlib/SRC/zhpsvx.c @@ -0,0 +1,794 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief ZHPSVX computes the solution to system of linear equations A * X = B for OTHER matrices */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHPSVX + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, */ +/* LDX, RCOND, FERR, BERR, WORK, RWORK, INFO ) */ + +/* CHARACTER FACT, UPLO */ +/* INTEGER INFO, LDB, LDX, N, NRHS */ +/* DOUBLE PRECISION RCOND */ +/* INTEGER IPIV( * ) */ +/* DOUBLE PRECISION BERR( * ), FERR( * ), RWORK( * ) */ +/* COMPLEX*16 AFP( * ), AP( * ), B( LDB, * ), WORK( * ), */ +/* $ X( LDX, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHPSVX uses the diagonal pivoting factorization A = U*D*U**H or */ +/* > A = L*D*L**H to compute the solution to a complex system of linear */ +/* > equations A * X = B, where A is an N-by-N Hermitian matrix stored */ +/* > in packed format and X and B are N-by-NRHS matrices. */ +/* > */ +/* > Error bounds on the solution and a condition estimate are also */ +/* > provided. */ +/* > \endverbatim */ + +/* > \par Description: */ +/* ================= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The following steps are performed: */ +/* > */ +/* > 1. If FACT = 'N', the diagonal pivoting method is used to factor A as */ +/* > A = U * D * U**H, if UPLO = 'U', or */ +/* > A = L * D * L**H, if UPLO = 'L', */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices and D is Hermitian and block diagonal with */ +/* > 1-by-1 and 2-by-2 diagonal blocks. */ +/* > */ +/* > 2. If some D(i,i)=0, so that D is exactly singular, then the routine */ +/* > returns with INFO = i. Otherwise, the factored form of A is used */ +/* > to estimate the condition number of the matrix A. If the */ +/* > reciprocal of the condition number is less than machine precision, */ +/* > INFO = N+1 is returned as a warning, but the routine still goes on */ +/* > to solve for X and compute error bounds as described below. */ +/* > */ +/* > 3. The system of equations is solved for X using the factored form */ +/* > of A. */ +/* > */ +/* > 4. Iterative refinement is applied to improve the computed solution */ +/* > matrix and calculate error bounds and backward error estimates */ +/* > for it. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] FACT */ +/* > \verbatim */ +/* > FACT is CHARACTER*1 */ +/* > Specifies whether or not the factored form of A has been */ +/* > supplied on entry. */ +/* > = 'F': On entry, AFP and IPIV contain the factored form of */ +/* > A. AFP and IPIV will not be modified. */ +/* > = 'N': The matrix A will be copied to AFP and factored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices B and X. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AP */ +/* > \verbatim */ +/* > AP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > The upper or lower triangle of the Hermitian matrix A, packed */ +/* > columnwise in a linear array. The j-th column of A is stored */ +/* > in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* > See below for further details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AFP */ +/* > \verbatim */ +/* > AFP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > If FACT = 'F', then AFP is an input argument and on entry */ +/* > contains the block diagonal matrix D and the multipliers used */ +/* > to obtain the factor U or L from the factorization */ +/* > A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as */ +/* > a packed triangular matrix in the same storage format as A. */ +/* > */ +/* > If FACT = 'N', then AFP is an output argument and on exit */ +/* > contains the block diagonal matrix D and the multipliers used */ +/* > to obtain the factor U or L from the factorization */ +/* > A = U*D*U**H or A = L*D*L**H as computed by ZHPTRF, stored as */ +/* > a packed triangular matrix in the same storage format as A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > If FACT = 'F', then IPIV is an input argument and on entry */ +/* > contains details of the interchanges and the block structure */ +/* > of D, as determined by ZHPTRF. */ +/* > If IPIV(k) > 0, then rows and columns k and IPIV(k) were */ +/* > interchanged and D(k,k) is a 1-by-1 diagonal block. */ +/* > If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and */ +/* > columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k) */ +/* > is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) = */ +/* > IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were */ +/* > interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block. */ +/* > */ +/* > If FACT = 'N', then IPIV is an output argument and on exit */ +/* > contains details of the interchanges and the block structure */ +/* > of D, as determined by ZHPTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > The N-by-NRHS right hand side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (LDX,NRHS) */ +/* > If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > The estimate of the reciprocal condition number of the matrix */ +/* > A. If RCOND is less than the machine precision (in */ +/* > particular, if RCOND = 0), the matrix is singular to working */ +/* > precision. This condition is indicated by a return code of */ +/* > INFO > 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] FERR */ +/* > \verbatim */ +/* > FERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The estimated forward error bound for each solution vector */ +/* > X(j) (the j-th column of the solution matrix X). */ +/* > If XTRUE is the true solution corresponding to X(j), FERR(j) */ +/* > is an estimated upper bound for the magnitude of the largest */ +/* > element in (X(j) - XTRUE) divided by the magnitude of the */ +/* > largest element in X(j). The estimate is as reliable as */ +/* > the estimate for RCOND, and is almost always a slight */ +/* > overestimate of the true error. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The componentwise relative backward error of each solution */ +/* > vector X(j) (i.e., the smallest relative change in */ +/* > any element of A or B that makes X(j) an exact solution). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, and i is */ +/* > <= N: D(i,i) is exactly zero. The factorization */ +/* > has been completed but the factor D is exactly */ +/* > singular, so the solution and error bounds could */ +/* > not be computed. RCOND = 0 is returned. */ +/* > = N+1: D is nonsingular, but RCOND is less than machine */ +/* > precision, meaning that the matrix is singular */ +/* > to working precision. Nevertheless, the */ +/* > solution and error bounds are computed because */ +/* > there are a number of situations where the */ +/* > computed solution can be more accurate than the */ +/* > value of RCOND would suggest. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date April 2012 */ + +/* > \ingroup complex16OTHERsolve */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The packed storage scheme is illustrated by the following example */ +/* > when N = 4, UPLO = 'U': */ +/* > */ +/* > Two-dimensional storage of the Hermitian matrix A: */ +/* > */ +/* > a11 a12 a13 a14 */ +/* > a22 a23 a24 */ +/* > a33 a34 (aij = conjg(aji)) */ +/* > a44 */ +/* > */ +/* > Packed storage of the upper triangle of A: */ +/* > */ +/* > AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ] */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zhpsvx_(char *fact, char *uplo, integer *n, integer * + nrhs, doublecomplex *ap, doublecomplex *afp, integer *ipiv, + doublecomplex *b, integer *ldb, doublecomplex *x, integer *ldx, + doublereal *rcond, doublereal *ferr, doublereal *berr, doublecomplex * + work, doublereal *rwork, integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, x_dim1, x_offset, i__1; + + /* Local variables */ + extern logical lsame_(char *, char *); + doublereal anorm; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + extern doublereal dlamch_(char *); + logical nofact; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *, + doublereal *); + extern /* Subroutine */ int zhpcon_(char *, integer *, doublecomplex *, + integer *, doublereal *, doublereal *, doublecomplex *, integer *), zlacpy_(char *, integer *, integer *, doublecomplex *, + integer *, doublecomplex *, integer *), zhprfs_(char *, + integer *, integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublereal *, doublereal *, doublecomplex *, doublereal *, + integer *), zhptrf_(char *, integer *, doublecomplex *, + integer *, integer *), zhptrs_(char *, integer *, integer + *, doublecomplex *, integer *, doublecomplex *, integer *, + integer *); + + +/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* April 2012 */ + + +/* ===================================================================== */ + + +/* Test the input parameters. */ + + /* Parameter adjustments */ + --ap; + --afp; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + --ferr; + --berr; + --work; + --rwork; + + /* Function Body */ + *info = 0; + nofact = lsame_(fact, "N"); + if (! nofact && ! lsame_(fact, "F")) { + *info = -1; + } else if (! lsame_(uplo, "U") && ! lsame_(uplo, + "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*ldb < f2cmax(1,*n)) { + *info = -9; + } else if (*ldx < f2cmax(1,*n)) { + *info = -11; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHPSVX", &i__1, (ftnlen)6); + return 0; + } + + if (nofact) { + +/* Compute the factorization A = U*D*U**H or A = L*D*L**H. */ + + i__1 = *n * (*n + 1) / 2; + zcopy_(&i__1, &ap[1], &c__1, &afp[1], &c__1); + zhptrf_(uplo, n, &afp[1], &ipiv[1], info); + +/* Return if INFO is non-zero. */ + + if (*info > 0) { + *rcond = 0.; + return 0; + } + } + +/* Compute the norm of the matrix A. */ + + anorm = zlanhp_("I", uplo, n, &ap[1], &rwork[1]); + +/* Compute the reciprocal of the condition number of A. */ + + zhpcon_(uplo, n, &afp[1], &ipiv[1], &anorm, rcond, &work[1], info); + +/* Compute the solution vectors X. */ + + zlacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx); + zhptrs_(uplo, n, nrhs, &afp[1], &ipiv[1], &x[x_offset], ldx, info); + +/* Use iterative refinement to improve the computed solutions and */ +/* compute error bounds and backward error estimates for them. */ + + zhprfs_(uplo, n, nrhs, &ap[1], &afp[1], &ipiv[1], &b[b_offset], ldb, &x[ + x_offset], ldx, &ferr[1], &berr[1], &work[1], &rwork[1], info); + +/* Set INFO = N+1 if the matrix is singular to working precision. */ + + if (*rcond < dlamch_("Epsilon")) { + *info = *n + 1; + } + + return 0; + +/* End of ZHPSVX */ + +} /* zhpsvx_ */ + diff --git a/lapack-netlib/SRC/zhptrd.c b/lapack-netlib/SRC/zhptrd.c new file mode 100644 index 000000000..8214e7c59 --- /dev/null +++ b/lapack-netlib/SRC/zhptrd.c @@ -0,0 +1,755 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHPTRD */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHPTRD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHPTRD( UPLO, N, AP, D, E, TAU, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N */ +/* DOUBLE PRECISION D( * ), E( * ) */ +/* COMPLEX*16 AP( * ), TAU( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHPTRD reduces a complex Hermitian matrix A stored in packed form to */ +/* > real symmetric tridiagonal form T by a unitary similarity */ +/* > transformation: Q**H * A * Q = T. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the Hermitian matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ +/* > On exit, if UPLO = 'U', the diagonal and first superdiagonal */ +/* > of A are overwritten by the corresponding elements of the */ +/* > tridiagonal matrix T, and the elements above the first */ +/* > superdiagonal, with the array TAU, represent the unitary */ +/* > matrix Q as a product of elementary reflectors; if UPLO */ +/* > = 'L', the diagonal and first subdiagonal of A are over- */ +/* > written by the corresponding elements of the tridiagonal */ +/* > matrix T, and the elements below the first subdiagonal, with */ +/* > the array TAU, represent the unitary matrix Q as a product */ +/* > of elementary reflectors. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > The diagonal elements of the tridiagonal matrix T: */ +/* > D(i) = A(i,i). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > The off-diagonal elements of the tridiagonal matrix T: */ +/* > E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAU */ +/* > \verbatim */ +/* > TAU is COMPLEX*16 array, dimension (N-1) */ +/* > The scalar factors of the elementary reflectors (see Further */ +/* > Details). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > If UPLO = 'U', the matrix Q is represented as a product of elementary */ +/* > reflectors */ +/* > */ +/* > Q = H(n-1) . . . H(2) H(1). */ +/* > */ +/* > Each H(i) has the form */ +/* > */ +/* > H(i) = I - tau * v * v**H */ +/* > */ +/* > where tau is a complex scalar, and v is a complex vector with */ +/* > v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP, */ +/* > overwriting A(1:i-1,i+1), and tau is stored in TAU(i). */ +/* > */ +/* > If UPLO = 'L', the matrix Q is represented as a product of elementary */ +/* > reflectors */ +/* > */ +/* > Q = H(1) H(2) . . . H(n-1). */ +/* > */ +/* > Each H(i) has the form */ +/* > */ +/* > H(i) = I - tau * v * v**H */ +/* > */ +/* > where tau is a complex scalar, and v is a complex vector with */ +/* > v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP, */ +/* > overwriting A(i+2:n,i), and tau is stored in TAU(i). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zhptrd_(char *uplo, integer *n, doublecomplex *ap, + doublereal *d__, doublereal *e, doublecomplex *tau, integer *info) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + doublereal d__1; + doublecomplex z__1, z__2, z__3, z__4; + + /* Local variables */ + doublecomplex taui; + extern /* Subroutine */ int zhpr2_(char *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *); + integer i__; + doublecomplex alpha; + extern logical lsame_(char *, char *); + extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + integer i1; + logical upper; + extern /* Subroutine */ int zhpmv_(char *, integer *, doublecomplex *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *), zaxpy_(integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *); + integer ii; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zlarfg_( + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *); + integer i1i1; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + +/* Test the input parameters */ + + /* Parameter adjustments */ + --tau; + --e; + --d__; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHPTRD", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n <= 0) { + return 0; + } + + if (upper) { + +/* Reduce the upper triangle of A. */ +/* I1 is the index in AP of A(1,I+1). */ + + i1 = *n * (*n - 1) / 2 + 1; + i__1 = i1 + *n - 1; + i__2 = i1 + *n - 1; + d__1 = ap[i__2].r; + ap[i__1].r = d__1, ap[i__1].i = 0.; + for (i__ = *n - 1; i__ >= 1; --i__) { + +/* Generate elementary reflector H(i) = I - tau * v * v**H */ +/* to annihilate A(1:i-1,i+1) */ + + i__1 = i1 + i__ - 1; + alpha.r = ap[i__1].r, alpha.i = ap[i__1].i; + zlarfg_(&i__, &alpha, &ap[i1], &c__1, &taui); + i__1 = i__; + e[i__1] = alpha.r; + + if (taui.r != 0. || taui.i != 0.) { + +/* Apply H(i) from both sides to A(1:i,1:i) */ + + i__1 = i1 + i__ - 1; + ap[i__1].r = 1., ap[i__1].i = 0.; + +/* Compute y := tau * A * v storing y in TAU(1:i) */ + + zhpmv_(uplo, &i__, &taui, &ap[1], &ap[i1], &c__1, &c_b2, &tau[ + 1], &c__1); + +/* Compute w := y - 1/2 * tau * (y**H *v) * v */ + + z__3.r = -.5, z__3.i = 0.; + z__2.r = z__3.r * taui.r - z__3.i * taui.i, z__2.i = z__3.r * + taui.i + z__3.i * taui.r; + zdotc_(&z__4, &i__, &tau[1], &c__1, &ap[i1], &c__1); + z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * + z__4.i + z__2.i * z__4.r; + alpha.r = z__1.r, alpha.i = z__1.i; + zaxpy_(&i__, &alpha, &ap[i1], &c__1, &tau[1], &c__1); + +/* Apply the transformation as a rank-2 update: */ +/* A := A - v * w**H - w * v**H */ + + z__1.r = -1., z__1.i = 0.; + zhpr2_(uplo, &i__, &z__1, &ap[i1], &c__1, &tau[1], &c__1, &ap[ + 1]); + + } + i__1 = i1 + i__ - 1; + i__2 = i__; + ap[i__1].r = e[i__2], ap[i__1].i = 0.; + i__1 = i__ + 1; + i__2 = i1 + i__; + d__[i__1] = ap[i__2].r; + i__1 = i__; + tau[i__1].r = taui.r, tau[i__1].i = taui.i; + i1 -= i__; +/* L10: */ + } + d__[1] = ap[1].r; + } else { + +/* Reduce the lower triangle of A. II is the index in AP of */ +/* A(i,i) and I1I1 is the index of A(i+1,i+1). */ + + ii = 1; + d__1 = ap[1].r; + ap[1].r = d__1, ap[1].i = 0.; + i__1 = *n - 1; + for (i__ = 1; i__ <= i__1; ++i__) { + i1i1 = ii + *n - i__ + 1; + +/* Generate elementary reflector H(i) = I - tau * v * v**H */ +/* to annihilate A(i+2:n,i) */ + + i__2 = ii + 1; + alpha.r = ap[i__2].r, alpha.i = ap[i__2].i; + i__2 = *n - i__; + zlarfg_(&i__2, &alpha, &ap[ii + 2], &c__1, &taui); + i__2 = i__; + e[i__2] = alpha.r; + + if (taui.r != 0. || taui.i != 0.) { + +/* Apply H(i) from both sides to A(i+1:n,i+1:n) */ + + i__2 = ii + 1; + ap[i__2].r = 1., ap[i__2].i = 0.; + +/* Compute y := tau * A * v storing y in TAU(i:n-1) */ + + i__2 = *n - i__; + zhpmv_(uplo, &i__2, &taui, &ap[i1i1], &ap[ii + 1], &c__1, & + c_b2, &tau[i__], &c__1); + +/* Compute w := y - 1/2 * tau * (y**H *v) * v */ + + z__3.r = -.5, z__3.i = 0.; + z__2.r = z__3.r * taui.r - z__3.i * taui.i, z__2.i = z__3.r * + taui.i + z__3.i * taui.r; + i__2 = *n - i__; + zdotc_(&z__4, &i__2, &tau[i__], &c__1, &ap[ii + 1], &c__1); + z__1.r = z__2.r * z__4.r - z__2.i * z__4.i, z__1.i = z__2.r * + z__4.i + z__2.i * z__4.r; + alpha.r = z__1.r, alpha.i = z__1.i; + i__2 = *n - i__; + zaxpy_(&i__2, &alpha, &ap[ii + 1], &c__1, &tau[i__], &c__1); + +/* Apply the transformation as a rank-2 update: */ +/* A := A - v * w**H - w * v**H */ + + i__2 = *n - i__; + z__1.r = -1., z__1.i = 0.; + zhpr2_(uplo, &i__2, &z__1, &ap[ii + 1], &c__1, &tau[i__], & + c__1, &ap[i1i1]); + + } + i__2 = ii + 1; + i__3 = i__; + ap[i__2].r = e[i__3], ap[i__2].i = 0.; + i__2 = i__; + i__3 = ii; + d__[i__2] = ap[i__3].r; + i__2 = i__; + tau[i__2].r = taui.r, tau[i__2].i = taui.i; + ii = i1i1; +/* L20: */ + } + i__1 = *n; + i__2 = ii; + d__[i__1] = ap[i__2].r; + } + + return 0; + +/* End of ZHPTRD */ + +} /* zhptrd_ */ + diff --git a/lapack-netlib/SRC/zhptrf.c b/lapack-netlib/SRC/zhptrf.c new file mode 100644 index 000000000..c60516bde --- /dev/null +++ b/lapack-netlib/SRC/zhptrf.c @@ -0,0 +1,1241 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHPTRF */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHPTRF + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHPTRF( UPLO, N, AP, IPIV, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 AP( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHPTRF computes the factorization of a complex Hermitian packed */ +/* > matrix A using the Bunch-Kaufman diagonal pivoting method: */ +/* > */ +/* > A = U*D*U**H or A = L*D*L**H */ +/* > */ +/* > where U (or L) is a product of permutation and unit upper (lower) */ +/* > triangular matrices, and D is Hermitian and block diagonal with */ +/* > 1-by-1 and 2-by-2 diagonal blocks. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > On entry, the upper or lower triangle of the Hermitian matrix */ +/* > A, packed columnwise in a linear array. The j-th column of A */ +/* > is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */ +/* > */ +/* > On exit, the block diagonal matrix D and the multipliers used */ +/* > to obtain the factor U or L, stored as a packed triangular */ +/* > matrix overwriting A (see below for further details). */ +/* > \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] 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 complex16OTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > If UPLO = 'U', then A = U*D*U**H, 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**H, 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: */ +/* ================== */ +/* > */ +/* > J. Lewis, Boeing Computer Services Company */ + +/* ===================================================================== */ +/* Subroutine */ int zhptrf_(char *uplo, integer *n, doublecomplex *ap, + integer *ipiv, integer *info) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4, i__5, i__6; + doublereal d__1, d__2, d__3, d__4; + doublecomplex z__1, z__2, z__3, z__4, z__5, z__6; + + /* Local variables */ + integer imax, jmax; + extern /* Subroutine */ int zhpr_(char *, integer *, doublereal *, + doublecomplex *, integer *, doublecomplex *); + doublereal d__; + integer i__, j, k; + doublecomplex t; + doublereal alpha; + extern logical lsame_(char *, char *); + integer kstep; + logical upper; + doublereal r1; + extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *); + extern doublereal dlapy2_(doublereal *, doublereal *); + doublereal d11; + doublecomplex d12; + doublereal d22; + doublecomplex d21; + integer kc, kk, kp; + doublereal absakk; + doublecomplex wk; + integer kx; + doublereal tt; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zdscal_( + integer *, doublereal *, doublecomplex *, integer *); + doublereal colmax; + extern integer izamax_(integer *, doublecomplex *, integer *); + doublereal rowmax; + integer knc, kpc, npp; + doublecomplex wkm1, wkp1; + + +/* -- 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 */ + --ipiv; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHPTRF", &i__1, (ftnlen)6); + return 0; + } + +/* Initialize ALPHA for use in choosing pivot block size. */ + + alpha = (sqrt(17.) + 1.) / 8.; + + if (upper) { + +/* Factorize A as U*D*U**H using the upper triangle of A */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* 1 or 2 */ + + k = *n; + kc = (*n - 1) * *n / 2 + 1; +L10: + knc = kc; + +/* If K < 1, exit from loop */ + + if (k < 1) { + goto L110; + } + kstep = 1; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = kc + k - 1; + absakk = (d__1 = ap[i__1].r, abs(d__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value */ + + if (k > 1) { + i__1 = k - 1; + imax = izamax_(&i__1, &ap[kc], &c__1); + i__1 = kc + imax - 1; + colmax = (d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[kc + + imax - 1]), abs(d__2)); + } else { + colmax = 0.; + } + + if (f2cmax(absakk,colmax) == 0.) { + +/* Column K is zero: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = kc + k - 1; + i__2 = kc + k - 1; + d__1 = ap[i__2].r; + ap[i__1].r = d__1, ap[i__1].i = 0.; + } else { + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value */ + + rowmax = 0.; + jmax = imax; + kx = imax * (imax + 1) / 2 + imax; + i__1 = k; + for (j = imax + 1; j <= i__1; ++j) { + i__2 = kx; + if ((d__1 = ap[i__2].r, abs(d__1)) + (d__2 = d_imag(&ap[ + kx]), abs(d__2)) > rowmax) { + i__2 = kx; + rowmax = (d__1 = ap[i__2].r, abs(d__1)) + (d__2 = + d_imag(&ap[kx]), abs(d__2)); + jmax = j; + } + kx += j; +/* L20: */ + } + kpc = (imax - 1) * imax / 2 + 1; + if (imax > 1) { + i__1 = imax - 1; + jmax = izamax_(&i__1, &ap[kpc], &c__1); +/* Computing MAX */ + i__1 = kpc + jmax - 1; + d__3 = rowmax, d__4 = (d__1 = ap[i__1].r, abs(d__1)) + ( + d__2 = d_imag(&ap[kpc + jmax - 1]), abs(d__2)); + rowmax = f2cmax(d__3,d__4); + } + + if (absakk >= alpha * colmax * (colmax / rowmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else /* if(complicated condition) */ { + i__1 = kpc + imax - 1; + if ((d__1 = ap[i__1].r, abs(d__1)) >= alpha * rowmax) { + +/* interchange rows and columns K and IMAX, use 1-by-1 */ +/* pivot block */ + + kp = imax; + } else { + +/* interchange rows and columns K-1 and IMAX, use 2-by-2 */ +/* pivot block */ + + kp = imax; + kstep = 2; + } + } + } + + kk = k - kstep + 1; + if (kstep == 2) { + knc = knc - k + 1; + } + if (kp != kk) { + +/* Interchange rows and columns KK and KP in the leading */ +/* submatrix A(1:k,1:k) */ + + i__1 = kp - 1; + zswap_(&i__1, &ap[knc], &c__1, &ap[kpc], &c__1); + kx = kpc + kp - 1; + i__1 = kk - 1; + for (j = kp + 1; j <= i__1; ++j) { + kx = kx + j - 1; + d_cnjg(&z__1, &ap[knc + j - 1]); + t.r = z__1.r, t.i = z__1.i; + i__2 = knc + j - 1; + d_cnjg(&z__1, &ap[kx]); + ap[i__2].r = z__1.r, ap[i__2].i = z__1.i; + i__2 = kx; + ap[i__2].r = t.r, ap[i__2].i = t.i; +/* L30: */ + } + i__1 = kx + kk - 1; + d_cnjg(&z__1, &ap[kx + kk - 1]); + ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; + i__1 = knc + kk - 1; + r1 = ap[i__1].r; + i__1 = knc + kk - 1; + i__2 = kpc + kp - 1; + d__1 = ap[i__2].r; + ap[i__1].r = d__1, ap[i__1].i = 0.; + i__1 = kpc + kp - 1; + ap[i__1].r = r1, ap[i__1].i = 0.; + if (kstep == 2) { + i__1 = kc + k - 1; + i__2 = kc + k - 1; + d__1 = ap[i__2].r; + ap[i__1].r = d__1, ap[i__1].i = 0.; + i__1 = kc + k - 2; + t.r = ap[i__1].r, t.i = ap[i__1].i; + i__1 = kc + k - 2; + i__2 = kc + kp - 1; + ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i; + i__1 = kc + kp - 1; + ap[i__1].r = t.r, ap[i__1].i = t.i; + } + } else { + i__1 = kc + k - 1; + i__2 = kc + k - 1; + d__1 = ap[i__2].r; + ap[i__1].r = d__1, ap[i__1].i = 0.; + if (kstep == 2) { + i__1 = kc - 1; + i__2 = kc - 1; + d__1 = ap[i__2].r; + ap[i__1].r = d__1, ap[i__1].i = 0.; + } + } + +/* Update the leading submatrix */ + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k now holds */ + +/* W(k) = U(k)*D(k) */ + +/* where U(k) is the k-th column of U */ + +/* Perform a rank-1 update of A(1:k-1,1:k-1) as */ + +/* A := A - U(k)*D(k)*U(k)**H = A - W(k)*1/D(k)*W(k)**H */ + + i__1 = kc + k - 1; + r1 = 1. / ap[i__1].r; + i__1 = k - 1; + d__1 = -r1; + zhpr_(uplo, &i__1, &d__1, &ap[kc], &c__1, &ap[1]); + +/* Store U(k) in column k */ + + i__1 = k - 1; + zdscal_(&i__1, &r1, &ap[kc], &c__1); + } else { + +/* 2-by-2 pivot block D(k): columns k and k-1 now hold */ + +/* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k) */ + +/* where U(k) and U(k-1) are the k-th and (k-1)-th columns */ +/* of U */ + +/* Perform a rank-2 update of A(1:k-2,1:k-2) as */ + +/* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )**H */ +/* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )**H */ + + if (k > 2) { + + i__1 = k - 1 + (k - 1) * k / 2; + d__1 = ap[i__1].r; + d__2 = d_imag(&ap[k - 1 + (k - 1) * k / 2]); + d__ = dlapy2_(&d__1, &d__2); + i__1 = k - 1 + (k - 2) * (k - 1) / 2; + d22 = ap[i__1].r / d__; + i__1 = k + (k - 1) * k / 2; + d11 = ap[i__1].r / d__; + tt = 1. / (d11 * d22 - 1.); + i__1 = k - 1 + (k - 1) * k / 2; + z__1.r = ap[i__1].r / d__, z__1.i = ap[i__1].i / d__; + d12.r = z__1.r, d12.i = z__1.i; + d__ = tt / d__; + + for (j = k - 2; j >= 1; --j) { + i__1 = j + (k - 2) * (k - 1) / 2; + z__3.r = d11 * ap[i__1].r, z__3.i = d11 * ap[i__1].i; + d_cnjg(&z__5, &d12); + i__2 = j + (k - 1) * k / 2; + z__4.r = z__5.r * ap[i__2].r - z__5.i * ap[i__2].i, + z__4.i = z__5.r * ap[i__2].i + z__5.i * ap[ + i__2].r; + z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i; + z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i; + wkm1.r = z__1.r, wkm1.i = z__1.i; + i__1 = j + (k - 1) * k / 2; + z__3.r = d22 * ap[i__1].r, z__3.i = d22 * ap[i__1].i; + i__2 = j + (k - 2) * (k - 1) / 2; + z__4.r = d12.r * ap[i__2].r - d12.i * ap[i__2].i, + z__4.i = d12.r * ap[i__2].i + d12.i * ap[i__2] + .r; + z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i; + z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i; + wk.r = z__1.r, wk.i = z__1.i; + for (i__ = j; i__ >= 1; --i__) { + i__1 = i__ + (j - 1) * j / 2; + i__2 = i__ + (j - 1) * j / 2; + i__3 = i__ + (k - 1) * k / 2; + d_cnjg(&z__4, &wk); + z__3.r = ap[i__3].r * z__4.r - ap[i__3].i * + z__4.i, z__3.i = ap[i__3].r * z__4.i + ap[ + i__3].i * z__4.r; + z__2.r = ap[i__2].r - z__3.r, z__2.i = ap[i__2].i + - z__3.i; + i__4 = i__ + (k - 2) * (k - 1) / 2; + d_cnjg(&z__6, &wkm1); + z__5.r = ap[i__4].r * z__6.r - ap[i__4].i * + z__6.i, z__5.i = ap[i__4].r * z__6.i + ap[ + i__4].i * z__6.r; + z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - + z__5.i; + ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; +/* L40: */ + } + i__1 = j + (k - 1) * k / 2; + ap[i__1].r = wk.r, ap[i__1].i = wk.i; + i__1 = j + (k - 2) * (k - 1) / 2; + ap[i__1].r = wkm1.r, ap[i__1].i = wkm1.i; + i__1 = j + (j - 1) * j / 2; + i__2 = j + (j - 1) * j / 2; + d__1 = ap[i__2].r; + z__1.r = d__1, z__1.i = 0.; + ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; +/* L50: */ + } + + } + + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k - 1] = -kp; + } + +/* Decrease K and return to the start of the main loop */ + + k -= kstep; + kc = knc - k; + goto L10; + + } else { + +/* Factorize A as L*D*L**H using the lower triangle of A */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2 */ + + k = 1; + kc = 1; + npp = *n * (*n + 1) / 2; +L60: + knc = kc; + +/* If K > N, exit from loop */ + + if (k > *n) { + goto L110; + } + kstep = 1; + +/* Determine rows and columns to be interchanged and whether */ +/* a 1-by-1 or 2-by-2 pivot block will be used */ + + i__1 = kc; + absakk = (d__1 = ap[i__1].r, abs(d__1)); + +/* IMAX is the row-index of the largest off-diagonal element in */ +/* column K, and COLMAX is its absolute value */ + + if (k < *n) { + i__1 = *n - k; + imax = k + izamax_(&i__1, &ap[kc + 1], &c__1); + i__1 = kc + imax - k; + colmax = (d__1 = ap[i__1].r, abs(d__1)) + (d__2 = d_imag(&ap[kc + + imax - k]), abs(d__2)); + } else { + colmax = 0.; + } + + if (f2cmax(absakk,colmax) == 0.) { + +/* Column K is zero: set INFO and continue */ + + if (*info == 0) { + *info = k; + } + kp = k; + i__1 = kc; + i__2 = kc; + d__1 = ap[i__2].r; + ap[i__1].r = d__1, ap[i__1].i = 0.; + } else { + if (absakk >= alpha * colmax) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else { + +/* JMAX is the column-index of the largest off-diagonal */ +/* element in row IMAX, and ROWMAX is its absolute value */ + + rowmax = 0.; + kx = kc + imax - k; + i__1 = imax - 1; + for (j = k; j <= i__1; ++j) { + i__2 = kx; + if ((d__1 = ap[i__2].r, abs(d__1)) + (d__2 = d_imag(&ap[ + kx]), abs(d__2)) > rowmax) { + i__2 = kx; + rowmax = (d__1 = ap[i__2].r, abs(d__1)) + (d__2 = + d_imag(&ap[kx]), abs(d__2)); + jmax = j; + } + kx = kx + *n - j; +/* L70: */ + } + kpc = npp - (*n - imax + 1) * (*n - imax + 2) / 2 + 1; + if (imax < *n) { + i__1 = *n - imax; + jmax = imax + izamax_(&i__1, &ap[kpc + 1], &c__1); +/* Computing MAX */ + i__1 = kpc + jmax - imax; + d__3 = rowmax, d__4 = (d__1 = ap[i__1].r, abs(d__1)) + ( + d__2 = d_imag(&ap[kpc + jmax - imax]), abs(d__2)); + rowmax = f2cmax(d__3,d__4); + } + + if (absakk >= alpha * colmax * (colmax / rowmax)) { + +/* no interchange, use 1-by-1 pivot block */ + + kp = k; + } else /* if(complicated condition) */ { + i__1 = kpc; + if ((d__1 = ap[i__1].r, abs(d__1)) >= alpha * rowmax) { + +/* interchange rows and columns K and IMAX, use 1-by-1 */ +/* pivot block */ + + kp = imax; + } else { + +/* interchange rows and columns K+1 and IMAX, use 2-by-2 */ +/* pivot block */ + + kp = imax; + kstep = 2; + } + } + } + + kk = k + kstep - 1; + if (kstep == 2) { + knc = knc + *n - k + 1; + } + if (kp != kk) { + +/* Interchange rows and columns KK and KP in the trailing */ +/* submatrix A(k:n,k:n) */ + + if (kp < *n) { + i__1 = *n - kp; + zswap_(&i__1, &ap[knc + kp - kk + 1], &c__1, &ap[kpc + 1], + &c__1); + } + kx = knc + kp - kk; + i__1 = kp - 1; + for (j = kk + 1; j <= i__1; ++j) { + kx = kx + *n - j + 1; + d_cnjg(&z__1, &ap[knc + j - kk]); + t.r = z__1.r, t.i = z__1.i; + i__2 = knc + j - kk; + d_cnjg(&z__1, &ap[kx]); + ap[i__2].r = z__1.r, ap[i__2].i = z__1.i; + i__2 = kx; + ap[i__2].r = t.r, ap[i__2].i = t.i; +/* L80: */ + } + i__1 = knc + kp - kk; + d_cnjg(&z__1, &ap[knc + kp - kk]); + ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; + i__1 = knc; + r1 = ap[i__1].r; + i__1 = knc; + i__2 = kpc; + d__1 = ap[i__2].r; + ap[i__1].r = d__1, ap[i__1].i = 0.; + i__1 = kpc; + ap[i__1].r = r1, ap[i__1].i = 0.; + if (kstep == 2) { + i__1 = kc; + i__2 = kc; + d__1 = ap[i__2].r; + ap[i__1].r = d__1, ap[i__1].i = 0.; + i__1 = kc + 1; + t.r = ap[i__1].r, t.i = ap[i__1].i; + i__1 = kc + 1; + i__2 = kc + kp - k; + ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i; + i__1 = kc + kp - k; + ap[i__1].r = t.r, ap[i__1].i = t.i; + } + } else { + i__1 = kc; + i__2 = kc; + d__1 = ap[i__2].r; + ap[i__1].r = d__1, ap[i__1].i = 0.; + if (kstep == 2) { + i__1 = knc; + i__2 = knc; + d__1 = ap[i__2].r; + ap[i__1].r = d__1, ap[i__1].i = 0.; + } + } + +/* Update the trailing submatrix */ + + if (kstep == 1) { + +/* 1-by-1 pivot block D(k): column k now holds */ + +/* W(k) = L(k)*D(k) */ + +/* where L(k) is the k-th column of L */ + + if (k < *n) { + +/* Perform a rank-1 update of A(k+1:n,k+1:n) as */ + +/* A := A - L(k)*D(k)*L(k)**H = A - W(k)*(1/D(k))*W(k)**H */ + + i__1 = kc; + r1 = 1. / ap[i__1].r; + i__1 = *n - k; + d__1 = -r1; + zhpr_(uplo, &i__1, &d__1, &ap[kc + 1], &c__1, &ap[kc + *n + - k + 1]); + +/* Store L(k) in column K */ + + i__1 = *n - k; + zdscal_(&i__1, &r1, &ap[kc + 1], &c__1); + } + } else { + +/* 2-by-2 pivot block D(k): columns K and K+1 now hold */ + +/* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k) */ + +/* where L(k) and L(k+1) are the k-th and (k+1)-th columns */ +/* of L */ + + if (k < *n - 1) { + +/* Perform a rank-2 update of A(k+2:n,k+2:n) as */ + +/* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )**H */ +/* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )**H */ + +/* where L(k) and L(k+1) are the k-th and (k+1)-th */ +/* columns of L */ + + i__1 = k + 1 + (k - 1) * ((*n << 1) - k) / 2; + d__1 = ap[i__1].r; + d__2 = d_imag(&ap[k + 1 + (k - 1) * ((*n << 1) - k) / 2]); + d__ = dlapy2_(&d__1, &d__2); + i__1 = k + 1 + k * ((*n << 1) - k - 1) / 2; + d11 = ap[i__1].r / d__; + i__1 = k + (k - 1) * ((*n << 1) - k) / 2; + d22 = ap[i__1].r / d__; + tt = 1. / (d11 * d22 - 1.); + i__1 = k + 1 + (k - 1) * ((*n << 1) - k) / 2; + z__1.r = ap[i__1].r / d__, z__1.i = ap[i__1].i / d__; + d21.r = z__1.r, d21.i = z__1.i; + d__ = tt / d__; + + i__1 = *n; + for (j = k + 2; j <= i__1; ++j) { + i__2 = j + (k - 1) * ((*n << 1) - k) / 2; + z__3.r = d11 * ap[i__2].r, z__3.i = d11 * ap[i__2].i; + i__3 = j + k * ((*n << 1) - k - 1) / 2; + z__4.r = d21.r * ap[i__3].r - d21.i * ap[i__3].i, + z__4.i = d21.r * ap[i__3].i + d21.i * ap[i__3] + .r; + z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i; + z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i; + wk.r = z__1.r, wk.i = z__1.i; + i__2 = j + k * ((*n << 1) - k - 1) / 2; + z__3.r = d22 * ap[i__2].r, z__3.i = d22 * ap[i__2].i; + d_cnjg(&z__5, &d21); + i__3 = j + (k - 1) * ((*n << 1) - k) / 2; + z__4.r = z__5.r * ap[i__3].r - z__5.i * ap[i__3].i, + z__4.i = z__5.r * ap[i__3].i + z__5.i * ap[ + i__3].r; + z__2.r = z__3.r - z__4.r, z__2.i = z__3.i - z__4.i; + z__1.r = d__ * z__2.r, z__1.i = d__ * z__2.i; + wkp1.r = z__1.r, wkp1.i = z__1.i; + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { + i__3 = i__ + (j - 1) * ((*n << 1) - j) / 2; + i__4 = i__ + (j - 1) * ((*n << 1) - j) / 2; + i__5 = i__ + (k - 1) * ((*n << 1) - k) / 2; + d_cnjg(&z__4, &wk); + z__3.r = ap[i__5].r * z__4.r - ap[i__5].i * + z__4.i, z__3.i = ap[i__5].r * z__4.i + ap[ + i__5].i * z__4.r; + z__2.r = ap[i__4].r - z__3.r, z__2.i = ap[i__4].i + - z__3.i; + i__6 = i__ + k * ((*n << 1) - k - 1) / 2; + d_cnjg(&z__6, &wkp1); + z__5.r = ap[i__6].r * z__6.r - ap[i__6].i * + z__6.i, z__5.i = ap[i__6].r * z__6.i + ap[ + i__6].i * z__6.r; + z__1.r = z__2.r - z__5.r, z__1.i = z__2.i - + z__5.i; + ap[i__3].r = z__1.r, ap[i__3].i = z__1.i; +/* L90: */ + } + i__2 = j + (k - 1) * ((*n << 1) - k) / 2; + ap[i__2].r = wk.r, ap[i__2].i = wk.i; + i__2 = j + k * ((*n << 1) - k - 1) / 2; + ap[i__2].r = wkp1.r, ap[i__2].i = wkp1.i; + i__2 = j + (j - 1) * ((*n << 1) - j) / 2; + i__3 = j + (j - 1) * ((*n << 1) - j) / 2; + d__1 = ap[i__3].r; + z__1.r = d__1, z__1.i = 0.; + ap[i__2].r = z__1.r, ap[i__2].i = z__1.i; +/* L100: */ + } + } + } + } + +/* Store details of the interchanges in IPIV */ + + if (kstep == 1) { + ipiv[k] = kp; + } else { + ipiv[k] = -kp; + ipiv[k + 1] = -kp; + } + +/* Increase K and return to the start of the main loop */ + + k += kstep; + kc = knc + *n - k + 2; + goto L60; + + } + +L110: + return 0; + +/* End of ZHPTRF */ + +} /* zhptrf_ */ + diff --git a/lapack-netlib/SRC/zhptri.c b/lapack-netlib/SRC/zhptri.c new file mode 100644 index 000000000..f66108dcf --- /dev/null +++ b/lapack-netlib/SRC/zhptri.c @@ -0,0 +1,936 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHPTRI */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHPTRI + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHPTRI( UPLO, N, AP, IPIV, WORK, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, N */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 AP( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHPTRI computes the inverse of a complex Hermitian indefinite matrix */ +/* > A in packed storage using the factorization A = U*D*U**H or */ +/* > A = L*D*L**H computed by ZHPTRF. */ +/* > \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**H; */ +/* > = 'L': Lower triangular, form is A = L*D*L**H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] AP */ +/* > \verbatim */ +/* > AP is COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > On entry, the block diagonal matrix D and the multipliers */ +/* > used to obtain the factor U or L as computed by ZHPTRF, */ +/* > stored as a packed triangular matrix. */ +/* > */ +/* > On exit, if INFO = 0, the (Hermitian) inverse of the original */ +/* > matrix, stored as a packed triangular matrix. The j-th column */ +/* > of inv(A) is stored in the array AP as follows: */ +/* > if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j; */ +/* > if UPLO = 'L', */ +/* > AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by ZHPTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 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 complex16OTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zhptri_(char *uplo, integer *n, doublecomplex *ap, + integer *ipiv, doublecomplex *work, integer *info) +{ + /* System generated locals */ + integer i__1, i__2, i__3; + doublereal d__1; + doublecomplex z__1, z__2; + + /* Local variables */ + doublecomplex temp, akkp1; + doublereal d__; + integer j, k; + doublereal t; + extern logical lsame_(char *, char *); + extern /* Double Complex */ VOID zdotc_(doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *); + integer kstep; + logical upper; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zhpmv_(char *, integer *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, integer *), zswap_( + integer *, doublecomplex *, integer *, doublecomplex *, integer *) + ; + doublereal ak; + integer kc, kp, kx; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + integer kcnext, kpc, npp; + 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 */ + --work; + --ipiv; + --ap; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHPTRI", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible */ + + if (*n == 0) { + return 0; + } + +/* Check that the diagonal matrix D is nonsingular. */ + + if (upper) { + +/* Upper triangular storage: examine D from bottom to top */ + + kp = *n * (*n + 1) / 2; + for (*info = *n; *info >= 1; --(*info)) { + i__1 = kp; + if (ipiv[*info] > 0 && (ap[i__1].r == 0. && ap[i__1].i == 0.)) { + return 0; + } + kp -= *info; +/* L10: */ + } + } else { + +/* Lower triangular storage: examine D from top to bottom. */ + + kp = 1; + i__1 = *n; + for (*info = 1; *info <= i__1; ++(*info)) { + i__2 = kp; + if (ipiv[*info] > 0 && (ap[i__2].r == 0. && ap[i__2].i == 0.)) { + return 0; + } + kp = kp + *n - *info + 1; +/* L20: */ + } + } + *info = 0; + + if (upper) { + +/* Compute inv(A) from the factorization A = U*D*U**H. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = 1; + kc = 1; +L30: + +/* If K > N, exit from loop. */ + + if (k > *n) { + goto L50; + } + + kcnext = kc + k; + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Invert the diagonal block. */ + + i__1 = kc + k - 1; + i__2 = kc + k - 1; + d__1 = 1. / ap[i__2].r; + ap[i__1].r = d__1, ap[i__1].i = 0.; + +/* Compute column K of the inverse. */ + + if (k > 1) { + i__1 = k - 1; + zcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1); + i__1 = k - 1; + z__1.r = -1., z__1.i = 0.; + zhpmv_(uplo, &i__1, &z__1, &ap[1], &work[1], &c__1, &c_b2, & + ap[kc], &c__1); + i__1 = kc + k - 1; + i__2 = kc + k - 1; + i__3 = k - 1; + zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kc], &c__1); + d__1 = z__2.r; + z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__2].i; + ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; + } + kstep = 1; + } else { + +/* 2 x 2 diagonal block */ + +/* Invert the diagonal block. */ + + t = z_abs(&ap[kcnext + k - 1]); + i__1 = kc + k - 1; + ak = ap[i__1].r / t; + i__1 = kcnext + k; + akp1 = ap[i__1].r / t; + i__1 = kcnext + k - 1; + z__1.r = ap[i__1].r / t, z__1.i = ap[i__1].i / t; + akkp1.r = z__1.r, akkp1.i = z__1.i; + d__ = t * (ak * akp1 - 1.); + i__1 = kc + k - 1; + d__1 = akp1 / d__; + ap[i__1].r = d__1, ap[i__1].i = 0.; + i__1 = kcnext + k; + d__1 = ak / d__; + ap[i__1].r = d__1, ap[i__1].i = 0.; + i__1 = kcnext + k - 1; + z__2.r = -akkp1.r, z__2.i = -akkp1.i; + z__1.r = z__2.r / d__, z__1.i = z__2.i / d__; + ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; + +/* Compute columns K and K+1 of the inverse. */ + + if (k > 1) { + i__1 = k - 1; + zcopy_(&i__1, &ap[kc], &c__1, &work[1], &c__1); + i__1 = k - 1; + z__1.r = -1., z__1.i = 0.; + zhpmv_(uplo, &i__1, &z__1, &ap[1], &work[1], &c__1, &c_b2, & + ap[kc], &c__1); + i__1 = kc + k - 1; + i__2 = kc + k - 1; + i__3 = k - 1; + zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kc], &c__1); + d__1 = z__2.r; + z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__2].i; + ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; + i__1 = kcnext + k - 1; + i__2 = kcnext + k - 1; + i__3 = k - 1; + zdotc_(&z__2, &i__3, &ap[kc], &c__1, &ap[kcnext], &c__1); + z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i; + ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; + i__1 = k - 1; + zcopy_(&i__1, &ap[kcnext], &c__1, &work[1], &c__1); + i__1 = k - 1; + z__1.r = -1., z__1.i = 0.; + zhpmv_(uplo, &i__1, &z__1, &ap[1], &work[1], &c__1, &c_b2, & + ap[kcnext], &c__1); + i__1 = kcnext + k; + i__2 = kcnext + k; + i__3 = k - 1; + zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kcnext], &c__1); + d__1 = z__2.r; + z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__2].i; + ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; + } + kstep = 2; + kcnext = kcnext + k + 1; + } + + kp = (i__1 = ipiv[k], abs(i__1)); + if (kp != k) { + +/* Interchange rows and columns K and KP in the leading */ +/* submatrix A(1:k+1,1:k+1) */ + + kpc = (kp - 1) * kp / 2 + 1; + i__1 = kp - 1; + zswap_(&i__1, &ap[kc], &c__1, &ap[kpc], &c__1); + kx = kpc + kp - 1; + i__1 = k - 1; + for (j = kp + 1; j <= i__1; ++j) { + kx = kx + j - 1; + d_cnjg(&z__1, &ap[kc + j - 1]); + temp.r = z__1.r, temp.i = z__1.i; + i__2 = kc + j - 1; + d_cnjg(&z__1, &ap[kx]); + ap[i__2].r = z__1.r, ap[i__2].i = z__1.i; + i__2 = kx; + ap[i__2].r = temp.r, ap[i__2].i = temp.i; +/* L40: */ + } + i__1 = kc + kp - 1; + d_cnjg(&z__1, &ap[kc + kp - 1]); + ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; + i__1 = kc + k - 1; + temp.r = ap[i__1].r, temp.i = ap[i__1].i; + i__1 = kc + k - 1; + i__2 = kpc + kp - 1; + ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i; + i__1 = kpc + kp - 1; + ap[i__1].r = temp.r, ap[i__1].i = temp.i; + if (kstep == 2) { + i__1 = kc + k + k - 1; + temp.r = ap[i__1].r, temp.i = ap[i__1].i; + i__1 = kc + k + k - 1; + i__2 = kc + k + kp - 1; + ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i; + i__1 = kc + k + kp - 1; + ap[i__1].r = temp.r, ap[i__1].i = temp.i; + } + } + + k += kstep; + kc = kcnext; + goto L30; +L50: + + ; + } else { + +/* Compute inv(A) from the factorization A = L*D*L**H. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + npp = *n * (*n + 1) / 2; + k = *n; + kc = npp; +L60: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L80; + } + + kcnext = kc - (*n - k + 2); + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Invert the diagonal block. */ + + i__1 = kc; + i__2 = kc; + d__1 = 1. / ap[i__2].r; + ap[i__1].r = d__1, ap[i__1].i = 0.; + +/* Compute column K of the inverse. */ + + if (k < *n) { + i__1 = *n - k; + zcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1); + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zhpmv_(uplo, &i__1, &z__1, &ap[kc + *n - k + 1], &work[1], & + c__1, &c_b2, &ap[kc + 1], &c__1); + i__1 = kc; + i__2 = kc; + i__3 = *n - k; + zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1); + d__1 = z__2.r; + z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__2].i; + ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; + } + kstep = 1; + } else { + +/* 2 x 2 diagonal block */ + +/* Invert the diagonal block. */ + + t = z_abs(&ap[kcnext + 1]); + i__1 = kcnext; + ak = ap[i__1].r / t; + i__1 = kc; + akp1 = ap[i__1].r / t; + i__1 = kcnext + 1; + z__1.r = ap[i__1].r / t, z__1.i = ap[i__1].i / t; + akkp1.r = z__1.r, akkp1.i = z__1.i; + d__ = t * (ak * akp1 - 1.); + i__1 = kcnext; + d__1 = akp1 / d__; + ap[i__1].r = d__1, ap[i__1].i = 0.; + i__1 = kc; + d__1 = ak / d__; + ap[i__1].r = d__1, ap[i__1].i = 0.; + i__1 = kcnext + 1; + z__2.r = -akkp1.r, z__2.i = -akkp1.i; + z__1.r = z__2.r / d__, z__1.i = z__2.i / d__; + ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; + +/* Compute columns K-1 and K of the inverse. */ + + if (k < *n) { + i__1 = *n - k; + zcopy_(&i__1, &ap[kc + 1], &c__1, &work[1], &c__1); + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zhpmv_(uplo, &i__1, &z__1, &ap[kc + (*n - k + 1)], &work[1], & + c__1, &c_b2, &ap[kc + 1], &c__1); + i__1 = kc; + i__2 = kc; + i__3 = *n - k; + zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kc + 1], &c__1); + d__1 = z__2.r; + z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__2].i; + ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; + i__1 = kcnext + 1; + i__2 = kcnext + 1; + i__3 = *n - k; + zdotc_(&z__2, &i__3, &ap[kc + 1], &c__1, &ap[kcnext + 2], & + c__1); + z__1.r = ap[i__2].r - z__2.r, z__1.i = ap[i__2].i - z__2.i; + ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; + i__1 = *n - k; + zcopy_(&i__1, &ap[kcnext + 2], &c__1, &work[1], &c__1); + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zhpmv_(uplo, &i__1, &z__1, &ap[kc + (*n - k + 1)], &work[1], & + c__1, &c_b2, &ap[kcnext + 2], &c__1); + i__1 = kcnext; + i__2 = kcnext; + i__3 = *n - k; + zdotc_(&z__2, &i__3, &work[1], &c__1, &ap[kcnext + 2], &c__1); + d__1 = z__2.r; + z__1.r = ap[i__2].r - d__1, z__1.i = ap[i__2].i; + ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; + } + kstep = 2; + kcnext -= *n - k + 3; + } + + kp = (i__1 = ipiv[k], abs(i__1)); + if (kp != k) { + +/* Interchange rows and columns K and KP in the trailing */ +/* submatrix A(k-1:n,k-1:n) */ + + kpc = npp - (*n - kp + 1) * (*n - kp + 2) / 2 + 1; + if (kp < *n) { + i__1 = *n - kp; + zswap_(&i__1, &ap[kc + kp - k + 1], &c__1, &ap[kpc + 1], & + c__1); + } + kx = kc + kp - k; + i__1 = kp - 1; + for (j = k + 1; j <= i__1; ++j) { + kx = kx + *n - j + 1; + d_cnjg(&z__1, &ap[kc + j - k]); + temp.r = z__1.r, temp.i = z__1.i; + i__2 = kc + j - k; + d_cnjg(&z__1, &ap[kx]); + ap[i__2].r = z__1.r, ap[i__2].i = z__1.i; + i__2 = kx; + ap[i__2].r = temp.r, ap[i__2].i = temp.i; +/* L70: */ + } + i__1 = kc + kp - k; + d_cnjg(&z__1, &ap[kc + kp - k]); + ap[i__1].r = z__1.r, ap[i__1].i = z__1.i; + i__1 = kc; + temp.r = ap[i__1].r, temp.i = ap[i__1].i; + i__1 = kc; + i__2 = kpc; + ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i; + i__1 = kpc; + ap[i__1].r = temp.r, ap[i__1].i = temp.i; + if (kstep == 2) { + i__1 = kc - *n + k - 1; + temp.r = ap[i__1].r, temp.i = ap[i__1].i; + i__1 = kc - *n + k - 1; + i__2 = kc - *n + kp - 1; + ap[i__1].r = ap[i__2].r, ap[i__1].i = ap[i__2].i; + i__1 = kc - *n + kp - 1; + ap[i__1].r = temp.r, ap[i__1].i = temp.i; + } + } + + k -= kstep; + kc = kcnext; + goto L60; +L80: + ; + } + + return 0; + +/* End of ZHPTRI */ + +} /* zhptri_ */ + diff --git a/lapack-netlib/SRC/zhptrs.c b/lapack-netlib/SRC/zhptrs.c new file mode 100644 index 000000000..c3d6f5eff --- /dev/null +++ b/lapack-netlib/SRC/zhptrs.c @@ -0,0 +1,962 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHPTRS */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHPTRS + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO ) */ + +/* CHARACTER UPLO */ +/* INTEGER INFO, LDB, N, NRHS */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 AP( * ), B( LDB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHPTRS solves a system of linear equations A*X = B with a complex */ +/* > Hermitian matrix A stored in packed format using the factorization */ +/* > A = U*D*U**H or A = L*D*L**H computed by ZHPTRF. */ +/* > \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**H; */ +/* > = 'L': Lower triangular, form is A = L*D*L**H. */ +/* > \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 COMPLEX*16 array, dimension (N*(N+1)/2) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by ZHPTRF, stored as a */ +/* > packed triangular matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by ZHPTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] B */ +/* > \verbatim */ +/* > B is COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > On entry, the right hand side matrix B. */ +/* > On exit, the solution matrix X. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zhptrs_(char *uplo, integer *n, integer *nrhs, + doublecomplex *ap, integer *ipiv, doublecomplex *b, integer *ldb, + integer *info) +{ + /* System generated locals */ + integer b_dim1, b_offset, i__1, i__2; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + doublecomplex akm1k; + integer j, k; + doublereal s; + extern logical lsame_(char *, char *); + doublecomplex denom; + extern /* Subroutine */ int zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + logical upper; + extern /* Subroutine */ int zgeru_(integer *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zswap_(integer *, doublecomplex *, + integer *, doublecomplex *, integer *); + doublecomplex ak, bk; + integer kc, kp; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zdscal_( + integer *, doublereal *, doublecomplex *, integer *), zlacgv_( + integer *, doublecomplex *, integer *); + doublecomplex akm1, bkm1; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --ap; + --ipiv; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*nrhs < 0) { + *info = -3; + } else if (*ldb < f2cmax(1,*n)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHPTRS", &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**H. */ + +/* First solve U*D*X = B, overwriting B with X. */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = *n; + kc = *n * (*n + 1) / 2 + 1; +L10: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L30; + } + + kc -= k; + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + zswap_(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; + z__1.r = -1., z__1.i = 0.; + zgeru_(&i__1, nrhs, &z__1, &ap[kc], &c__1, &b[k + b_dim1], ldb, & + b[b_dim1 + 1], ldb); + +/* Multiply by the inverse of the diagonal block. */ + + i__1 = kc + k - 1; + s = 1. / ap[i__1].r; + zdscal_(nrhs, &s, &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) { + zswap_(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; + z__1.r = -1., z__1.i = 0.; + zgeru_(&i__1, nrhs, &z__1, &ap[kc], &c__1, &b[k + b_dim1], ldb, & + b[b_dim1 + 1], ldb); + i__1 = k - 2; + z__1.r = -1., z__1.i = 0.; + zgeru_(&i__1, nrhs, &z__1, &ap[kc - (k - 1)], &c__1, &b[k - 1 + + b_dim1], ldb, &b[b_dim1 + 1], ldb); + +/* Multiply by the inverse of the diagonal block. */ + + i__1 = kc + k - 2; + akm1k.r = ap[i__1].r, akm1k.i = ap[i__1].i; + z_div(&z__1, &ap[kc - 1], &akm1k); + akm1.r = z__1.r, akm1.i = z__1.i; + d_cnjg(&z__2, &akm1k); + z_div(&z__1, &ap[kc + k - 1], &z__2); + ak.r = z__1.r, ak.i = z__1.i; + z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i + + akm1.i * ak.r; + z__1.r = z__2.r - 1., z__1.i = z__2.i + 0.; + denom.r = z__1.r, denom.i = z__1.i; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + z_div(&z__1, &b[k - 1 + j * b_dim1], &akm1k); + bkm1.r = z__1.r, bkm1.i = z__1.i; + d_cnjg(&z__2, &akm1k); + z_div(&z__1, &b[k + j * b_dim1], &z__2); + bk.r = z__1.r, bk.i = z__1.i; + i__2 = k - 1 + j * b_dim1; + z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r * + bkm1.i + ak.i * bkm1.r; + z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i; + z_div(&z__1, &z__2, &denom); + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = k + j * b_dim1; + z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r * + bk.i + akm1.i * bk.r; + z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i; + z_div(&z__1, &z__2, &denom); + b[i__2].r = z__1.r, b[i__2].i = z__1.i; +/* L20: */ + } + kc = kc - k + 1; + k += -2; + } + + goto L10; +L30: + +/* Next solve U**H *X = B, overwriting B with X. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = 1; + kc = 1; +L40: + +/* If K > N, exit from loop. */ + + if (k > *n) { + goto L50; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Multiply by inv(U**H(K)), where U(K) is the transformation */ +/* stored in column K of A. */ + + if (k > 1) { + zlacgv_(nrhs, &b[k + b_dim1], ldb); + i__1 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset] + , ldb, &ap[kc], &c__1, &c_b1, &b[k + b_dim1], ldb); + zlacgv_(nrhs, &b[k + b_dim1], ldb); + } + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + kc += k; + ++k; + } else { + +/* 2 x 2 diagonal block */ + +/* Multiply by inv(U**H(K+1)), where U(K+1) is the transformation */ +/* stored in columns K and K+1 of A. */ + + if (k > 1) { + zlacgv_(nrhs, &b[k + b_dim1], ldb); + i__1 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset] + , ldb, &ap[kc], &c__1, &c_b1, &b[k + b_dim1], ldb); + zlacgv_(nrhs, &b[k + b_dim1], ldb); + + zlacgv_(nrhs, &b[k + 1 + b_dim1], ldb); + i__1 = k - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[b_offset] + , ldb, &ap[kc + k], &c__1, &c_b1, &b[k + 1 + b_dim1], + ldb); + zlacgv_(nrhs, &b[k + 1 + b_dim1], ldb); + } + +/* Interchange rows K and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + kc = kc + (k << 1) + 1; + k += 2; + } + + goto L40; +L50: + + ; + } else { + +/* Solve A*X = B, where A = L*D*L**H. */ + +/* First solve L*D*X = B, overwriting B with X. */ + +/* K is the main loop index, increasing from 1 to N in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = 1; + kc = 1; +L60: + +/* If K > N, exit from loop. */ + + if (k > *n) { + goto L80; + } + + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + zswap_(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; + z__1.r = -1., z__1.i = 0.; + zgeru_(&i__1, nrhs, &z__1, &ap[kc + 1], &c__1, &b[k + b_dim1], + ldb, &b[k + 1 + b_dim1], ldb); + } + +/* Multiply by the inverse of the diagonal block. */ + + i__1 = kc; + s = 1. / ap[i__1].r; + zdscal_(nrhs, &s, &b[k + b_dim1], ldb); + kc = kc + *n - k + 1; + ++k; + } else { + +/* 2 x 2 diagonal block */ + +/* Interchange rows K+1 and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k + 1) { + zswap_(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; + z__1.r = -1., z__1.i = 0.; + zgeru_(&i__1, nrhs, &z__1, &ap[kc + 2], &c__1, &b[k + b_dim1], + ldb, &b[k + 2 + b_dim1], ldb); + i__1 = *n - k - 1; + z__1.r = -1., z__1.i = 0.; + zgeru_(&i__1, nrhs, &z__1, &ap[kc + *n - k + 2], &c__1, &b[k + + 1 + b_dim1], ldb, &b[k + 2 + b_dim1], ldb); + } + +/* Multiply by the inverse of the diagonal block. */ + + i__1 = kc + 1; + akm1k.r = ap[i__1].r, akm1k.i = ap[i__1].i; + d_cnjg(&z__2, &akm1k); + z_div(&z__1, &ap[kc], &z__2); + akm1.r = z__1.r, akm1.i = z__1.i; + z_div(&z__1, &ap[kc + *n - k + 1], &akm1k); + ak.r = z__1.r, ak.i = z__1.i; + z__2.r = akm1.r * ak.r - akm1.i * ak.i, z__2.i = akm1.r * ak.i + + akm1.i * ak.r; + z__1.r = z__2.r - 1., z__1.i = z__2.i + 0.; + denom.r = z__1.r, denom.i = z__1.i; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + d_cnjg(&z__2, &akm1k); + z_div(&z__1, &b[k + j * b_dim1], &z__2); + bkm1.r = z__1.r, bkm1.i = z__1.i; + z_div(&z__1, &b[k + 1 + j * b_dim1], &akm1k); + bk.r = z__1.r, bk.i = z__1.i; + i__2 = k + j * b_dim1; + z__3.r = ak.r * bkm1.r - ak.i * bkm1.i, z__3.i = ak.r * + bkm1.i + ak.i * bkm1.r; + z__2.r = z__3.r - bk.r, z__2.i = z__3.i - bk.i; + z_div(&z__1, &z__2, &denom); + b[i__2].r = z__1.r, b[i__2].i = z__1.i; + i__2 = k + 1 + j * b_dim1; + z__3.r = akm1.r * bk.r - akm1.i * bk.i, z__3.i = akm1.r * + bk.i + akm1.i * bk.r; + z__2.r = z__3.r - bkm1.r, z__2.i = z__3.i - bkm1.i; + z_div(&z__1, &z__2, &denom); + b[i__2].r = z__1.r, b[i__2].i = z__1.i; +/* L70: */ + } + kc = kc + (*n - k << 1) + 1; + k += 2; + } + + goto L60; +L80: + +/* Next solve L**H *X = B, overwriting B with X. */ + +/* K is the main loop index, decreasing from N to 1 in steps of */ +/* 1 or 2, depending on the size of the diagonal blocks. */ + + k = *n; + kc = *n * (*n + 1) / 2 + 1; +L90: + +/* If K < 1, exit from loop. */ + + if (k < 1) { + goto L100; + } + + kc -= *n - k + 1; + if (ipiv[k] > 0) { + +/* 1 x 1 diagonal block */ + +/* Multiply by inv(L**H(K)), where L(K) is the transformation */ +/* stored in column K of A. */ + + if (k < *n) { + zlacgv_(nrhs, &b[k + b_dim1], ldb); + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 + + b_dim1], ldb, &ap[kc + 1], &c__1, &c_b1, &b[k + + b_dim1], ldb); + zlacgv_(nrhs, &b[k + b_dim1], ldb); + } + +/* Interchange rows K and IPIV(K). */ + + kp = ipiv[k]; + if (kp != k) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + --k; + } else { + +/* 2 x 2 diagonal block */ + +/* Multiply by inv(L**H(K-1)), where L(K-1) is the transformation */ +/* stored in columns K-1 and K of A. */ + + if (k < *n) { + zlacgv_(nrhs, &b[k + b_dim1], ldb); + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 + + b_dim1], ldb, &ap[kc + 1], &c__1, &c_b1, &b[k + + b_dim1], ldb); + zlacgv_(nrhs, &b[k + b_dim1], ldb); + + zlacgv_(nrhs, &b[k - 1 + b_dim1], ldb); + i__1 = *n - k; + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &i__1, nrhs, &z__1, &b[k + 1 + + b_dim1], ldb, &ap[kc - (*n - k)], &c__1, &c_b1, &b[k + - 1 + b_dim1], ldb); + zlacgv_(nrhs, &b[k - 1 + b_dim1], ldb); + } + +/* Interchange rows K and -IPIV(K). */ + + kp = -ipiv[k]; + if (kp != k) { + zswap_(nrhs, &b[k + b_dim1], ldb, &b[kp + b_dim1], ldb); + } + kc -= *n - k + 2; + k += -2; + } + + goto L90; +L100: + ; + } + + return 0; + +/* End of ZHPTRS */ + +} /* zhptrs_ */ + diff --git a/lapack-netlib/SRC/zhsein.c b/lapack-netlib/SRC/zhsein.c new file mode 100644 index 000000000..a6dd0faaa --- /dev/null +++ b/lapack-netlib/SRC/zhsein.c @@ -0,0 +1,906 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHSEIN */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHSEIN + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, W, VL, */ +/* LDVL, VR, LDVR, MM, M, WORK, RWORK, IFAILL, */ +/* IFAILR, INFO ) */ + +/* CHARACTER EIGSRC, INITV, SIDE */ +/* INTEGER INFO, LDH, LDVL, LDVR, M, MM, N */ +/* LOGICAL SELECT( * ) */ +/* INTEGER IFAILL( * ), IFAILR( * ) */ +/* DOUBLE PRECISION RWORK( * ) */ +/* COMPLEX*16 H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ), */ +/* $ W( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHSEIN uses inverse iteration to find specified right and/or left */ +/* > eigenvectors of a complex upper Hessenberg matrix H. */ +/* > */ +/* > The right eigenvector x and the left eigenvector y of the matrix H */ +/* > corresponding to an eigenvalue w are defined by: */ +/* > */ +/* > H * x = w * x, y**h * H = w * y**h */ +/* > */ +/* > where y**h denotes the conjugate transpose of the vector y. */ +/* > \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] EIGSRC */ +/* > \verbatim */ +/* > EIGSRC is CHARACTER*1 */ +/* > Specifies the source of eigenvalues supplied in W: */ +/* > = 'Q': the eigenvalues were found using ZHSEQR; thus, if */ +/* > H has zero subdiagonal elements, and so is */ +/* > block-triangular, then the j-th eigenvalue can be */ +/* > assumed to be an eigenvalue of the block containing */ +/* > the j-th row/column. This property allows ZHSEIN to */ +/* > perform inverse iteration on just one diagonal block. */ +/* > = 'N': no assumptions are made on the correspondence */ +/* > between eigenvalues and diagonal blocks. In this */ +/* > case, ZHSEIN must always perform inverse iteration */ +/* > using the whole matrix H. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INITV */ +/* > \verbatim */ +/* > INITV is CHARACTER*1 */ +/* > = 'N': no initial vectors are supplied; */ +/* > = 'U': user-supplied initial vectors are stored in the arrays */ +/* > VL and/or VR. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] SELECT */ +/* > \verbatim */ +/* > SELECT is LOGICAL array, dimension (N) */ +/* > Specifies the eigenvectors to be computed. To select the */ +/* > eigenvector corresponding to the eigenvalue W(j), */ +/* > SELECT(j) must be set to .TRUE.. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix H. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] H */ +/* > \verbatim */ +/* > H is COMPLEX*16 array, dimension (LDH,N) */ +/* > The upper Hessenberg matrix H. */ +/* > If a NaN is detected in H, the routine will return with INFO=-6. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > The leading dimension of the array H. LDH >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] W */ +/* > \verbatim */ +/* > W is COMPLEX*16 array, dimension (N) */ +/* > On entry, the eigenvalues of H. */ +/* > On exit, the real parts of W may have been altered since */ +/* > close eigenvalues are perturbed slightly in searching for */ +/* > independent eigenvectors. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VL */ +/* > \verbatim */ +/* > VL is COMPLEX*16 array, dimension (LDVL,MM) */ +/* > On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must */ +/* > contain starting vectors for the inverse iteration for the */ +/* > left eigenvectors; the starting vector for each eigenvector */ +/* > must be in the same column in which the eigenvector will be */ +/* > stored. */ +/* > On exit, if SIDE = 'L' or 'B', the left eigenvectors */ +/* > specified by SELECT will be stored consecutively in the */ +/* > columns of VL, in the same order as their eigenvalues. */ +/* > If SIDE = 'R', VL is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVL */ +/* > \verbatim */ +/* > LDVL is INTEGER */ +/* > The leading dimension of the array VL. */ +/* > LDVL >= f2cmax(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] VR */ +/* > \verbatim */ +/* > VR is COMPLEX*16 array, dimension (LDVR,MM) */ +/* > On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must */ +/* > contain starting vectors for the inverse iteration for the */ +/* > right eigenvectors; the starting vector for each eigenvector */ +/* > must be in the same column in which the eigenvector will be */ +/* > stored. */ +/* > On exit, if SIDE = 'R' or 'B', the right eigenvectors */ +/* > specified by SELECT will be stored consecutively in the */ +/* > columns of VR, in the same order as their eigenvalues. */ +/* > If SIDE = 'L', VR is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDVR */ +/* > \verbatim */ +/* > LDVR is INTEGER */ +/* > The leading dimension of the array VR. */ +/* > LDVR >= f2cmax(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise. */ +/* > \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 required to */ +/* > store the eigenvectors (= the number of .TRUE. elements in */ +/* > SELECT). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (N*N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (N) */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IFAILL */ +/* > \verbatim */ +/* > IFAILL is INTEGER array, dimension (MM) */ +/* > If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left */ +/* > eigenvector in the i-th column of VL (corresponding to the */ +/* > eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the */ +/* > eigenvector converged satisfactorily. */ +/* > If SIDE = 'R', IFAILL is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IFAILR */ +/* > \verbatim */ +/* > IFAILR is INTEGER array, dimension (MM) */ +/* > If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right */ +/* > eigenvector in the i-th column of VR (corresponding to the */ +/* > eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the */ +/* > eigenvector converged satisfactorily. */ +/* > If SIDE = 'L', IFAILR is not referenced. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value */ +/* > > 0: if INFO = i, i is the number of eigenvectors which */ +/* > failed to converge; see IFAILL and IFAILR for further */ +/* > details. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > 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 zhsein_(char *side, char *eigsrc, char *initv, logical * + select, integer *n, doublecomplex *h__, integer *ldh, doublecomplex * + w, doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr, + integer *mm, integer *m, doublecomplex *work, doublereal *rwork, + integer *ifaill, integer *ifailr, integer *info) +{ + /* System generated locals */ + integer h_dim1, h_offset, vl_dim1, vl_offset, vr_dim1, vr_offset, i__1, + i__2, i__3; + doublereal d__1, d__2; + doublecomplex z__1, z__2; + + /* Local variables */ + doublereal unfl; + integer i__, k; + extern logical lsame_(char *, char *); + integer iinfo; + logical leftv, bothv; + doublereal hnorm; + integer kl; + extern doublereal dlamch_(char *); + integer kr, ks; + doublecomplex wk; + extern logical disnan_(doublereal *); + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen), zlaein_( + logical *, logical *, integer *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, doublecomplex *, integer *, + doublereal *, doublereal *, doublereal *, integer *); + extern doublereal zlanhs_(char *, integer *, doublecomplex *, integer *, + doublereal *); + logical noinit; + integer ldwork; + logical rightv, fromqr; + doublereal smlnum; + integer kln; + doublereal ulp, eps3; + + +/* -- 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; + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + --w; + vl_dim1 = *ldvl; + vl_offset = 1 + vl_dim1 * 1; + vl -= vl_offset; + vr_dim1 = *ldvr; + vr_offset = 1 + vr_dim1 * 1; + vr -= vr_offset; + --work; + --rwork; + --ifaill; + --ifailr; + + /* Function Body */ + bothv = lsame_(side, "B"); + rightv = lsame_(side, "R") || bothv; + leftv = lsame_(side, "L") || bothv; + + fromqr = lsame_(eigsrc, "Q"); + + noinit = lsame_(initv, "N"); + +/* Set M to the number of columns required to store the selected */ +/* eigenvectors. */ + + *m = 0; + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (select[k]) { + ++(*m); + } +/* L10: */ + } + + *info = 0; + if (! rightv && ! leftv) { + *info = -1; + } else if (! fromqr && ! lsame_(eigsrc, "N")) { + *info = -2; + } else if (! noinit && ! lsame_(initv, "U")) { + *info = -3; + } else if (*n < 0) { + *info = -5; + } else if (*ldh < f2cmax(1,*n)) { + *info = -7; + } else if (*ldvl < 1 || leftv && *ldvl < *n) { + *info = -10; + } else if (*ldvr < 1 || rightv && *ldvr < *n) { + *info = -12; + } else if (*mm < *m) { + *info = -13; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZHSEIN", &i__1, (ftnlen)6); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0) { + return 0; + } + +/* Set machine-dependent constants. */ + + unfl = dlamch_("Safe minimum"); + ulp = dlamch_("Precision"); + smlnum = unfl * (*n / ulp); + + ldwork = *n; + + kl = 1; + kln = 0; + if (fromqr) { + kr = 0; + } else { + kr = *n; + } + ks = 1; + + i__1 = *n; + for (k = 1; k <= i__1; ++k) { + if (select[k]) { + +/* Compute eigenvector(s) corresponding to W(K). */ + + if (fromqr) { + +/* If affiliation of eigenvalues is known, check whether */ +/* the matrix splits. */ + +/* Determine KL and KR such that 1 <= KL <= K <= KR <= N */ +/* and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or */ +/* KR = N). */ + +/* Then inverse iteration can be performed with the */ +/* submatrix H(KL:N,KL:N) for a left eigenvector, and with */ +/* the submatrix H(1:KR,1:KR) for a right eigenvector. */ + + i__2 = kl + 1; + for (i__ = k; i__ >= i__2; --i__) { + i__3 = i__ + (i__ - 1) * h_dim1; + if (h__[i__3].r == 0. && h__[i__3].i == 0.) { + goto L30; + } +/* L20: */ + } +L30: + kl = i__; + if (k > kr) { + i__2 = *n - 1; + for (i__ = k; i__ <= i__2; ++i__) { + i__3 = i__ + 1 + i__ * h_dim1; + if (h__[i__3].r == 0. && h__[i__3].i == 0.) { + goto L50; + } +/* L40: */ + } +L50: + kr = i__; + } + } + + if (kl != kln) { + kln = kl; + +/* Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it */ +/* has not ben computed before. */ + + i__2 = kr - kl + 1; + hnorm = zlanhs_("I", &i__2, &h__[kl + kl * h_dim1], ldh, & + rwork[1]); + if (disnan_(&hnorm)) { + *info = -6; + return 0; + } else if (hnorm > 0.) { + eps3 = hnorm * ulp; + } else { + eps3 = smlnum; + } + } + +/* Perturb eigenvalue if it is close to any previous */ +/* selected eigenvalues affiliated to the submatrix */ +/* H(KL:KR,KL:KR). Close roots are modified by EPS3. */ + + i__2 = k; + wk.r = w[i__2].r, wk.i = w[i__2].i; +L60: + i__2 = kl; + for (i__ = k - 1; i__ >= i__2; --i__) { + i__3 = i__; + z__2.r = w[i__3].r - wk.r, z__2.i = w[i__3].i - wk.i; + z__1.r = z__2.r, z__1.i = z__2.i; + if (select[i__] && (d__1 = z__1.r, abs(d__1)) + (d__2 = + d_imag(&z__1), abs(d__2)) < eps3) { + z__1.r = wk.r + eps3, z__1.i = wk.i; + wk.r = z__1.r, wk.i = z__1.i; + goto L60; + } +/* L70: */ + } + i__2 = k; + w[i__2].r = wk.r, w[i__2].i = wk.i; + + if (leftv) { + +/* Compute left eigenvector. */ + + i__2 = *n - kl + 1; + zlaein_(&c_false, &noinit, &i__2, &h__[kl + kl * h_dim1], ldh, + &wk, &vl[kl + ks * vl_dim1], &work[1], &ldwork, & + rwork[1], &eps3, &smlnum, &iinfo); + if (iinfo > 0) { + ++(*info); + ifaill[ks] = k; + } else { + ifaill[ks] = 0; + } + i__2 = kl - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + ks * vl_dim1; + vl[i__3].r = 0., vl[i__3].i = 0.; +/* L80: */ + } + } + if (rightv) { + +/* Compute right eigenvector. */ + + zlaein_(&c_true, &noinit, &kr, &h__[h_offset], ldh, &wk, &vr[ + ks * vr_dim1 + 1], &work[1], &ldwork, &rwork[1], & + eps3, &smlnum, &iinfo); + if (iinfo > 0) { + ++(*info); + ifailr[ks] = k; + } else { + ifailr[ks] = 0; + } + i__2 = *n; + for (i__ = kr + 1; i__ <= i__2; ++i__) { + i__3 = i__ + ks * vr_dim1; + vr[i__3].r = 0., vr[i__3].i = 0.; +/* L90: */ + } + } + ++ks; + } +/* L100: */ + } + + return 0; + +/* End of ZHSEIN */ + +} /* zhsein_ */ + diff --git a/lapack-netlib/SRC/zhseqr.c b/lapack-netlib/SRC/zhseqr.c new file mode 100644 index 000000000..baa51988f --- /dev/null +++ b/lapack-netlib/SRC/zhseqr.c @@ -0,0 +1,935 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZHSEQR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZHSEQR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, W, Z, LDZ, */ +/* WORK, LWORK, INFO ) */ + +/* INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N */ +/* CHARACTER COMPZ, JOB */ +/* COMPLEX*16 H( LDH, * ), W( * ), WORK( * ), Z( LDZ, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZHSEQR computes the eigenvalues of a Hessenberg matrix H */ +/* > and, optionally, the matrices T and Z from the Schur decomposition */ +/* > H = Z T Z**H, where T is an upper triangular matrix (the */ +/* > Schur form), and Z is the unitary matrix of Schur vectors. */ +/* > */ +/* > Optionally Z may be postmultiplied into an input unitary */ +/* > matrix Q so that this routine can give the Schur factorization */ +/* > of a matrix A which has been reduced to the Hessenberg form H */ +/* > by the unitary matrix Q: A = Q*H*Q**H = (QZ)*T*(QZ)**H. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] JOB */ +/* > \verbatim */ +/* > JOB is CHARACTER*1 */ +/* > = 'E': compute eigenvalues only; */ +/* > = 'S': compute eigenvalues and the Schur form T. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COMPZ */ +/* > \verbatim */ +/* > COMPZ is CHARACTER*1 */ +/* > = 'N': no Schur vectors are computed; */ +/* > = 'I': Z is initialized to the unit matrix and the matrix Z */ +/* > of Schur vectors of H is returned; */ +/* > = 'V': Z must contain an unitary matrix Q on entry, and */ +/* > the product Q*Z is returned. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix H. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ILO */ +/* > \verbatim */ +/* > ILO is INTEGER */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IHI */ +/* > \verbatim */ +/* > IHI is INTEGER */ +/* > */ +/* > It is assumed that H is already upper triangular in rows */ +/* > and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally */ +/* > set by a previous call to ZGEBAL, and then passed to ZGEHRD */ +/* > when the matrix output by ZGEBAL is reduced to Hessenberg */ +/* > form. Otherwise ILO and IHI should be set to 1 and N */ +/* > respectively. If N > 0, then 1 <= ILO <= IHI <= N. */ +/* > If N = 0, then ILO = 1 and IHI = 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] H */ +/* > \verbatim */ +/* > H is COMPLEX*16 array, dimension (LDH,N) */ +/* > On entry, the upper Hessenberg matrix H. */ +/* > On exit, if INFO = 0 and JOB = 'S', H contains the upper */ +/* > triangular matrix T from the Schur decomposition (the */ +/* > Schur form). If INFO = 0 and JOB = 'E', the contents of */ +/* > H are unspecified on exit. (The output value of H when */ +/* > INFO > 0 is given under the description of INFO below.) */ +/* > */ +/* > Unlike earlier versions of ZHSEQR, this subroutine may */ +/* > explicitly H(i,j) = 0 for i > j and j = 1, 2, ... ILO-1 */ +/* > or j = IHI+1, IHI+2, ... N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDH */ +/* > \verbatim */ +/* > LDH is INTEGER */ +/* > The leading dimension of the array H. LDH >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] W */ +/* > \verbatim */ +/* > W is COMPLEX*16 array, dimension (N) */ +/* > The computed eigenvalues. If JOB = 'S', the eigenvalues are */ +/* > stored in the same order as on the diagonal of the Schur */ +/* > form returned in H, with W(i) = H(i,i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Z */ +/* > \verbatim */ +/* > Z is COMPLEX*16 array, dimension (LDZ,N) */ +/* > If COMPZ = 'N', Z is not referenced. */ +/* > If COMPZ = 'I', on entry Z need not be set and on exit, */ +/* > if INFO = 0, Z contains the unitary matrix Z of the Schur */ +/* > vectors of H. If COMPZ = 'V', on entry Z must contain an */ +/* > N-by-N matrix Q, which is assumed to be equal to the unit */ +/* > matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit, */ +/* > if INFO = 0, Z contains Q*Z. */ +/* > Normally Q is the unitary matrix generated by ZUNGHR */ +/* > after the call to ZGEHRD which formed the Hessenberg matrix */ +/* > H. (The output value of Z when INFO > 0 is given under */ +/* > the description of INFO below.) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDZ */ +/* > \verbatim */ +/* > LDZ is INTEGER */ +/* > The leading dimension of the array Z. if COMPZ = 'I' or */ +/* > COMPZ = 'V', then LDZ >= MAX(1,N). Otherwise, LDZ >= 1. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (LWORK) */ +/* > On exit, if INFO = 0, WORK(1) returns an estimate of */ +/* > the optimal value for LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. LWORK >= f2cmax(1,N) */ +/* > is sufficient and delivers very good and sometimes */ +/* > optimal performance. However, LWORK as large as 11*N */ +/* > may be required for optimal performance. A workspace */ +/* > query is recommended to determine the optimal workspace */ +/* > size. */ +/* > */ +/* > If LWORK = -1, then ZHSEQR does a workspace query. */ +/* > In this case, ZHSEQR checks the input parameters and */ +/* > estimates the optimal workspace size for the given */ +/* > values of N, ILO and IHI. The estimate is returned */ +/* > in WORK(1). No error message related to LWORK is */ +/* > issued by XERBLA. Neither H nor Z are accessed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit */ +/* > < 0: if INFO = -i, the i-th argument had an illegal */ +/* > value */ +/* > > 0: if INFO = i, ZHSEQR failed to compute all of */ +/* > the eigenvalues. Elements 1:ilo-1 and i+1:n of W */ +/* > contain those eigenvalues which have been */ +/* > successfully computed. (Failures are rare.) */ +/* > */ +/* > If INFO > 0 and JOB = 'E', then on exit, the */ +/* > remaining unconverged eigenvalues are the eigen- */ +/* > values of the upper Hessenberg matrix rows and */ +/* > columns ILO through INFO of the final, output */ +/* > value of H. */ +/* > */ +/* > If INFO > 0 and JOB = 'S', then on exit */ +/* > */ +/* > (*) (initial value of H)*U = U*(final value of H) */ +/* > */ +/* > where U is a unitary matrix. The final */ +/* > value of H is upper Hessenberg and triangular in */ +/* > rows and columns INFO+1 through IHI. */ +/* > */ +/* > If INFO > 0 and COMPZ = 'V', then on exit */ +/* > */ +/* > (final value of Z) = (initial value of Z)*U */ +/* > */ +/* > where U is the unitary matrix in (*) (regard- */ +/* > less of the value of JOB.) */ +/* > */ +/* > If INFO > 0 and COMPZ = 'I', then on exit */ +/* > (final value of Z) = U */ +/* > where U is the unitary matrix in (*) (regard- */ +/* > less of the value of JOB.) */ +/* > */ +/* > If INFO > 0 and COMPZ = 'N', then Z is not */ +/* > accessed. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERcomputational */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Karen Braman and Ralph Byers, Department of Mathematics, */ +/* > University of Kansas, USA */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Default values supplied by */ +/* > ILAENV(ISPEC,'ZHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK). */ +/* > It is suggested that these defaults be adjusted in order */ +/* > to attain best performance in each particular */ +/* > computational environment. */ +/* > */ +/* > ISPEC=12: The ZLAHQR vs ZLAQR0 crossover point. */ +/* > Default: 75. (Must be at least 11.) */ +/* > */ +/* > ISPEC=13: Recommended deflation window size. */ +/* > This depends on ILO, IHI and NS. NS is the */ +/* > number of simultaneous shifts returned */ +/* > by ILAENV(ISPEC=15). (See ISPEC=15 below.) */ +/* > The default for (IHI-ILO+1) <= 500 is NS. */ +/* > The default for (IHI-ILO+1) > 500 is 3*NS/2. */ +/* > */ +/* > ISPEC=14: Nibble crossover point. (See IPARMQ for */ +/* > details.) Default: 14% of deflation window */ +/* > size. */ +/* > */ +/* > ISPEC=15: Number of simultaneous shifts in a multishift */ +/* > QR iteration. */ +/* > */ +/* > If IHI-ILO+1 is ... */ +/* > */ +/* > greater than ...but less ... the */ +/* > or equal to ... than default is */ +/* > */ +/* > 1 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 some or all matrices of this order */ +/* > are passed to the implicit double shift routine */ +/* > ZLAHQR and this parameter is ignored. See */ +/* > ISPEC=12 above and comments in IPARMQ for */ +/* > details. */ +/* > */ +/* > (**) The asterisks (**) indicate an ad-hoc */ +/* > function of N increasing from 10 to 64. */ +/* > */ +/* > ISPEC=16: Select structured matrix multiply. */ +/* > If the number of simultaneous shifts (specified */ +/* > by ISPEC=15) is less than 14, then the default */ +/* > for ISPEC=16 is 0. Otherwise the default for */ +/* > ISPEC=16 is 2. */ +/* > \endverbatim */ + +/* > \par References: */ +/* ================ */ +/* > */ +/* > K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ +/* > Algorithm Part I: Maintaining Well Focused Shifts, and Level 3 */ +/* > Performance, SIAM Journal of Matrix Analysis, volume 23, pages */ +/* > 929--947, 2002. */ +/* > \n */ +/* > K. Braman, R. Byers and R. Mathias, The Multi-Shift QR */ +/* > Algorithm Part II: Aggressive Early Deflation, SIAM Journal */ +/* > of Matrix Analysis, volume 23, pages 948--973, 2002. */ + +/* ===================================================================== */ +/* Subroutine */ int zhseqr_(char *job, char *compz, integer *n, integer *ilo, + integer *ihi, doublecomplex *h__, integer *ldh, doublecomplex *w, + doublecomplex *z__, integer *ldz, doublecomplex *work, integer *lwork, + integer *info) +{ + /* System generated locals */ + address a__1[2]; + integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3[2]; + doublereal d__1, d__2, d__3; + doublecomplex z__1; + char ch__1[2]; + + /* Local variables */ + integer kbot, nmin; + extern logical lsame_(char *, char *); + logical initz; + doublecomplex workl[49]; + logical wantt, wantz; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zlaqr0_(logical *, logical *, + integer *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *, integer *); + doublecomplex hl[2401] /* was [49][49] */; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + extern /* Subroutine */ int zlahqr_(logical *, logical *, integer *, + integer *, integer *, doublecomplex *, integer *, doublecomplex *, + integer *, integer *, doublecomplex *, integer *, integer *), + zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zlaset_(char *, integer *, + integer *, doublecomplex *, doublecomplex *, doublecomplex *, + integer *); + 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 */ + + +/* ===================================================================== */ + + +/* ==== Matrices of order NTINY or smaller must be processed by */ +/* . ZLAHQR because of insufficient subdiagonal scratch space. */ +/* . (This is a hard limit.) ==== */ + +/* ==== NL allocates some local workspace to help small matrices */ +/* . through a rare ZLAHQR failure. NL > NTINY = 15 is */ +/* . required and NL <= NMIN = ILAENV(ISPEC=12,...) is recom- */ +/* . mended. (The default value of NMIN is 75.) Using NL = 49 */ +/* . allows up to six simultaneous shifts and a 16-by-16 */ +/* . deflation window. ==== */ + +/* ==== Decode and check the input parameters. ==== */ + + /* Parameter adjustments */ + h_dim1 = *ldh; + h_offset = 1 + h_dim1 * 1; + h__ -= h_offset; + --w; + z_dim1 = *ldz; + z_offset = 1 + z_dim1 * 1; + z__ -= z_offset; + --work; + + /* Function Body */ + wantt = lsame_(job, "S"); + initz = lsame_(compz, "I"); + wantz = initz || lsame_(compz, "V"); + d__1 = (doublereal) f2cmax(1,*n); + z__1.r = d__1, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + lquery = *lwork == -1; + + *info = 0; + if (! lsame_(job, "E") && ! wantt) { + *info = -1; + } else if (! lsame_(compz, "N") && ! wantz) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*ilo < 1 || *ilo > f2cmax(1,*n)) { + *info = -4; + } else if (*ihi < f2cmin(*ilo,*n) || *ihi > *n) { + *info = -5; + } else if (*ldh < f2cmax(1,*n)) { + *info = -7; + } else if (*ldz < 1 || wantz && *ldz < f2cmax(1,*n)) { + *info = -10; + } else if (*lwork < f2cmax(1,*n) && ! lquery) { + *info = -12; + } + + if (*info != 0) { + +/* ==== Quick return in case of invalid argument. ==== */ + + i__1 = -(*info); + xerbla_("ZHSEQR", &i__1, (ftnlen)6); + return 0; + + } else if (*n == 0) { + +/* ==== Quick return in case N = 0; nothing to do. ==== */ + + return 0; + + } else if (lquery) { + +/* ==== Quick return in case of a workspace query ==== */ + + zlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1], ilo, + ihi, &z__[z_offset], ldz, &work[1], lwork, info); +/* ==== Ensure reported workspace size is backward-compatible with */ +/* . previous LAPACK versions. ==== */ +/* Computing MAX */ + d__2 = work[1].r, d__3 = (doublereal) f2cmax(1,*n); + d__1 = f2cmax(d__2,d__3); + z__1.r = d__1, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + return 0; + + } else { + +/* ==== copy eigenvalues isolated by ZGEBAL ==== */ + + if (*ilo > 1) { + i__1 = *ilo - 1; + i__2 = *ldh + 1; + zcopy_(&i__1, &h__[h_offset], &i__2, &w[1], &c__1); + } + if (*ihi < *n) { + i__1 = *n - *ihi; + i__2 = *ldh + 1; + zcopy_(&i__1, &h__[*ihi + 1 + (*ihi + 1) * h_dim1], &i__2, &w[* + ihi + 1], &c__1); + } + +/* ==== Initialize Z, if requested ==== */ + + if (initz) { + zlaset_("A", n, n, &c_b1, &c_b2, &z__[z_offset], ldz); + } + +/* ==== Quick return if possible ==== */ + + if (*ilo == *ihi) { + i__1 = *ilo; + i__2 = *ilo + *ilo * h_dim1; + w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i; + return 0; + } + +/* ==== ZLAHQR/ZLAQR0 crossover point ==== */ + +/* Writing concatenation */ + i__3[0] = 1, a__1[0] = job; + i__3[1] = 1, a__1[1] = compz; + s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2); + nmin = ilaenv_(&c__12, "ZHSEQR", ch__1, n, ilo, ihi, lwork, (ftnlen)6, + (ftnlen)2); + nmin = f2cmax(15,nmin); + +/* ==== ZLAQR0 for big matrices; ZLAHQR for small ones ==== */ + + if (*n > nmin) { + zlaqr0_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1], + ilo, ihi, &z__[z_offset], ldz, &work[1], lwork, info); + } else { + +/* ==== Small matrix ==== */ + + zlahqr_(&wantt, &wantz, n, ilo, ihi, &h__[h_offset], ldh, &w[1], + ilo, ihi, &z__[z_offset], ldz, info); + + if (*info > 0) { + +/* ==== A rare ZLAHQR failure! ZLAQR0 sometimes succeeds */ +/* . when ZLAHQR fails. ==== */ + + kbot = *info; + + if (*n >= 49) { + +/* ==== Larger matrices have enough subdiagonal scratch */ +/* . space to call ZLAQR0 directly. ==== */ + + zlaqr0_(&wantt, &wantz, n, ilo, &kbot, &h__[h_offset], + ldh, &w[1], ilo, ihi, &z__[z_offset], ldz, &work[ + 1], lwork, info); + + } else { + +/* ==== Tiny matrices don't have enough subdiagonal */ +/* . scratch space to benefit from ZLAQR0. Hence, */ +/* . tiny matrices must be copied into a larger */ +/* . array before calling ZLAQR0. ==== */ + + zlacpy_("A", n, n, &h__[h_offset], ldh, hl, &c__49); + i__1 = *n + 1 + *n * 49 - 50; + hl[i__1].r = 0., hl[i__1].i = 0.; + i__1 = 49 - *n; + zlaset_("A", &c__49, &i__1, &c_b1, &c_b1, &hl[(*n + 1) * + 49 - 49], &c__49); + zlaqr0_(&wantt, &wantz, &c__49, ilo, &kbot, hl, &c__49, & + w[1], ilo, ihi, &z__[z_offset], ldz, workl, & + c__49, info); + if (wantt || *info != 0) { + zlacpy_("A", n, n, hl, &c__49, &h__[h_offset], ldh); + } + } + } + } + +/* ==== Clear out the trash, if necessary. ==== */ + + if ((wantt || *info != 0) && *n > 2) { + i__1 = *n - 2; + i__2 = *n - 2; + zlaset_("L", &i__1, &i__2, &c_b1, &c_b1, &h__[h_dim1 + 3], ldh); + } + +/* ==== Ensure reported workspace size is backward-compatible with */ +/* . previous LAPACK versions. ==== */ + +/* Computing MAX */ + d__2 = (doublereal) f2cmax(1,*n), d__3 = work[1].r; + d__1 = f2cmax(d__2,d__3); + z__1.r = d__1, z__1.i = 0.; + work[1].r = z__1.r, work[1].i = z__1.i; + } + +/* ==== End of ZHSEQR ==== */ + + return 0; +} /* zhseqr_ */ + diff --git a/lapack-netlib/SRC/zla_gbamv.c b/lapack-netlib/SRC/zla_gbamv.c new file mode 100644 index 000000000..cff36856e --- /dev/null +++ b/lapack-netlib/SRC/zla_gbamv.c @@ -0,0 +1,839 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_GBAMV performs a matrix-vector operation to calculate error bounds. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_GBAMV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLA_GBAMV( TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, */ +/* INCX, BETA, Y, INCY ) */ + +/* DOUBLE PRECISION ALPHA, BETA */ +/* INTEGER INCX, INCY, LDAB, M, N, KL, KU, TRANS */ +/* COMPLEX*16 AB( LDAB, * ), X( * ) */ +/* DOUBLE PRECISION Y( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLA_GBAMV performs one of the matrix-vector operations */ +/* > */ +/* > y := alpha*abs(A)*abs(x) + beta*abs(y), */ +/* > or y := alpha*abs(A)**T*abs(x) + beta*abs(y), */ +/* > */ +/* > where alpha and beta are scalars, x and y are vectors and A is an */ +/* > m by n matrix. */ +/* > */ +/* > This function is primarily used in calculating error bounds. */ +/* > To protect against underflow during evaluation, components in */ +/* > the resulting vector are perturbed away from zero by (N+1) */ +/* > times the underflow threshold. To prevent unnecessarily large */ +/* > errors for block-structure embedded in general matrices, */ +/* > "symbolically" zero components are not perturbed. A zero */ +/* > entry is considered "symbolic" if all multiplications involved */ +/* > in computing that entry have at least one zero multiplicand. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is INTEGER */ +/* > On entry, TRANS specifies the operation to be performed as */ +/* > follows: */ +/* > */ +/* > BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) */ +/* > BLAS_TRANS y := alpha*abs(A**T)*abs(x) + beta*abs(y) */ +/* > BLAS_CONJ_TRANS y := alpha*abs(A**T)*abs(x) + beta*abs(y) */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > On entry, M specifies the number of rows of the matrix A. */ +/* > 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 the matrix A. */ +/* > N must be at least zero. */ +/* > Unchanged on exit. */ +/* > \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] ALPHA */ +/* > \verbatim */ +/* > ALPHA is DOUBLE PRECISION */ +/* > On entry, ALPHA specifies the scalar alpha. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is COMPLEX*16 array, dimension ( LDAB, n ) */ +/* > Before entry, the leading m by n part of the array AB must */ +/* > contain the matrix of coefficients. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > On entry, LDAB specifies the first dimension of AB as declared */ +/* > in the calling (sub) program. LDAB must be at least */ +/* > f2cmax( 1, m ). */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension */ +/* > ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */ +/* > and at least */ +/* > ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */ +/* > Before entry, the incremented array X must contain the */ +/* > vector x. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > On entry, INCX specifies the increment for the elements of */ +/* > X. INCX must not be zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION */ +/* > On entry, BETA specifies the scalar beta. When BETA is */ +/* > supplied as zero then Y need not be set on input. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is DOUBLE PRECISION array, dimension */ +/* > ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */ +/* > and at least */ +/* > ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */ +/* > Before entry with BETA non-zero, the incremented array Y */ +/* > must contain the vector y. On exit, Y is overwritten by the */ +/* > updated vector y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCY */ +/* > \verbatim */ +/* > INCY is INTEGER */ +/* > On entry, INCY specifies the increment for the elements of */ +/* > Y. INCY must not be zero. */ +/* > Unchanged on exit. */ +/* > */ +/* > Level 2 Blas routine. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup complex16GBcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zla_gbamv_(integer *trans, integer *m, integer *n, + integer *kl, integer *ku, doublereal *alpha, doublecomplex *ab, + integer *ldab, doublecomplex *x, integer *incx, doublereal *beta, + doublereal *y, integer *incy) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4; + doublereal d__1, d__2; + + /* Local variables */ + integer info; + doublereal temp; + integer lenx, leny; + extern integer ilatrans_(char *); + doublereal safe1; + integer i__, j; + logical symb_zero__; + integer kd, ke; + extern doublereal dlamch_(char *); + integer iy, jx, kx, ky; + 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 */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + --x; + --y; + + /* Function Body */ + info = 0; + if (! (*trans == ilatrans_("N") || *trans == ilatrans_("T") || *trans == ilatrans_("C"))) { + info = 1; + } else if (*m < 0) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*kl < 0 || *kl > *m - 1) { + info = 4; + } else if (*ku < 0 || *ku > *n - 1) { + info = 5; + } else if (*ldab < *kl + *ku + 1) { + info = 6; + } else if (*incx == 0) { + info = 8; + } else if (*incy == 0) { + info = 11; + } + if (info != 0) { + xerbla_("ZLA_GBAMV ", &info, (ftnlen)10); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { + return 0; + } + +/* Set LENX and LENY, the lengths of the vectors x and y, and set */ +/* up the start points in X and Y. */ + + if (*trans == ilatrans_("N")) { + lenx = *n; + leny = *m; + } else { + lenx = *m; + leny = *n; + } + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (lenx - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (leny - 1) * *incy; + } + +/* Set SAFE1 essentially to be the underflow threshold times the */ +/* number of additions in each row. */ + + safe1 = dlamch_("Safe minimum"); + safe1 = (*n + 1) * safe1; + +/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */ + +/* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to */ +/* the inexact flag. Still doesn't help change the iteration order */ +/* to per-column. */ + + kd = *ku + 1; + ke = *kl + 1; + iy = ky; + if (*incx == 1) { + if (*trans == ilatrans_("N")) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + if (*alpha != 0.) { +/* Computing MAX */ + i__2 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__3 = f2cmin(i__4,lenx); + for (j = f2cmax(i__2,1); j <= i__3; ++j) { + i__2 = kd + i__ - j + j * ab_dim1; + temp = (d__1 = ab[i__2].r, abs(d__1)) + (d__2 = + d_imag(&ab[kd + i__ - j + j * ab_dim1]), abs( + d__2)); + i__2 = j; + symb_zero__ = symb_zero__ && (x[i__2].r == 0. && x[ + i__2].i == 0. || temp == 0.); + i__2 = j; + y[iy] += *alpha * ((d__1 = x[i__2].r, abs(d__1)) + ( + d__2 = d_imag(&x[j]), abs(d__2))) * temp; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + if (*alpha != 0.) { +/* Computing MAX */ + i__3 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__2 = f2cmin(i__4,lenx); + for (j = f2cmax(i__3,1); j <= i__2; ++j) { + i__3 = ke - i__ + j + i__ * ab_dim1; + temp = (d__1 = ab[i__3].r, abs(d__1)) + (d__2 = + d_imag(&ab[ke - i__ + j + i__ * ab_dim1]), + abs(d__2)); + i__3 = j; + symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ + i__3].i == 0. || temp == 0.); + i__3 = j; + y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&x[j]), abs(d__2))) * temp; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } + } else { + if (*trans == ilatrans_("N")) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + if (*alpha != 0.) { + jx = kx; +/* Computing MAX */ + i__2 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__3 = f2cmin(i__4,lenx); + for (j = f2cmax(i__2,1); j <= i__3; ++j) { + i__2 = kd + i__ - j + j * ab_dim1; + temp = (d__1 = ab[i__2].r, abs(d__1)) + (d__2 = + d_imag(&ab[kd + i__ - j + j * ab_dim1]), abs( + d__2)); + i__2 = jx; + symb_zero__ = symb_zero__ && (x[i__2].r == 0. && x[ + i__2].i == 0. || temp == 0.); + i__2 = jx; + y[iy] += *alpha * ((d__1 = x[i__2].r, abs(d__1)) + ( + d__2 = d_imag(&x[jx]), abs(d__2))) * temp; + jx += *incx; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + if (*alpha != 0.) { + jx = kx; +/* Computing MAX */ + i__3 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__2 = f2cmin(i__4,lenx); + for (j = f2cmax(i__3,1); j <= i__2; ++j) { + i__3 = ke - i__ + j + i__ * ab_dim1; + temp = (d__1 = ab[i__3].r, abs(d__1)) + (d__2 = + d_imag(&ab[ke - i__ + j + i__ * ab_dim1]), + abs(d__2)); + i__3 = jx; + symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ + i__3].i == 0. || temp == 0.); + i__3 = jx; + y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&x[jx]), abs(d__2))) * temp; + jx += *incx; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } + } + + return 0; + +/* End of ZLA_GBAMV */ + +} /* zla_gbamv__ */ + diff --git a/lapack-netlib/SRC/zla_gbrcond_c.c b/lapack-netlib/SRC/zla_gbrcond_c.c new file mode 100644 index 000000000..fd5f398e4 --- /dev/null +++ b/lapack-netlib/SRC/zla_gbrcond_c.c @@ -0,0 +1,796 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_GBRCOND_C computes the infinity norm condition number of op(A)*inv(diag(c)) for general ban +ded matrices. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_GBRCOND_C + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLA_GBRCOND_C( TRANS, N, KL, KU, AB, */ +/* LDAB, AFB, LDAFB, IPIV, */ +/* C, CAPPLY, INFO, WORK, */ +/* RWORK ) */ + +/* CHARACTER TRANS */ +/* LOGICAL CAPPLY */ +/* INTEGER N, KL, KU, KD, KE, LDAB, LDAFB, INFO */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ) */ +/* DOUBLE PRECISION C( * ), RWORK( * ) */ + + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLA_GBRCOND_C Computes the infinity norm condition number of */ +/* > op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector. */ +/* > \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 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] AB */ +/* > \verbatim */ +/* > AB is COMPLEX*16 array, dimension (LDAB,N) */ +/* > On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */ +/* > The j-th column of A is stored in the j-th column of the */ +/* > array AB as follows: */ +/* > AB(KU+1+i-j,j) = A(i,j) for f2cmax(1,j-KU)<=i<=f2cmin(N,j+kl) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AFB */ +/* > \verbatim */ +/* > AFB is COMPLEX*16 array, dimension (LDAFB,N) */ +/* > Details of the LU factorization of the band matrix A, as */ +/* > computed by ZGBTRF. U is stored as an upper triangular */ +/* > band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */ +/* > and the multipliers used during the factorization are stored */ +/* > in rows KL+KU+2 to 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAFB */ +/* > \verbatim */ +/* > LDAFB is INTEGER */ +/* > The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices from the factorization A = P*L*U */ +/* > as computed by ZGBTRF; row i of the matrix was interchanged */ +/* > with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N) */ +/* > The vector C in the formula op(A) * inv(diag(C)). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CAPPLY */ +/* > \verbatim */ +/* > CAPPLY is LOGICAL */ +/* > If .TRUE. then access the vector C in the formula above. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > i > 0: The ith argument is invalid. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N). */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (N). */ +/* > Workspace. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GBcomputational */ + +/* ===================================================================== */ +doublereal zla_gbrcond_c_(char *trans, integer *n, integer *kl, integer *ku, + doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *ldafb, + integer *ipiv, doublereal *c__, logical *capply, integer *info, + doublecomplex *work, doublereal *rwork) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, i__1, i__2, i__3, i__4; + doublereal ret_val, d__1, d__2; + doublecomplex z__1; + + /* Local variables */ + integer kase, i__, j; + extern logical lsame_(char *, char *); + integer isave[3]; + doublereal anorm; + extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *, + doublecomplex *, doublereal *, integer *, integer *); + integer kd, ke; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal ainvnm; + extern /* Subroutine */ int zgbtrs_(char *, integer *, integer *, integer + *, integer *, doublecomplex *, integer *, integer *, + doublecomplex *, integer *, integer *); + doublereal tmp; + logical 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 */ + + + +/* ===================================================================== */ + + /* 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; + --c__; + --work; + --rwork; + + /* Function Body */ + ret_val = 0.; + + *info = 0; + notrans = lsame_(trans, "N"); + if (! notrans && ! lsame_(trans, "T") && ! lsame_( + trans, "C")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0 || *kl > *n - 1) { + *info = -3; + } else if (*ku < 0 || *ku > *n - 1) { + *info = -4; + } else if (*ldab < *kl + *ku + 1) { + *info = -6; + } else if (*ldafb < (*kl << 1) + *ku + 1) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLA_GBRCOND_C", &i__1, (ftnlen)13); + return ret_val; + } + +/* Compute norm of op(A)*op2(C). */ + + anorm = 0.; + kd = *ku + 1; + ke = *kl + 1; + if (notrans) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + if (*capply) { +/* Computing MAX */ + i__2 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__3 = f2cmin(i__4,*n); + for (j = f2cmax(i__2,1); j <= i__3; ++j) { + i__2 = kd + i__ - j + j * ab_dim1; + tmp += ((d__1 = ab[i__2].r, abs(d__1)) + (d__2 = d_imag(& + ab[kd + i__ - j + j * ab_dim1]), abs(d__2))) / + c__[j]; + } + } else { +/* Computing MAX */ + i__3 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__2 = f2cmin(i__4,*n); + for (j = f2cmax(i__3,1); j <= i__2; ++j) { + i__3 = kd + i__ - j + j * ab_dim1; + tmp += (d__1 = ab[i__3].r, abs(d__1)) + (d__2 = d_imag(& + ab[kd + i__ - j + j * ab_dim1]), abs(d__2)); + } + } + rwork[i__] = tmp; + anorm = f2cmax(anorm,tmp); + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + if (*capply) { +/* Computing MAX */ + i__2 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__3 = f2cmin(i__4,*n); + for (j = f2cmax(i__2,1); j <= i__3; ++j) { + i__2 = ke - i__ + j + i__ * ab_dim1; + tmp += ((d__1 = ab[i__2].r, abs(d__1)) + (d__2 = d_imag(& + ab[ke - i__ + j + i__ * ab_dim1]), abs(d__2))) / + c__[j]; + } + } else { +/* Computing MAX */ + i__3 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__2 = f2cmin(i__4,*n); + for (j = f2cmax(i__3,1); j <= i__2; ++j) { + i__3 = ke - i__ + j + i__ * ab_dim1; + tmp += (d__1 = ab[i__3].r, abs(d__1)) + (d__2 = d_imag(& + ab[ke - i__ + j + i__ * ab_dim1]), abs(d__2)); + } + } + rwork[i__] = tmp; + anorm = f2cmax(anorm,tmp); + } + } + +/* Quick return if possible. */ + + if (*n == 0) { + ret_val = 1.; + return ret_val; + } else if (anorm == 0.) { + return ret_val; + } + +/* Estimate the norm of inv(op(A)). */ + + ainvnm = 0.; + + kase = 0; +L10: + zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == 2) { + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + + if (notrans) { + zgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset], + ldafb, &ipiv[1], &work[1], n, info); + } else { + zgbtrs_("Conjugate transpose", n, kl, ku, &c__1, &afb[ + afb_offset], ldafb, &ipiv[1], &work[1], n, info); + } + +/* Multiply by inv(C). */ + + if (*capply) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = c__[i__4] * work[i__3].r, z__1.i = c__[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } + } else { + +/* Multiply by inv(C**H). */ + + if (*capply) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = c__[i__4] * work[i__3].r, z__1.i = c__[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } + + if (notrans) { + zgbtrs_("Conjugate transpose", n, kl, ku, &c__1, &afb[ + afb_offset], ldafb, &ipiv[1], &work[1], n, info); + } else { + zgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset], + ldafb, &ipiv[1], &work[1], n, info); + } + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + ret_val = 1. / ainvnm; + } + + return ret_val; + +} /* zla_gbrcond_c__ */ + diff --git a/lapack-netlib/SRC/zla_gbrcond_x.c b/lapack-netlib/SRC/zla_gbrcond_x.c new file mode 100644 index 000000000..6955c8726 --- /dev/null +++ b/lapack-netlib/SRC/zla_gbrcond_x.c @@ -0,0 +1,762 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_GBRCOND_X computes the infinity norm condition number of op(A)*diag(x) for general banded m +atrices. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_GBRCOND_X + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLA_GBRCOND_X( TRANS, N, KL, KU, AB, */ +/* LDAB, AFB, LDAFB, IPIV, */ +/* X, INFO, WORK, RWORK ) */ + +/* CHARACTER TRANS */ +/* INTEGER N, KL, KU, KD, KE, LDAB, LDAFB, INFO */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ), */ +/* $ X( * ) */ +/* DOUBLE PRECISION RWORK( * ) */ + + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLA_GBRCOND_X Computes the infinity norm condition number of */ +/* > op(A) * diag(X) where X is a COMPLEX*16 vector. */ +/* > \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 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] AB */ +/* > \verbatim */ +/* > AB is COMPLEX*16 array, dimension (LDAB,N) */ +/* > On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */ +/* > The j-th column of A is stored in the j-th column of the */ +/* > array AB as follows: */ +/* > AB(KU+1+i-j,j) = A(i,j) for f2cmax(1,j-KU)<=i<=f2cmin(N,j+kl) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AFB */ +/* > \verbatim */ +/* > AFB is COMPLEX*16 array, dimension (LDAFB,N) */ +/* > Details of the LU factorization of the band matrix A, as */ +/* > computed by ZGBTRF. U is stored as an upper triangular */ +/* > band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */ +/* > and the multipliers used during the factorization are stored */ +/* > in rows KL+KU+2 to 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAFB */ +/* > \verbatim */ +/* > LDAFB is INTEGER */ +/* > The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices from the factorization A = P*L*U */ +/* > as computed by ZGBTRF; row i of the matrix was interchanged */ +/* > with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (N) */ +/* > The vector X in the formula op(A) * diag(X). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > i > 0: The ith argument is invalid. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N). */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (N). */ +/* > Workspace. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GBcomputational */ + +/* ===================================================================== */ +doublereal zla_gbrcond_x_(char *trans, integer *n, integer *kl, integer *ku, + doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *ldafb, + integer *ipiv, doublecomplex *x, integer *info, doublecomplex *work, + doublereal *rwork) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, i__1, i__2, i__3, i__4; + doublereal ret_val, d__1, d__2; + doublecomplex z__1, z__2; + + /* Local variables */ + integer kase, i__, j; + extern logical lsame_(char *, char *); + integer isave[3]; + doublereal anorm; + extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *, + doublecomplex *, doublereal *, integer *, integer *); + integer kd, ke; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal ainvnm; + extern /* Subroutine */ int zgbtrs_(char *, integer *, integer *, integer + *, integer *, doublecomplex *, integer *, integer *, + doublecomplex *, integer *, integer *); + doublereal tmp; + logical 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 */ + + + +/* ===================================================================== */ + + + /* 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; + --x; + --work; + --rwork; + + /* Function Body */ + ret_val = 0.; + + *info = 0; + notrans = lsame_(trans, "N"); + if (! notrans && ! lsame_(trans, "T") && ! lsame_( + trans, "C")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*kl < 0 || *kl > *n - 1) { + *info = -3; + } else if (*ku < 0 || *ku > *n - 1) { + *info = -4; + } else if (*ldab < *kl + *ku + 1) { + *info = -6; + } else if (*ldafb < (*kl << 1) + *ku + 1) { + *info = -8; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLA_GBRCOND_X", &i__1, (ftnlen)13); + return ret_val; + } + +/* Compute norm of op(A)*op2(C). */ + + kd = *ku + 1; + ke = *kl + 1; + anorm = 0.; + if (notrans) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; +/* Computing MAX */ + i__2 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__3 = f2cmin(i__4,*n); + for (j = f2cmax(i__2,1); j <= i__3; ++j) { + i__2 = kd + i__ - j + j * ab_dim1; + i__4 = j; + z__2.r = ab[i__2].r * x[i__4].r - ab[i__2].i * x[i__4].i, + z__2.i = ab[i__2].r * x[i__4].i + ab[i__2].i * x[i__4] + .r; + z__1.r = z__2.r, z__1.i = z__2.i; + tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), + abs(d__2)); + } + rwork[i__] = tmp; + anorm = f2cmax(anorm,tmp); + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; +/* Computing MAX */ + i__3 = i__ - *kl; +/* Computing MIN */ + i__4 = i__ + *ku; + i__2 = f2cmin(i__4,*n); + for (j = f2cmax(i__3,1); j <= i__2; ++j) { + i__3 = ke - i__ + j + i__ * ab_dim1; + i__4 = j; + z__2.r = ab[i__3].r * x[i__4].r - ab[i__3].i * x[i__4].i, + z__2.i = ab[i__3].r * x[i__4].i + ab[i__3].i * x[i__4] + .r; + z__1.r = z__2.r, z__1.i = z__2.i; + tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), + abs(d__2)); + } + rwork[i__] = tmp; + anorm = f2cmax(anorm,tmp); + } + } + +/* Quick return if possible. */ + + if (*n == 0) { + ret_val = 1.; + return ret_val; + } else if (anorm == 0.) { + return ret_val; + } + +/* Estimate the norm of inv(op(A)). */ + + ainvnm = 0.; + + kase = 0; +L10: + zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == 2) { + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + + if (notrans) { + zgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset], + ldafb, &ipiv[1], &work[1], n, info); + } else { + zgbtrs_("Conjugate transpose", n, kl, ku, &c__1, &afb[ + afb_offset], ldafb, &ipiv[1], &work[1], n, info); + } + +/* Multiply by inv(X). */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + z_div(&z__1, &work[i__], &x[i__]); + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } else { + +/* Multiply by inv(X**H). */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + z_div(&z__1, &work[i__], &x[i__]); + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + + if (notrans) { + zgbtrs_("Conjugate transpose", n, kl, ku, &c__1, &afb[ + afb_offset], ldafb, &ipiv[1], &work[1], n, info); + } else { + zgbtrs_("No transpose", n, kl, ku, &c__1, &afb[afb_offset], + ldafb, &ipiv[1], &work[1], n, info); + } + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + ret_val = 1. / ainvnm; + } + + return ret_val; + +} /* zla_gbrcond_x__ */ + diff --git a/lapack-netlib/SRC/zla_gbrfsx_extended.c b/lapack-netlib/SRC/zla_gbrfsx_extended.c new file mode 100644 index 000000000..a10903f16 --- /dev/null +++ b/lapack-netlib/SRC/zla_gbrfsx_extended.c @@ -0,0 +1,1149 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_GBRFSX_EXTENDED improves the computed solution to a system of linear equations for general +banded matrices by performing extra-precise iterative refinement and provides error bounds and backwar +d error estimates for the solution. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_GBRFSX_EXTENDED + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLA_GBRFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, KL, KU, */ +/* NRHS, AB, LDAB, AFB, LDAFB, IPIV, */ +/* COLEQU, C, B, LDB, Y, LDY, */ +/* BERR_OUT, N_NORMS, ERR_BNDS_NORM, */ +/* ERR_BNDS_COMP, RES, AYB, DY, */ +/* Y_TAIL, RCOND, ITHRESH, RTHRESH, */ +/* DZ_UB, IGNORE_CWISE, INFO ) */ + +/* INTEGER INFO, LDAB, LDAFB, LDB, LDY, N, KL, KU, NRHS, */ +/* $ PREC_TYPE, TRANS_TYPE, N_NORMS, ITHRESH */ +/* LOGICAL COLEQU, IGNORE_CWISE */ +/* DOUBLE PRECISION RTHRESH, DZ_UB */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ), */ +/* $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) */ +/* DOUBLE PRECISION C( * ), AYB(*), RCOND, BERR_OUT( * ), */ +/* $ ERR_BNDS_NORM( NRHS, * ), */ +/* $ ERR_BNDS_COMP( NRHS, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLA_GBRFSX_EXTENDED improves the computed solution to a system of */ +/* > linear equations by performing extra-precise iterative refinement */ +/* > and provides error bounds and backward error estimates for the solution. */ +/* > This subroutine is called by ZGBRFSX to perform iterative refinement. */ +/* > 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. Note that this */ +/* > subroutine is only resonsible for setting the second fields of */ +/* > ERR_BNDS_NORM and ERR_BNDS_COMP. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] PREC_TYPE */ +/* > \verbatim */ +/* > PREC_TYPE is INTEGER */ +/* > Specifies the intermediate precision to be used in refinement. */ +/* > The value is defined by ILAPREC(P) where P is a CHARACTER and P */ +/* > = 'S': Single */ +/* > = 'D': Double */ +/* > = 'I': Indigenous */ +/* > = 'X' or 'E': Extra */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS_TYPE */ +/* > \verbatim */ +/* > TRANS_TYPE is INTEGER */ +/* > Specifies the transposition operation on A. */ +/* > The value is defined by ILATRANS(T) where T is a CHARACTER and T */ +/* > = 'N': No transpose */ +/* > = 'T': Transpose */ +/* > = 'C': Conjugate transpose */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KL */ +/* > \verbatim */ +/* > KL is INTEGER */ +/* > The number of subdiagonals within the band of A. KL >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] KU */ +/* > \verbatim */ +/* > KU is INTEGER */ +/* > The number of superdiagonals within the band of A. KU >= 0 */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right-hand-sides, i.e., the number of columns of the */ +/* > matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is COMPLEX*16 array, dimension (LDAB,N) */ +/* > On entry, the N-by-N matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array A. LDAB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AFB */ +/* > \verbatim */ +/* > AFB is COMPLEX*16 array, dimension (LDAF,N) */ +/* > The factors L and U from the factorization */ +/* > A = P*L*U as computed by ZGBTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAFB */ +/* > \verbatim */ +/* > LDAFB is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices from the factorization A = P*L*U */ +/* > as computed by ZGBTRF; row i of the matrix was interchanged */ +/* > with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COLEQU */ +/* > \verbatim */ +/* > COLEQU is LOGICAL */ +/* > If .TRUE. then column equilibration was done to A before calling */ +/* > this routine. This is needed to compute the solution and error */ +/* > bounds correctly. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N) */ +/* > The column scale factors for A. If COLEQU = .FALSE., C */ +/* > is not accessed. 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 COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > The right-hand-side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is COMPLEX*16 array, dimension (LDY,NRHS) */ +/* > On entry, the solution matrix X, as computed by ZGBTRS. */ +/* > On exit, the improved solution matrix Y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDY */ +/* > \verbatim */ +/* > LDY is INTEGER */ +/* > The leading dimension of the array Y. LDY >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR_OUT */ +/* > \verbatim */ +/* > BERR_OUT is DOUBLE PRECISION array, dimension (NRHS) */ +/* > On exit, BERR_OUT(j) contains the componentwise relative backward */ +/* > error for right-hand-side j from the formula */ +/* > f2cmax(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* > where abs(Z) is the componentwise absolute value of the matrix */ +/* > or vector Z. This is computed by ZLA_LIN_BERR. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N_NORMS */ +/* > \verbatim */ +/* > N_NORMS is INTEGER */ +/* > Determines which error bounds to return (see ERR_BNDS_NORM */ +/* > and ERR_BNDS_COMP). */ +/* > If N_NORMS >= 1 return normwise error bounds. */ +/* > If N_NORMS >= 2 return componentwise error bounds. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ERR_BNDS_NORM */ +/* > \verbatim */ +/* > ERR_BNDS_NORM is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > normwise relative error, which is defined as follows: */ +/* > */ +/* > Normwise relative error in the ith solution vector: */ +/* > max_j (abs(XTRUE(j,i) - X(j,i))) */ +/* > ------------------------------ */ +/* > max_j abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the type of error information as described */ +/* > below. There currently are up to three pieces of information */ +/* > returned. */ +/* > */ +/* > The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_NORM(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * 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. */ +/* > */ +/* > This subroutine is only responsible for setting the second field */ +/* > above. */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ERR_BNDS_COMP */ +/* > \verbatim */ +/* > ERR_BNDS_COMP is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > componentwise relative error, which is defined as follows: */ +/* > */ +/* > Componentwise relative error in the ith solution vector: */ +/* > abs(XTRUE(j,i) - X(j,i)) */ +/* > max_j ---------------------- */ +/* > abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the right-hand side i (on which the */ +/* > componentwise relative error depends), and the type of error */ +/* > information as described below. There currently are up to three */ +/* > pieces of information returned for each right-hand side. If */ +/* > componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ +/* > ERR_BNDS_COMP is not accessed. If N_ERR_BNDS < 3, then at most */ +/* > the first (:,N_ERR_BNDS) entries are returned. */ +/* > */ +/* > The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_COMP(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * 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. */ +/* > */ +/* > This subroutine is only responsible for setting the second field */ +/* > above. */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RES */ +/* > \verbatim */ +/* > RES is COMPLEX*16 array, dimension (N) */ +/* > Workspace to hold the intermediate residual. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AYB */ +/* > \verbatim */ +/* > AYB is DOUBLE PRECISION array, dimension (N) */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DY */ +/* > \verbatim */ +/* > DY is COMPLEX*16 array, dimension (N) */ +/* > Workspace to hold the intermediate solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Y_TAIL */ +/* > \verbatim */ +/* > Y_TAIL is COMPLEX*16 array, dimension (N) */ +/* > Workspace to hold the trailing bits of the intermediate solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > Reciprocal scaled condition number. This is an estimate of the */ +/* > reciprocal Skeel condition number of the matrix A after */ +/* > equilibration (if done). If this is less than the machine */ +/* > precision (in particular, if it is zero), the matrix is singular */ +/* > to working precision. Note that the error may still be small even */ +/* > if this number is very small and the matrix appears ill- */ +/* > conditioned. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ITHRESH */ +/* > \verbatim */ +/* > ITHRESH is INTEGER */ +/* > The maximum number of residual computations allowed for */ +/* > refinement. The default is 10. For '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. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RTHRESH */ +/* > \verbatim */ +/* > RTHRESH is DOUBLE PRECISION */ +/* > Determines when to stop refinement if the error estimate stops */ +/* > decreasing. Refinement will stop when the next solution no longer */ +/* > satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */ +/* > the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */ +/* > default value is 0.5. For 'aggressive' set to 0.9 to permit */ +/* > convergence on extremely ill-conditioned matrices. See LAWN 165 */ +/* > for more details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DZ_UB */ +/* > \verbatim */ +/* > DZ_UB is DOUBLE PRECISION */ +/* > Determines when to start considering componentwise convergence. */ +/* > Componentwise convergence is only considered after each component */ +/* > of the solution Y is stable, which we definte as the relative */ +/* > change in each component being less than DZ_UB. The default value */ +/* > is 0.25, requiring the first bit to be stable. See LAWN 165 for */ +/* > more details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IGNORE_CWISE */ +/* > \verbatim */ +/* > IGNORE_CWISE is LOGICAL */ +/* > If .TRUE. then ignore componentwise convergence. Default value */ +/* > is .FALSE.. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > < 0: if INFO = -i, the ith argument to ZGBTRS 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 complex16GBcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zla_gbrfsx_extended_(integer *prec_type__, integer * + trans_type__, integer *n, integer *kl, integer *ku, integer *nrhs, + doublecomplex *ab, integer *ldab, doublecomplex *afb, integer *ldafb, + integer *ipiv, logical *colequ, doublereal *c__, doublecomplex *b, + integer *ldb, doublecomplex *y, integer *ldy, doublereal *berr_out__, + integer *n_norms__, doublereal *err_bnds_norm__, doublereal * + err_bnds_comp__, doublecomplex *res, doublereal *ayb, doublecomplex * + dy, doublecomplex *y_tail__, doublereal *rcond, integer *ithresh, + doublereal *rthresh, doublereal *dz_ub__, logical *ignore_cwise__, + integer *info) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, b_dim1, b_offset, + y_dim1, y_offset, err_bnds_norm_dim1, err_bnds_norm_offset, + err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3, i__4; + doublereal d__1, d__2; + char ch__1[1]; + + /* Local variables */ + doublereal dx_x__, dz_z__, ymin; + extern /* Subroutine */ int zla_lin_berr_(integer *, integer *, integer * + , doublecomplex *, doublereal *, doublereal *); + doublereal dxratmax, dzratmax; + extern /* Subroutine */ int blas_zgbmv_x_(integer *, integer *, integer * + , integer *, integer *, doublecomplex *, doublecomplex *, integer + *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *); + integer y_prec_state__, i__, j, m; + extern /* Subroutine */ int blas_zgbmv2_x_(integer *, integer *, integer + *, integer *, integer *, doublecomplex *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, doublecomplex *, integer *, integer *), + zla_gbamv_(integer *, integer *, integer *, integer *, integer *, + doublereal *, doublecomplex *, integer *, doublecomplex *, + integer *, doublereal *, doublereal *, integer *); + doublereal dxrat; + logical incr_prec__; + doublereal dzrat; + extern /* Subroutine */ int zgbmv_(char *, integer *, integer *, integer * + , integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *); + char trans[1]; + doublereal normx, normy; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *); + doublereal myhugeval, prev_dz_z__; + extern doublereal dlamch_(char *); + doublereal yk, final_dx_x__, final_dz_z__, normdx; + extern /* Subroutine */ int zgbtrs_(char *, integer *, integer *, integer + *, integer *, doublecomplex *, integer *, integer *, + doublecomplex *, integer *, integer *), zla_wwaddw_( + integer *, doublecomplex *, doublecomplex *, doublecomplex *); + extern /* Character */ VOID chla_transtype_(char *, integer *); + doublereal prevnormdx; + integer cnt; + doublereal dyk, eps; + integer x_state__, z_state__; + doublereal incr_thresh__; + + +/* -- 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 */ + 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; + --c__; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + y -= y_offset; + --berr_out__; + --res; + --ayb; + --dy; + --y_tail__; + + /* Function Body */ + if (*info != 0) { + return 0; + } + chla_transtype_(ch__1, trans_type__); + *(unsigned char *)trans = *(unsigned char *)&ch__1[0]; + eps = dlamch_("Epsilon"); + myhugeval = dlamch_("Overflow"); +/* Force MYHUGEVAL to Inf */ + myhugeval *= myhugeval; +/* Using MYHUGEVAL may lead to spurious underflows. */ + incr_thresh__ = (doublereal) (*n) * eps; + m = *kl + *ku + 1; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + y_prec_state__ = 1; + if (y_prec_state__ == 2) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + y_tail__[i__3].r = 0., y_tail__[i__3].i = 0.; + } + } + dxrat = 0.; + dxratmax = 0.; + dzrat = 0.; + dzratmax = 0.; + final_dx_x__ = myhugeval; + final_dz_z__ = myhugeval; + prevnormdx = myhugeval; + prev_dz_z__ = myhugeval; + dz_z__ = myhugeval; + dx_x__ = myhugeval; + x_state__ = 1; + z_state__ = 0; + incr_prec__ = FALSE_; + i__2 = *ithresh; + for (cnt = 1; cnt <= i__2; ++cnt) { + +/* Compute residual RES = B_s - op(A_s) * Y, */ +/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ + + zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + if (y_prec_state__ == 0) { + zgbmv_(trans, &m, n, kl, ku, &c_b6, &ab[ab_offset], ldab, &y[ + j * y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1); + } else if (y_prec_state__ == 1) { + blas_zgbmv_x__(trans_type__, n, n, kl, ku, &c_b6, &ab[ + ab_offset], ldab, &y[j * y_dim1 + 1], &c__1, &c_b8, & + res[1], &c__1, prec_type__); + } else { + blas_zgbmv2_x__(trans_type__, n, n, kl, ku, &c_b6, &ab[ + ab_offset], ldab, &y[j * y_dim1 + 1], &y_tail__[1], & + c__1, &c_b8, &res[1], &c__1, prec_type__); + } +/* XXX: RES is no longer needed. */ + zcopy_(n, &res[1], &c__1, &dy[1], &c__1); + zgbtrs_(trans, n, kl, ku, &c__1, &afb[afb_offset], ldafb, &ipiv[1] + , &dy[1], n, info); + +/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */ + + normx = 0.; + normy = 0.; + normdx = 0.; + dz_z__ = 0.; + ymin = myhugeval; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * y_dim1; + yk = (d__1 = y[i__4].r, abs(d__1)) + (d__2 = d_imag(&y[i__ + + j * y_dim1]), abs(d__2)); + i__4 = i__; + dyk = (d__1 = dy[i__4].r, abs(d__1)) + (d__2 = d_imag(&dy[i__] + ), abs(d__2)); + if (yk != 0.) { +/* Computing MAX */ + d__1 = dz_z__, d__2 = dyk / yk; + dz_z__ = f2cmax(d__1,d__2); + } else if (dyk != 0.) { + dz_z__ = myhugeval; + } + ymin = f2cmin(ymin,yk); + normy = f2cmax(normy,yk); + if (*colequ) { +/* Computing MAX */ + d__1 = normx, d__2 = yk * c__[i__]; + normx = f2cmax(d__1,d__2); +/* Computing MAX */ + d__1 = normdx, d__2 = dyk * c__[i__]; + normdx = f2cmax(d__1,d__2); + } else { + normx = normy; + normdx = f2cmax(normdx,dyk); + } + } + if (normx != 0.) { + dx_x__ = normdx / normx; + } else if (normdx == 0.) { + dx_x__ = 0.; + } else { + dx_x__ = myhugeval; + } + dxrat = normdx / prevnormdx; + dzrat = dz_z__ / prev_dz_z__; + +/* Check termination criteria. */ + + if (! (*ignore_cwise__) && ymin * *rcond < incr_thresh__ * normy + && y_prec_state__ < 2) { + incr_prec__ = TRUE_; + } + if (x_state__ == 3 && dxrat <= *rthresh) { + x_state__ = 1; + } + if (x_state__ == 1) { + if (dx_x__ <= eps) { + x_state__ = 2; + } else if (dxrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = TRUE_; + } else { + x_state__ = 3; + } + } else { + if (dxrat > dxratmax) { + dxratmax = dxrat; + } + } + if (x_state__ > 1) { + final_dx_x__ = dx_x__; + } + } + if (z_state__ == 0 && dz_z__ <= *dz_ub__) { + z_state__ = 1; + } + if (z_state__ == 3 && dzrat <= *rthresh) { + z_state__ = 1; + } + if (z_state__ == 1) { + if (dz_z__ <= eps) { + z_state__ = 2; + } else if (dz_z__ > *dz_ub__) { + z_state__ = 0; + dzratmax = 0.; + final_dz_z__ = myhugeval; + } else if (dzrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = TRUE_; + } else { + z_state__ = 3; + } + } else { + if (dzrat > dzratmax) { + dzratmax = dzrat; + } + } + if (z_state__ > 1) { + final_dz_z__ = dz_z__; + } + } + +/* Exit if both normwise and componentwise stopped working, */ +/* but if componentwise is unstable, let it go at least two */ +/* iterations. */ + + if (x_state__ != 1) { + if (*ignore_cwise__) { + goto L666; + } + if (z_state__ == 3 || z_state__ == 2) { + goto L666; + } + if (z_state__ == 0 && cnt > 1) { + goto L666; + } + } + if (incr_prec__) { + incr_prec__ = FALSE_; + ++y_prec_state__; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + y_tail__[i__4].r = 0., y_tail__[i__4].i = 0.; + } + } + prevnormdx = normdx; + prev_dz_z__ = dz_z__; + +/* Update soluton. */ + + if (y_prec_state__ < 2) { + zaxpy_(n, &c_b8, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1); + } else { + zla_wwaddw_(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]); + } + } +/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't CALL MYEXIT. */ +L666: + +/* Set final_* when cnt hits ithresh. */ + + if (x_state__ == 1) { + final_dx_x__ = dx_x__; + } + if (z_state__ == 1) { + final_dz_z__ = dz_z__; + } + +/* Compute error bounds. */ + + if (*n_norms__ >= 1) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / ( + 1 - dxratmax); + } + if (*n_norms__ >= 2) { + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / ( + 1 - dzratmax); + } + +/* Compute componentwise relative backward error from formula */ +/* f2cmax(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. */ + +/* Compute residual RES = B_s - op(A_s) * Y, */ +/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ + + zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + zgbmv_(trans, n, n, kl, ku, &c_b6, &ab[ab_offset], ldab, &y[j * + y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + ayb[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__ + + j * b_dim1]), abs(d__2)); + } + +/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */ + + zla_gbamv_(trans_type__, n, n, kl, ku, &c_b31, &ab[ab_offset], ldab, + &y[j * y_dim1 + 1], &c__1, &c_b31, &ayb[1], &c__1); + zla_lin_berr_(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]); + +/* End of loop for each RHS. */ + + } + + return 0; +} /* zla_gbrfsx_extended__ */ + diff --git a/lapack-netlib/SRC/zla_gbrpvgrw.c b/lapack-netlib/SRC/zla_gbrpvgrw.c new file mode 100644 index 000000000..e49f509cc --- /dev/null +++ b/lapack-netlib/SRC/zla_gbrpvgrw.c @@ -0,0 +1,574 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_GBRPVGRW computes the reciprocal pivot growth factor norm(A)/norm(U) for a general banded m +atrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_GBRPVGRW + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLA_GBRPVGRW( N, KL, KU, NCOLS, AB, */ +/* LDAB, AFB, LDAFB ) */ + +/* INTEGER N, KL, KU, NCOLS, LDAB, LDAFB */ +/* COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLA_GBRPVGRW computes the reciprocal pivot growth factor */ +/* > norm(A)/norm(U). The "f2cmax absolute element" norm is used. If this is */ +/* > much less than 1, 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. */ +/* > \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] NCOLS */ +/* > \verbatim */ +/* > NCOLS is INTEGER */ +/* > The number of columns of the matrix A. NCOLS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AB */ +/* > \verbatim */ +/* > AB is COMPLEX*16 array, dimension (LDAB,N) */ +/* > On entry, the matrix A in band storage, in rows 1 to KL+KU+1. */ +/* > The j-th column of A is stored in the j-th column of the */ +/* > array AB as follows: */ +/* > AB(KU+1+i-j,j) = A(i,j) for f2cmax(1,j-KU)<=i<=f2cmin(N,j+kl) */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAB */ +/* > \verbatim */ +/* > LDAB is INTEGER */ +/* > The leading dimension of the array AB. LDAB >= KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AFB */ +/* > \verbatim */ +/* > AFB is COMPLEX*16 array, dimension (LDAFB,N) */ +/* > Details of the LU factorization of the band matrix A, as */ +/* > computed by ZGBTRF. U is stored as an upper triangular */ +/* > band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, */ +/* > and the multipliers used during the factorization are stored */ +/* > in rows KL+KU+2 to 2*KL+KU+1. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAFB */ +/* > \verbatim */ +/* > LDAFB is INTEGER */ +/* > The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GBcomputational */ + +/* ===================================================================== */ +doublereal zla_gbrpvgrw_(integer *n, integer *kl, integer *ku, integer * + ncols, doublecomplex *ab, integer *ldab, doublecomplex *afb, integer * + ldafb) +{ + /* System generated locals */ + integer ab_dim1, ab_offset, afb_dim1, afb_offset, i__1, i__2, i__3, i__4; + doublereal ret_val, d__1, d__2, d__3; + + /* Local variables */ + doublereal amax, umax; + integer i__, j, kd; + doublereal rpvgrw; + + +/* -- 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 */ + ab_dim1 = *ldab; + ab_offset = 1 + ab_dim1 * 1; + ab -= ab_offset; + afb_dim1 = *ldafb; + afb_offset = 1 + afb_dim1 * 1; + afb -= afb_offset; + + /* Function Body */ + rpvgrw = 1.; + kd = *ku + 1; + i__1 = *ncols; + for (j = 1; j <= i__1; ++j) { + amax = 0.; + umax = 0.; +/* Computing MAX */ + i__2 = j - *ku; +/* Computing MIN */ + i__4 = j + *kl; + i__3 = f2cmin(i__4,*n); + for (i__ = f2cmax(i__2,1); i__ <= i__3; ++i__) { +/* Computing MAX */ + i__2 = kd + i__ - j + j * ab_dim1; + d__3 = (d__1 = ab[i__2].r, abs(d__1)) + (d__2 = d_imag(&ab[kd + + i__ - j + j * ab_dim1]), abs(d__2)); + amax = f2cmax(d__3,amax); + } +/* Computing MAX */ + i__3 = j - *ku; + i__2 = j; + for (i__ = f2cmax(i__3,1); i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = kd + i__ - j + j * afb_dim1; + d__3 = (d__1 = afb[i__3].r, abs(d__1)) + (d__2 = d_imag(&afb[kd + + i__ - j + j * afb_dim1]), abs(d__2)); + umax = f2cmax(d__3,umax); + } + if (umax != 0.) { +/* Computing MIN */ + d__1 = amax / umax; + rpvgrw = f2cmin(d__1,rpvgrw); + } + } + ret_val = rpvgrw; + return ret_val; +} /* zla_gbrpvgrw__ */ + diff --git a/lapack-netlib/SRC/zla_geamv.c b/lapack-netlib/SRC/zla_geamv.c new file mode 100644 index 000000000..a9c43e00d --- /dev/null +++ b/lapack-netlib/SRC/zla_geamv.c @@ -0,0 +1,800 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_GEAMV computes a matrix-vector product using a general matrix to calculate error bounds. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_GEAMV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLA_GEAMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, */ +/* Y, INCY ) */ + +/* DOUBLE PRECISION ALPHA, BETA */ +/* INTEGER INCX, INCY, LDA, M, N */ +/* INTEGER TRANS */ +/* COMPLEX*16 A( LDA, * ), X( * ) */ +/* DOUBLE PRECISION Y( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLA_GEAMV performs one of the matrix-vector operations */ +/* > */ +/* > y := alpha*abs(A)*abs(x) + beta*abs(y), */ +/* > or y := alpha*abs(A)**T*abs(x) + beta*abs(y), */ +/* > */ +/* > where alpha and beta are scalars, x and y are vectors and A is an */ +/* > m by n matrix. */ +/* > */ +/* > This function is primarily used in calculating error bounds. */ +/* > To protect against underflow during evaluation, components in */ +/* > the resulting vector are perturbed away from zero by (N+1) */ +/* > times the underflow threshold. To prevent unnecessarily large */ +/* > errors for block-structure embedded in general matrices, */ +/* > "symbolically" zero components are not perturbed. A zero */ +/* > entry is considered "symbolic" if all multiplications involved */ +/* > in computing that entry have at least one zero multiplicand. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] TRANS */ +/* > \verbatim */ +/* > TRANS is INTEGER */ +/* > On entry, TRANS specifies the operation to be performed as */ +/* > follows: */ +/* > */ +/* > BLAS_NO_TRANS y := alpha*abs(A)*abs(x) + beta*abs(y) */ +/* > BLAS_TRANS y := alpha*abs(A**T)*abs(x) + beta*abs(y) */ +/* > BLAS_CONJ_TRANS y := alpha*abs(A**T)*abs(x) + beta*abs(y) */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > On entry, M specifies the number of rows of the matrix A. */ +/* > 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 the matrix A. */ +/* > 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. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension ( LDA, n ) */ +/* > Before entry, the leading m by n part of the array A must */ +/* > contain the matrix of coefficients. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > On entry, LDA specifies the first dimension of A as declared */ +/* > in the calling (sub) program. LDA must be at least */ +/* > f2cmax( 1, m ). */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension at least */ +/* > ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */ +/* > and at least */ +/* > ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */ +/* > Before entry, the incremented array X must contain the */ +/* > vector x. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > On entry, INCX specifies the increment for the elements of */ +/* > X. INCX must not be zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION */ +/* > On entry, BETA specifies the scalar beta. When BETA is */ +/* > supplied as zero then Y need not be set on input. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is DOUBLE PRECISION array, dimension */ +/* > ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */ +/* > and at least */ +/* > ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */ +/* > Before entry with BETA non-zero, the incremented array Y */ +/* > must contain the vector y. On exit, Y is overwritten by the */ +/* > updated vector y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCY */ +/* > \verbatim */ +/* > INCY is INTEGER */ +/* > On entry, INCY specifies the increment for the elements of */ +/* > Y. INCY must not be zero. */ +/* > Unchanged on exit. */ +/* > */ +/* > Level 2 Blas routine. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup complex16GEcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zla_geamv_(integer *trans, integer *m, integer *n, + doublereal *alpha, doublecomplex *a, integer *lda, doublecomplex *x, + integer *incx, doublereal *beta, doublereal *y, integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1, d__2; + + /* Local variables */ + integer info; + doublereal temp; + integer lenx, leny; + extern integer ilatrans_(char *); + doublereal safe1; + integer i__, j; + logical symb_zero__; + extern doublereal dlamch_(char *); + integer iy, jx, kx, ky; + 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; + --x; + --y; + + /* Function Body */ + info = 0; + if (! (*trans == ilatrans_("N") || *trans == ilatrans_("T") || *trans == ilatrans_("C"))) { + info = 1; + } else if (*m < 0) { + info = 2; + } else if (*n < 0) { + info = 3; + } else if (*lda < f2cmax(1,*m)) { + info = 6; + } else if (*incx == 0) { + info = 8; + } else if (*incy == 0) { + info = 11; + } + if (info != 0) { + xerbla_("ZLA_GEAMV ", &info, (ftnlen)10); + return 0; + } + +/* Quick return if possible. */ + + if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) { + return 0; + } + +/* Set LENX and LENY, the lengths of the vectors x and y, and set */ +/* up the start points in X and Y. */ + + if (*trans == ilatrans_("N")) { + lenx = *n; + leny = *m; + } else { + lenx = *m; + leny = *n; + } + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (lenx - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (leny - 1) * *incy; + } + +/* Set SAFE1 essentially to be the underflow threshold times the */ +/* number of additions in each row. */ + + safe1 = dlamch_("Safe minimum"); + safe1 = (*n + 1) * safe1; + +/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */ + +/* The O(M*N) SYMB_ZERO tests could be replaced by O(N) queries to */ +/* the inexact flag. Still doesn't help change the iteration order */ +/* to per-column. */ + + iy = ky; + if (*incx == 1) { + if (*trans == ilatrans_("N")) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + if (*alpha != 0.) { + i__2 = lenx; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag( + &a[i__ + j * a_dim1]), abs(d__2)); + i__3 = j; + symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ + i__3].i == 0. || temp == 0.); + i__3 = j; + y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&x[j]), abs(d__2))) * temp; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + if (*alpha != 0.) { + i__2 = lenx; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag( + &a[j + i__ * a_dim1]), abs(d__2)); + i__3 = j; + symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ + i__3].i == 0. || temp == 0.); + i__3 = j; + y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&x[j]), abs(d__2))) * temp; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } + } else { + if (*trans == ilatrans_("N")) { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + if (*alpha != 0.) { + jx = kx; + i__2 = lenx; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag( + &a[i__ + j * a_dim1]), abs(d__2)); + i__3 = jx; + symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ + i__3].i == 0. || temp == 0.); + i__3 = jx; + y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&x[jx]), abs(d__2))) * temp; + jx += *incx; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } else { + i__1 = leny; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + if (*alpha != 0.) { + jx = kx; + i__2 = lenx; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag( + &a[j + i__ * a_dim1]), abs(d__2)); + i__3 = jx; + symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ + i__3].i == 0. || temp == 0.); + i__3 = jx; + y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&x[jx]), abs(d__2))) * temp; + jx += *incx; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } + } + + return 0; + +/* End of ZLA_GEAMV */ + +} /* zla_geamv__ */ + diff --git a/lapack-netlib/SRC/zla_gercond_c.c b/lapack-netlib/SRC/zla_gercond_c.c new file mode 100644 index 000000000..49c906d6f --- /dev/null +++ b/lapack-netlib/SRC/zla_gercond_c.c @@ -0,0 +1,750 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_GERCOND_C computes the infinity norm condition number of op(A)*inv(diag(c)) for general mat +rices. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_GERCOND_C + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLA_GERCOND_C( TRANS, N, A, LDA, AF, */ +/* LDAF, IPIV, C, CAPPLY, */ +/* INFO, WORK, RWORK ) */ + +/* CHARACTER TRANS */ +/* LOGICAL CAPPLY */ +/* INTEGER N, LDA, LDAF, INFO */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ) */ +/* DOUBLE PRECISION C( * ), RWORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLA_GERCOND_C computes the infinity norm condition number of */ +/* > op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector. */ +/* > \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 number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the N-by-N matrix A */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is COMPLEX*16 array, dimension (LDAF,N) */ +/* > The factors L and U from the factorization */ +/* > A = P*L*U as computed by ZGETRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices from the factorization A = P*L*U */ +/* > as computed by ZGETRF; row i of the matrix was interchanged */ +/* > with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N) */ +/* > The vector C in the formula op(A) * inv(diag(C)). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CAPPLY */ +/* > \verbatim */ +/* > CAPPLY is LOGICAL */ +/* > If .TRUE. then access the vector C in the formula above. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > i > 0: The ith argument is invalid. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N). */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (N). */ +/* > Workspace. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GEcomputational */ + +/* ===================================================================== */ +doublereal zla_gercond_c_(char *trans, integer *n, doublecomplex *a, integer + *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublereal * + c__, logical *capply, integer *info, doublecomplex *work, doublereal * + rwork) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4; + doublereal ret_val, d__1, d__2; + doublecomplex z__1; + + /* Local variables */ + integer kase, i__, j; + extern logical lsame_(char *, char *); + integer isave[3]; + doublereal anorm; + extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *, + doublecomplex *, doublereal *, integer *, integer *), xerbla_( + char *, integer *, ftnlen); + doublereal ainvnm; + extern /* Subroutine */ int zgetrs_(char *, integer *, integer *, + doublecomplex *, integer *, integer *, doublecomplex *, integer *, + integer *); + doublereal tmp; + logical 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 */ + + +/* ===================================================================== */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --ipiv; + --c__; + --work; + --rwork; + + /* Function Body */ + ret_val = 0.; + + *info = 0; + notrans = lsame_(trans, "N"); + if (! notrans && ! lsame_(trans, "T") && ! lsame_( + trans, "C")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*ldaf < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLA_GERCOND_C", &i__1, (ftnlen)13); + return ret_val; + } + +/* Compute norm of op(A)*op2(C). */ + + anorm = 0.; + if (notrans) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + if (*capply) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + i__ + j * a_dim1]), abs(d__2))) / c__[j]; + } + } else { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + i__ + j * a_dim1]), abs(d__2)); + } + } + rwork[i__] = tmp; + anorm = f2cmax(anorm,tmp); + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + if (*capply) { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + j + i__ * a_dim1]), abs(d__2))) / c__[j]; + } + } else { + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + j + i__ * a_dim1]), abs(d__2)); + } + } + rwork[i__] = tmp; + anorm = f2cmax(anorm,tmp); + } + } + +/* Quick return if possible. */ + + if (*n == 0) { + ret_val = 1.; + return ret_val; + } else if (anorm == 0.) { + return ret_val; + } + +/* Estimate the norm of inv(op(A)). */ + + ainvnm = 0.; + + kase = 0; +L10: + zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == 2) { + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + + if (notrans) { + zgetrs_("No transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[ + 1], &work[1], n, info); + } else { + zgetrs_("Conjugate transpose", n, &c__1, &af[af_offset], ldaf, + &ipiv[1], &work[1], n, info); + } + +/* Multiply by inv(C). */ + + if (*capply) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = c__[i__4] * work[i__3].r, z__1.i = c__[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } + } else { + +/* Multiply by inv(C**H). */ + + if (*capply) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = c__[i__4] * work[i__3].r, z__1.i = c__[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } + + if (notrans) { + zgetrs_("Conjugate transpose", n, &c__1, &af[af_offset], ldaf, + &ipiv[1], &work[1], n, info); + } else { + zgetrs_("No transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[ + 1], &work[1], n, info); + } + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + ret_val = 1. / ainvnm; + } + + return ret_val; + +} /* zla_gercond_c__ */ + diff --git a/lapack-netlib/SRC/zla_gercond_x.c b/lapack-netlib/SRC/zla_gercond_x.c new file mode 100644 index 000000000..2c2814d0c --- /dev/null +++ b/lapack-netlib/SRC/zla_gercond_x.c @@ -0,0 +1,723 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_GERCOND_X computes the infinity norm condition number of op(A)*diag(x) for general matrices +. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_GERCOND_X + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLA_GERCOND_X( TRANS, N, A, LDA, AF, */ +/* LDAF, IPIV, X, INFO, */ +/* WORK, RWORK ) */ + +/* CHARACTER TRANS */ +/* INTEGER N, LDA, LDAF, INFO */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) */ +/* DOUBLE PRECISION RWORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLA_GERCOND_X computes the infinity norm condition number of */ +/* > op(A) * diag(X) where X is a COMPLEX*16 vector. */ +/* > \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 number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the N-by-N matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is COMPLEX*16 array, dimension (LDAF,N) */ +/* > The factors L and U from the factorization */ +/* > A = P*L*U as computed by ZGETRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices from the factorization A = P*L*U */ +/* > as computed by ZGETRF; row i of the matrix was interchanged */ +/* > with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (N) */ +/* > The vector X in the formula op(A) * diag(X). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > i > 0: The ith argument is invalid. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N). */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (N). */ +/* > Workspace. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16GEcomputational */ + +/* ===================================================================== */ +doublereal zla_gercond_x_(char *trans, integer *n, doublecomplex *a, integer + *lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublecomplex * + x, integer *info, doublecomplex *work, doublereal *rwork) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4; + doublereal ret_val, d__1, d__2; + doublecomplex z__1, z__2; + + /* Local variables */ + integer kase, i__, j; + extern logical lsame_(char *, char *); + integer isave[3]; + doublereal anorm; + extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *, + doublecomplex *, doublereal *, integer *, integer *), xerbla_( + char *, integer *, ftnlen); + doublereal ainvnm; + extern /* Subroutine */ int zgetrs_(char *, integer *, integer *, + doublecomplex *, integer *, integer *, doublecomplex *, integer *, + integer *); + doublereal tmp; + logical 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 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --ipiv; + --x; + --work; + --rwork; + + /* Function Body */ + ret_val = 0.; + + *info = 0; + notrans = lsame_(trans, "N"); + if (! notrans && ! lsame_(trans, "T") && ! lsame_( + trans, "C")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*ldaf < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLA_GERCOND_X", &i__1, (ftnlen)13); + return ret_val; + } + +/* Compute norm of op(A)*op2(C). */ + + anorm = 0.; + if (notrans) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + i__4 = j; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i, + z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4] + .r; + z__1.r = z__2.r, z__1.i = z__2.i; + tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), + abs(d__2)); + } + rwork[i__] = tmp; + anorm = f2cmax(anorm,tmp); + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + i__2 = *n; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + i__4 = j; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i, + z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4] + .r; + z__1.r = z__2.r, z__1.i = z__2.i; + tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), + abs(d__2)); + } + rwork[i__] = tmp; + anorm = f2cmax(anorm,tmp); + } + } + +/* Quick return if possible. */ + + if (*n == 0) { + ret_val = 1.; + return ret_val; + } else if (anorm == 0.) { + return ret_val; + } + +/* Estimate the norm of inv(op(A)). */ + + ainvnm = 0.; + + kase = 0; +L10: + zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == 2) { +/* Multiply by R. */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + + if (notrans) { + zgetrs_("No transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[ + 1], &work[1], n, info); + } else { + zgetrs_("Conjugate transpose", n, &c__1, &af[af_offset], ldaf, + &ipiv[1], &work[1], n, info); + } + +/* Multiply by inv(X). */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + z_div(&z__1, &work[i__], &x[i__]); + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } else { + +/* Multiply by inv(X**H). */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + z_div(&z__1, &work[i__], &x[i__]); + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + + if (notrans) { + zgetrs_("Conjugate transpose", n, &c__1, &af[af_offset], ldaf, + &ipiv[1], &work[1], n, info); + } else { + zgetrs_("No transpose", n, &c__1, &af[af_offset], ldaf, &ipiv[ + 1], &work[1], n, info); + } + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + ret_val = 1. / ainvnm; + } + + return ret_val; + +} /* zla_gercond_x__ */ + diff --git a/lapack-netlib/SRC/zla_gerfsx_extended.c b/lapack-netlib/SRC/zla_gerfsx_extended.c new file mode 100644 index 000000000..819e5dab5 --- /dev/null +++ b/lapack-netlib/SRC/zla_gerfsx_extended.c @@ -0,0 +1,1131 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_GERFSX_EXTENDED */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_GERFSX_EXTENDED + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLA_GERFSX_EXTENDED( PREC_TYPE, TRANS_TYPE, N, NRHS, A, */ +/* LDA, AF, LDAF, IPIV, COLEQU, C, B, */ +/* LDB, Y, LDY, BERR_OUT, N_NORMS, */ +/* ERRS_N, ERRS_C, RES, AYB, DY, */ +/* Y_TAIL, RCOND, ITHRESH, RTHRESH, */ +/* DZ_UB, IGNORE_CWISE, INFO ) */ + +/* INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, */ +/* $ TRANS_TYPE, N_NORMS */ +/* LOGICAL COLEQU, IGNORE_CWISE */ +/* INTEGER ITHRESH */ +/* DOUBLE PRECISION RTHRESH, DZ_UB */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), */ +/* $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) */ +/* DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ), */ +/* $ ERRS_N( NRHS, * ), ERRS_C( NRHS, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLA_GERFSX_EXTENDED improves the computed solution to a system of */ +/* > linear equations by performing extra-precise iterative refinement */ +/* > and provides error bounds and backward error estimates for the solution. */ +/* > This subroutine is called by ZGERFSX to perform iterative refinement. */ +/* > In addition to normwise error bound, the code provides maximum */ +/* > componentwise error bound if possible. See comments for ERRS_N */ +/* > and ERRS_C for details of the error bounds. Note that this */ +/* > subroutine is only resonsible for setting the second fields of */ +/* > ERRS_N and ERRS_C. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] PREC_TYPE */ +/* > \verbatim */ +/* > PREC_TYPE is INTEGER */ +/* > Specifies the intermediate precision to be used in refinement. */ +/* > The value is defined by ILAPREC(P) where P is a CHARACTER and P */ +/* > = 'S': Single */ +/* > = 'D': Double */ +/* > = 'I': Indigenous */ +/* > = 'X' or 'E': Extra */ +/* > \endverbatim */ +/* > */ +/* > \param[in] TRANS_TYPE */ +/* > \verbatim */ +/* > TRANS_TYPE is INTEGER */ +/* > Specifies the transposition operation on A. */ +/* > The value is defined by ILATRANS(T) where T is a CHARACTER and T */ +/* > = 'N': No transpose */ +/* > = 'T': Transpose */ +/* > = 'C': Conjugate transpose */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right-hand-sides, i.e., the number of columns of the */ +/* > matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the N-by-N matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is COMPLEX*16 array, dimension (LDAF,N) */ +/* > The factors L and U from the factorization */ +/* > A = P*L*U as computed by ZGETRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > The pivot indices from the factorization A = P*L*U */ +/* > as computed by ZGETRF; row i of the matrix was interchanged */ +/* > with row IPIV(i). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COLEQU */ +/* > \verbatim */ +/* > COLEQU is LOGICAL */ +/* > If .TRUE. then column equilibration was done to A before calling */ +/* > this routine. This is needed to compute the solution and error */ +/* > bounds correctly. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N) */ +/* > The column scale factors for A. If COLEQU = .FALSE., C */ +/* > is not accessed. 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 COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > The right-hand-side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is COMPLEX*16 array, dimension (LDY,NRHS) */ +/* > On entry, the solution matrix X, as computed by ZGETRS. */ +/* > On exit, the improved solution matrix Y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDY */ +/* > \verbatim */ +/* > LDY is INTEGER */ +/* > The leading dimension of the array Y. LDY >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR_OUT */ +/* > \verbatim */ +/* > BERR_OUT is DOUBLE PRECISION array, dimension (NRHS) */ +/* > On exit, BERR_OUT(j) contains the componentwise relative backward */ +/* > error for right-hand-side j from the formula */ +/* > f2cmax(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* > where abs(Z) is the componentwise absolute value of the matrix */ +/* > or vector Z. This is computed by ZLA_LIN_BERR. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N_NORMS */ +/* > \verbatim */ +/* > N_NORMS is INTEGER */ +/* > Determines which error bounds to return (see ERRS_N */ +/* > and ERRS_C). */ +/* > If N_NORMS >= 1 return normwise error bounds. */ +/* > If N_NORMS >= 2 return componentwise error bounds. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ERRS_N */ +/* > \verbatim */ +/* > ERRS_N is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > normwise relative error, which is defined as follows: */ +/* > */ +/* > Normwise relative error in the ith solution vector: */ +/* > max_j (abs(XTRUE(j,i) - X(j,i))) */ +/* > ------------------------------ */ +/* > max_j abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the type of error information as described */ +/* > below. There currently are up to three pieces of information */ +/* > returned. */ +/* > */ +/* > The first index in ERRS_N(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERRS_N(:,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. */ +/* > */ +/* > This subroutine is only responsible for setting the second field */ +/* > above. */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ERRS_C */ +/* > \verbatim */ +/* > ERRS_C is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > componentwise relative error, which is defined as follows: */ +/* > */ +/* > Componentwise relative error in the ith solution vector: */ +/* > abs(XTRUE(j,i) - X(j,i)) */ +/* > max_j ---------------------- */ +/* > abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the right-hand side i (on which the */ +/* > componentwise relative error depends), and the type of error */ +/* > information as described below. There currently are up to three */ +/* > pieces of information returned for each right-hand side. If */ +/* > componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ +/* > ERRS_C is not accessed. If N_ERR_BNDS < 3, then at most */ +/* > the first (:,N_ERR_BNDS) entries are returned. */ +/* > */ +/* > The first index in ERRS_C(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERRS_C(:,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. */ +/* > */ +/* > This subroutine is only responsible for setting the second field */ +/* > above. */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RES */ +/* > \verbatim */ +/* > RES is COMPLEX*16 array, dimension (N) */ +/* > Workspace to hold the intermediate residual. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AYB */ +/* > \verbatim */ +/* > AYB is DOUBLE PRECISION array, dimension (N) */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DY */ +/* > \verbatim */ +/* > DY is COMPLEX*16 array, dimension (N) */ +/* > Workspace to hold the intermediate solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Y_TAIL */ +/* > \verbatim */ +/* > Y_TAIL is COMPLEX*16 array, dimension (N) */ +/* > Workspace to hold the trailing bits of the intermediate solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > Reciprocal scaled condition number. This is an estimate of the */ +/* > reciprocal Skeel condition number of the matrix A after */ +/* > equilibration (if done). If this is less than the machine */ +/* > precision (in particular, if it is zero), the matrix is singular */ +/* > to working precision. Note that the error may still be small even */ +/* > if this number is very small and the matrix appears ill- */ +/* > conditioned. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ITHRESH */ +/* > \verbatim */ +/* > ITHRESH is INTEGER */ +/* > The maximum number of residual computations allowed for */ +/* > refinement. The default is 10. For '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 */ +/* > ERRS_N and ERRS_C may no longer be trustworthy. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RTHRESH */ +/* > \verbatim */ +/* > RTHRESH is DOUBLE PRECISION */ +/* > Determines when to stop refinement if the error estimate stops */ +/* > decreasing. Refinement will stop when the next solution no longer */ +/* > satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */ +/* > the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */ +/* > default value is 0.5. For 'aggressive' set to 0.9 to permit */ +/* > convergence on extremely ill-conditioned matrices. See LAWN 165 */ +/* > for more details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DZ_UB */ +/* > \verbatim */ +/* > DZ_UB is DOUBLE PRECISION */ +/* > Determines when to start considering componentwise convergence. */ +/* > Componentwise convergence is only considered after each component */ +/* > of the solution Y is stable, which we definte as the relative */ +/* > change in each component being less than DZ_UB. The default value */ +/* > is 0.25, requiring the first bit to be stable. See LAWN 165 for */ +/* > more details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IGNORE_CWISE */ +/* > \verbatim */ +/* > IGNORE_CWISE is LOGICAL */ +/* > If .TRUE. then ignore componentwise convergence. Default value */ +/* > is .FALSE.. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > < 0: if INFO = -i, the ith argument to ZGETRS had an illegal */ +/* > value */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup complex16GEcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zla_gerfsx_extended_(integer *prec_type__, integer * + trans_type__, integer *n, integer *nrhs, doublecomplex *a, integer * + lda, doublecomplex *af, integer *ldaf, integer *ipiv, logical *colequ, + doublereal *c__, doublecomplex *b, integer *ldb, doublecomplex *y, + integer *ldy, doublereal *berr_out__, integer *n_norms__, doublereal * + errs_n__, doublereal *errs_c__, doublecomplex *res, doublereal *ayb, + doublecomplex *dy, doublecomplex *y_tail__, doublereal *rcond, + integer *ithresh, doublereal *rthresh, doublereal *dz_ub__, logical * + ignore_cwise__, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1, + y_offset, errs_n_dim1, errs_n_offset, errs_c_dim1, errs_c_offset, + i__1, i__2, i__3, i__4; + doublereal d__1, d__2; + char ch__1[1]; + + /* Local variables */ + doublereal dx_x__, dz_z__, ymin; + extern /* Subroutine */ int zla_lin_berr_(integer *, integer *, integer * + , doublecomplex *, doublereal *, doublereal *); + doublereal dxratmax, dzratmax; + extern /* Subroutine */ int blas_zgemv_x_(integer *, integer *, integer * + , doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *, integer *) + ; + integer y_prec_state__, i__, j; + extern /* Subroutine */ int blas_zgemv2_x_(integer *, integer *, integer + *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *); + doublereal dxrat; + logical incr_prec__; + doublereal dzrat; + extern /* Subroutine */ int zla_geamv_(integer *, integer *, integer *, + doublereal *, doublecomplex *, integer *, doublecomplex *, + integer *, doublereal *, doublereal *, integer *); + char trans[1]; + extern /* Subroutine */ int zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + doublereal normx, normy; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *); + doublereal myhugeval, prev_dz_z__; + extern doublereal dlamch_(char *); + doublereal yk, final_dx_x__, final_dz_z__, normdx; + extern /* Subroutine */ int zgetrs_(char *, integer *, integer *, + doublecomplex *, integer *, integer *, doublecomplex *, integer *, + integer *), zla_wwaddw_(integer *, doublecomplex *, + doublecomplex *, doublecomplex *); + extern /* Character */ VOID chla_transtype_(char *, integer *); + doublereal prevnormdx; + integer cnt; + doublereal dyk, eps; + integer x_state__, z_state__; + doublereal incr_thresh__; + + +/* -- 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 */ + errs_c_dim1 = *nrhs; + errs_c_offset = 1 + errs_c_dim1 * 1; + errs_c__ -= errs_c_offset; + errs_n_dim1 = *nrhs; + errs_n_offset = 1 + errs_n_dim1 * 1; + errs_n__ -= errs_n_offset; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --ipiv; + --c__; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + y -= y_offset; + --berr_out__; + --res; + --ayb; + --dy; + --y_tail__; + + /* Function Body */ + if (*info != 0) { + return 0; + } + chla_transtype_(ch__1, trans_type__); + *(unsigned char *)trans = *(unsigned char *)&ch__1[0]; + eps = dlamch_("Epsilon"); + myhugeval = dlamch_("Overflow"); +/* Force MYHUGEVAL to Inf */ + myhugeval *= myhugeval; +/* Using MYHUGEVAL may lead to spurious underflows. */ + incr_thresh__ = (doublereal) (*n) * eps; + + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + y_prec_state__ = 1; + if (y_prec_state__ == 2) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + y_tail__[i__3].r = 0., y_tail__[i__3].i = 0.; + } + } + dxrat = 0.; + dxratmax = 0.; + dzrat = 0.; + dzratmax = 0.; + final_dx_x__ = myhugeval; + final_dz_z__ = myhugeval; + prevnormdx = myhugeval; + prev_dz_z__ = myhugeval; + dz_z__ = myhugeval; + dx_x__ = myhugeval; + x_state__ = 1; + z_state__ = 0; + incr_prec__ = FALSE_; + i__2 = *ithresh; + for (cnt = 1; cnt <= i__2; ++cnt) { + +/* Compute residual RES = B_s - op(A_s) * Y, */ +/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ + + zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + if (y_prec_state__ == 0) { + zgemv_(trans, n, n, &c_b6, &a[a_offset], lda, &y[j * y_dim1 + + 1], &c__1, &c_b8, &res[1], &c__1); + } else if (y_prec_state__ == 1) { + blas_zgemv_x__(trans_type__, n, n, &c_b6, &a[a_offset], lda, & + y[j * y_dim1 + 1], &c__1, &c_b8, &res[1], &c__1, + prec_type__); + } else { + blas_zgemv2_x__(trans_type__, n, n, &c_b6, &a[a_offset], lda, + &y[j * y_dim1 + 1], &y_tail__[1], &c__1, &c_b8, &res[ + 1], &c__1, prec_type__); + } +/* XXX: RES is no longer needed. */ + zcopy_(n, &res[1], &c__1, &dy[1], &c__1); + zgetrs_(trans, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &dy[1], + n, info); + +/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */ + + normx = 0.; + normy = 0.; + normdx = 0.; + dz_z__ = 0.; + ymin = myhugeval; + + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * y_dim1; + yk = (d__1 = y[i__4].r, abs(d__1)) + (d__2 = d_imag(&y[i__ + + j * y_dim1]), abs(d__2)); + i__4 = i__; + dyk = (d__1 = dy[i__4].r, abs(d__1)) + (d__2 = d_imag(&dy[i__] + ), abs(d__2)); + if (yk != 0.) { +/* Computing MAX */ + d__1 = dz_z__, d__2 = dyk / yk; + dz_z__ = f2cmax(d__1,d__2); + } else if (dyk != 0.) { + dz_z__ = myhugeval; + } + ymin = f2cmin(ymin,yk); + normy = f2cmax(normy,yk); + if (*colequ) { +/* Computing MAX */ + d__1 = normx, d__2 = yk * c__[i__]; + normx = f2cmax(d__1,d__2); +/* Computing MAX */ + d__1 = normdx, d__2 = dyk * c__[i__]; + normdx = f2cmax(d__1,d__2); + } else { + normx = normy; + normdx = f2cmax(normdx,dyk); + } + } + if (normx != 0.) { + dx_x__ = normdx / normx; + } else if (normdx == 0.) { + dx_x__ = 0.; + } else { + dx_x__ = myhugeval; + } + dxrat = normdx / prevnormdx; + dzrat = dz_z__ / prev_dz_z__; + +/* Check termination criteria */ + + if (! (*ignore_cwise__) && ymin * *rcond < incr_thresh__ * normy + && y_prec_state__ < 2) { + incr_prec__ = TRUE_; + } + if (x_state__ == 3 && dxrat <= *rthresh) { + x_state__ = 1; + } + if (x_state__ == 1) { + if (dx_x__ <= eps) { + x_state__ = 2; + } else if (dxrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = TRUE_; + } else { + x_state__ = 3; + } + } else { + if (dxrat > dxratmax) { + dxratmax = dxrat; + } + } + if (x_state__ > 1) { + final_dx_x__ = dx_x__; + } + } + if (z_state__ == 0 && dz_z__ <= *dz_ub__) { + z_state__ = 1; + } + if (z_state__ == 3 && dzrat <= *rthresh) { + z_state__ = 1; + } + if (z_state__ == 1) { + if (dz_z__ <= eps) { + z_state__ = 2; + } else if (dz_z__ > *dz_ub__) { + z_state__ = 0; + dzratmax = 0.; + final_dz_z__ = myhugeval; + } else if (dzrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = TRUE_; + } else { + z_state__ = 3; + } + } else { + if (dzrat > dzratmax) { + dzratmax = dzrat; + } + } + if (z_state__ > 1) { + final_dz_z__ = dz_z__; + } + } + +/* Exit if both normwise and componentwise stopped working, */ +/* but if componentwise is unstable, let it go at least two */ +/* iterations. */ + + if (x_state__ != 1) { + if (*ignore_cwise__) { + goto L666; + } + if (z_state__ == 3 || z_state__ == 2) { + goto L666; + } + if (z_state__ == 0 && cnt > 1) { + goto L666; + } + } + if (incr_prec__) { + incr_prec__ = FALSE_; + ++y_prec_state__; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + y_tail__[i__4].r = 0., y_tail__[i__4].i = 0.; + } + } + prevnormdx = normdx; + prev_dz_z__ = dz_z__; + +/* Update soluton. */ + + if (y_prec_state__ < 2) { + zaxpy_(n, &c_b8, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1); + } else { + zla_wwaddw_(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]); + } + } +/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't CALL MYEXIT. */ +L666: + +/* Set final_* when cnt hits ithresh */ + + if (x_state__ == 1) { + final_dx_x__ = dx_x__; + } + if (z_state__ == 1) { + final_dz_z__ = dz_z__; + } + +/* Compute error bounds */ + + if (*n_norms__ >= 1) { + errs_n__[j + (errs_n_dim1 << 1)] = final_dx_x__ / (1 - dxratmax); + } + if (*n_norms__ >= 2) { + errs_c__[j + (errs_c_dim1 << 1)] = final_dz_z__ / (1 - dzratmax); + } + +/* Compute componentwise relative backward error from formula */ +/* f2cmax(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. */ + +/* Compute residual RES = B_s - op(A_s) * Y, */ +/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ + + zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + zgemv_(trans, n, n, &c_b6, &a[a_offset], lda, &y[j * y_dim1 + 1], & + c__1, &c_b8, &res[1], &c__1); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + ayb[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__ + + j * b_dim1]), abs(d__2)); + } + +/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */ + + zla_geamv_(trans_type__, n, n, &c_b31, &a[a_offset], lda, &y[j * + y_dim1 + 1], &c__1, &c_b31, &ayb[1], &c__1); + zla_lin_berr_(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]); + +/* End of loop for each RHS. */ + + } + + return 0; +} /* zla_gerfsx_extended__ */ + diff --git a/lapack-netlib/SRC/zla_gerpvgrw.c b/lapack-netlib/SRC/zla_gerpvgrw.c new file mode 100644 index 000000000..c8c541ab6 --- /dev/null +++ b/lapack-netlib/SRC/zla_gerpvgrw.c @@ -0,0 +1,548 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_GERPVGRW multiplies a square real matrix by a complex matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_GERPVGRW + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLA_GERPVGRW( N, NCOLS, A, LDA, AF, */ +/* LDAF ) */ + +/* INTEGER N, NCOLS, LDA, LDAF */ +/* COMPLEX*16 A( LDA, * ), AF( LDAF, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > */ +/* > ZLA_GERPVGRW computes the reciprocal pivot growth factor */ +/* > norm(A)/norm(U). The "f2cmax absolute element" norm is used. If this is */ +/* > much less than 1, 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. */ +/* > \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] NCOLS */ +/* > \verbatim */ +/* > NCOLS is INTEGER */ +/* > The number of columns of the matrix A. NCOLS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the N-by-N matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is COMPLEX*16 array, dimension (LDAF,N) */ +/* > The factors L and U from the factorization */ +/* > A = P*L*U as computed by ZGETRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16GEcomputational */ + +/* ===================================================================== */ +doublereal zla_gerpvgrw_(integer *n, integer *ncols, doublecomplex *a, + integer *lda, doublecomplex *af, integer *ldaf) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3; + doublereal ret_val, d__1, d__2, d__3; + + /* Local variables */ + doublereal amax, umax; + integer i__, j; + doublereal rpvgrw; + + +/* -- 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; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + + /* Function Body */ + rpvgrw = 1.; + i__1 = *ncols; + for (j = 1; j <= i__1; ++j) { + amax = 0.; + umax = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ + j * a_dim1; + d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + j * + a_dim1]), abs(d__2)); + amax = f2cmax(d__3,amax); + } + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ + j * af_dim1; + d__3 = (d__1 = af[i__3].r, abs(d__1)) + (d__2 = d_imag(&af[i__ + + j * af_dim1]), abs(d__2)); + umax = f2cmax(d__3,umax); + } + if (umax != 0.) { +/* Computing MIN */ + d__1 = amax / umax; + rpvgrw = f2cmin(d__1,rpvgrw); + } + } + ret_val = rpvgrw; + return ret_val; +} /* zla_gerpvgrw__ */ + diff --git a/lapack-netlib/SRC/zla_heamv.c b/lapack-netlib/SRC/zla_heamv.c new file mode 100644 index 000000000..38c14bd35 --- /dev/null +++ b/lapack-netlib/SRC/zla_heamv.c @@ -0,0 +1,843 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_HEAMV computes a matrix-vector product using a Hermitian indefinite matrix to calculate err +or bounds. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_HEAMV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLA_HEAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, */ +/* INCY ) */ + +/* DOUBLE PRECISION ALPHA, BETA */ +/* INTEGER INCX, INCY, LDA, N, UPLO */ +/* COMPLEX*16 A( LDA, * ), X( * ) */ +/* DOUBLE PRECISION Y( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLA_SYAMV performs the matrix-vector operation */ +/* > */ +/* > y := alpha*abs(A)*abs(x) + beta*abs(y), */ +/* > */ +/* > where alpha and beta are scalars, x and y are vectors and A is an */ +/* > n by n symmetric matrix. */ +/* > */ +/* > This function is primarily used in calculating error bounds. */ +/* > To protect against underflow during evaluation, components in */ +/* > the resulting vector are perturbed away from zero by (N+1) */ +/* > times the underflow threshold. To prevent unnecessarily large */ +/* > errors for block-structure embedded in general matrices, */ +/* > "symbolically" zero components are not perturbed. A zero */ +/* > entry is considered "symbolic" if all multiplications involved */ +/* > in computing that entry have at least one zero multiplicand. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is INTEGER */ +/* > On entry, UPLO specifies whether the upper or lower */ +/* > triangular part of the array A is to be referenced as */ +/* > follows: */ +/* > */ +/* > UPLO = BLAS_UPPER Only the upper triangular part of A */ +/* > is to be referenced. */ +/* > */ +/* > UPLO = BLAS_LOWER Only the lower triangular part of A */ +/* > is to be referenced. */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > On entry, N specifies the number of columns of the matrix A. */ +/* > 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. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension ( LDA, n ). */ +/* > Before entry, the leading m by n part of the array A must */ +/* > contain the matrix of coefficients. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > On entry, LDA specifies the first dimension of A as declared */ +/* > in the calling (sub) program. LDA must be at least */ +/* > f2cmax( 1, n ). */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension at least */ +/* > ( 1 + ( n - 1 )*abs( INCX ) ) */ +/* > Before entry, the incremented array X must contain the */ +/* > vector x. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > On entry, INCX specifies the increment for the elements of */ +/* > X. INCX must not be zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION . */ +/* > On entry, BETA specifies the scalar beta. When BETA is */ +/* > supplied as zero then Y need not be set on input. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is DOUBLE PRECISION array, dimension */ +/* > ( 1 + ( n - 1 )*abs( INCY ) ) */ +/* > Before entry with BETA non-zero, the incremented array Y */ +/* > must contain the vector y. On exit, Y is overwritten by the */ +/* > updated vector y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCY */ +/* > \verbatim */ +/* > INCY is INTEGER */ +/* > On entry, INCY specifies the increment for the elements of */ +/* > Y. INCY must not be zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup complex16HEcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Level 2 Blas routine. */ +/* > */ +/* > -- Written on 22-October-1986. */ +/* > Jack Dongarra, Argonne National Lab. */ +/* > Jeremy Du Croz, Nag Central Office. */ +/* > Sven Hammarling, Nag Central Office. */ +/* > Richard Hanson, Sandia National Labs. */ +/* > -- Modified for the absolute-value product, April 2006 */ +/* > Jason Riedy, UC Berkeley */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zla_heamv_(integer *uplo, integer *n, doublereal *alpha, + doublecomplex *a, integer *lda, doublecomplex *x, integer *incx, + doublereal *beta, doublereal *y, integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1, d__2; + + /* Local variables */ + integer info; + doublereal temp, safe1; + integer i__, j; + logical symb_zero__; + extern doublereal dlamch_(char *); + integer iy, jx, kx, ky; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilauplo_(char *); + + +/* -- 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; + --x; + --y; + + /* Function Body */ + info = 0; + if (*uplo != ilauplo_("U") && *uplo != ilauplo_("L") + ) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*lda < f2cmax(1,*n)) { + info = 5; + } else if (*incx == 0) { + info = 7; + } else if (*incy == 0) { + info = 10; + } + if (info != 0) { + xerbla_("ZHEMV ", &info, (ftnlen)6); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0. && *beta == 1.) { + return 0; + } + +/* Set up the start points in X and Y. */ + + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + +/* Set SAFE1 essentially to be the underflow threshold times the */ +/* number of additions in each row. */ + + safe1 = dlamch_("Safe minimum"); + safe1 = (*n + 1) * safe1; + +/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */ + +/* The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to */ +/* the inexact flag. Still doesn't help change the iteration order */ +/* to per-column. */ + + iy = ky; + if (*incx == 1) { + if (*uplo == ilauplo_("U")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + if (*alpha != 0.) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag( + &a[j + i__ * a_dim1]), abs(d__2)); + i__3 = j; + symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ + i__3].i == 0. || temp == 0.); + i__3 = j; + y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&x[j]), abs(d__2))) * temp; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag( + &a[i__ + j * a_dim1]), abs(d__2)); + i__3 = j; + symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ + i__3].i == 0. || temp == 0.); + i__3 = j; + y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&x[j]), abs(d__2))) * temp; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + if (*alpha != 0.) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag( + &a[i__ + j * a_dim1]), abs(d__2)); + i__3 = j; + symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ + i__3].i == 0. || temp == 0.); + i__3 = j; + y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&x[j]), abs(d__2))) * temp; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag( + &a[j + i__ * a_dim1]), abs(d__2)); + i__3 = j; + symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ + i__3].i == 0. || temp == 0.); + i__3 = j; + y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&x[j]), abs(d__2))) * temp; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } + } else { + if (*uplo == ilauplo_("U")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + jx = kx; + if (*alpha != 0.) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag( + &a[j + i__ * a_dim1]), abs(d__2)); + i__3 = j; + symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ + i__3].i == 0. || temp == 0.); + i__3 = jx; + y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&x[jx]), abs(d__2))) * temp; + jx += *incx; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag( + &a[i__ + j * a_dim1]), abs(d__2)); + i__3 = j; + symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ + i__3].i == 0. || temp == 0.); + i__3 = jx; + y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&x[jx]), abs(d__2))) * temp; + jx += *incx; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + jx = kx; + if (*alpha != 0.) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag( + &a[i__ + j * a_dim1]), abs(d__2)); + i__3 = j; + symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ + i__3].i == 0. || temp == 0.); + i__3 = jx; + y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&x[jx]), abs(d__2))) * temp; + jx += *incx; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag( + &a[j + i__ * a_dim1]), abs(d__2)); + i__3 = j; + symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ + i__3].i == 0. || temp == 0.); + i__3 = jx; + y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&x[jx]), abs(d__2))) * temp; + jx += *incx; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } + } + + return 0; + +/* End of ZLA_HEAMV */ + +} /* zla_heamv__ */ + diff --git a/lapack-netlib/SRC/zla_hercond_c.c b/lapack-netlib/SRC/zla_hercond_c.c new file mode 100644 index 000000000..62b18e95d --- /dev/null +++ b/lapack-netlib/SRC/zla_hercond_c.c @@ -0,0 +1,776 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_HERCOND_C computes the infinity norm condition number of op(A)*inv(diag(c)) for Hermitian i +ndefinite matrices. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_HERCOND_C + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLA_HERCOND_C( UPLO, N, A, LDA, AF, */ +/* LDAF, IPIV, C, CAPPLY, */ +/* INFO, WORK, RWORK ) */ + +/* CHARACTER UPLO */ +/* LOGICAL CAPPLY */ +/* INTEGER N, LDA, LDAF, INFO */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ) */ +/* DOUBLE PRECISION C ( * ), RWORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLA_HERCOND_C computes the infinity norm condition number of */ +/* > op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the N-by-N matrix A */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is COMPLEX*16 array, dimension (LDAF,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by ZHETRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by CHETRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N) */ +/* > The vector C in the formula op(A) * inv(diag(C)). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CAPPLY */ +/* > \verbatim */ +/* > CAPPLY is LOGICAL */ +/* > If .TRUE. then access the vector C in the formula above. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > i > 0: The ith argument is invalid. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N). */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (N). */ +/* > Workspace. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16HEcomputational */ + +/* ===================================================================== */ +doublereal zla_hercond_c_(char *uplo, integer *n, doublecomplex *a, integer * + lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublereal *c__, + logical *capply, integer *info, doublecomplex *work, doublereal * + rwork) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4; + doublereal ret_val, d__1, d__2; + doublecomplex z__1; + + /* Local variables */ + integer kase, i__, j; + extern logical lsame_(char *, char *); + integer isave[3]; + doublereal anorm; + logical upper; + extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *, + doublecomplex *, doublereal *, integer *, integer *); + logical up; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal ainvnm; + extern /* Subroutine */ int zhetrs_(char *, integer *, integer *, + doublecomplex *, integer *, integer *, doublecomplex *, integer *, + integer *); + doublereal tmp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --ipiv; + --c__; + --work; + --rwork; + + /* Function Body */ + ret_val = 0.; + + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*ldaf < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLA_HERCOND_C", &i__1, (ftnlen)13); + return ret_val; + } + up = FALSE_; + if (lsame_(uplo, "U")) { + up = TRUE_; + } + +/* Compute norm of op(A)*op2(C). */ + + anorm = 0.; + if (up) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + if (*capply) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + j + i__ * a_dim1]), abs(d__2))) / c__[j]; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + i__ + j * a_dim1]), abs(d__2))) / c__[j]; + } + } else { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + j + i__ * a_dim1]), abs(d__2)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + i__ + j * a_dim1]), abs(d__2)); + } + } + rwork[i__] = tmp; + anorm = f2cmax(anorm,tmp); + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + if (*capply) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + i__ + j * a_dim1]), abs(d__2))) / c__[j]; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + j + i__ * a_dim1]), abs(d__2))) / c__[j]; + } + } else { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + i__ + j * a_dim1]), abs(d__2)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + j + i__ * a_dim1]), abs(d__2)); + } + } + rwork[i__] = tmp; + anorm = f2cmax(anorm,tmp); + } + } + +/* Quick return if possible. */ + + if (*n == 0) { + ret_val = 1.; + return ret_val; + } else if (anorm == 0.) { + return ret_val; + } + +/* Estimate the norm of inv(op(A)). */ + + ainvnm = 0.; + + kase = 0; +L10: + zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == 2) { + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + + if (up) { + zhetrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } else { + zhetrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } + +/* Multiply by inv(C). */ + + if (*capply) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = c__[i__4] * work[i__3].r, z__1.i = c__[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } + } else { + +/* Multiply by inv(C**H). */ + + if (*capply) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = c__[i__4] * work[i__3].r, z__1.i = c__[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } + + if (up) { + zhetrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } else { + zhetrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + ret_val = 1. / ainvnm; + } + + return ret_val; + +} /* zla_hercond_c__ */ + diff --git a/lapack-netlib/SRC/zla_hercond_x.c b/lapack-netlib/SRC/zla_hercond_x.c new file mode 100644 index 000000000..8ee4d0e63 --- /dev/null +++ b/lapack-netlib/SRC/zla_hercond_x.c @@ -0,0 +1,748 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_HERCOND_X computes the infinity norm condition number of op(A)*diag(x) for Hermitian indefi +nite matrices. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_HERCOND_X + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLA_HERCOND_X( UPLO, N, A, LDA, AF, */ +/* LDAF, IPIV, X, INFO, */ +/* WORK, RWORK ) */ + +/* CHARACTER UPLO */ +/* INTEGER N, LDA, LDAF, INFO */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) */ +/* DOUBLE PRECISION RWORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLA_HERCOND_X computes the infinity norm condition number of */ +/* > op(A) * diag(X) where X is a COMPLEX*16 vector. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the N-by-N matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is COMPLEX*16 array, dimension (LDAF,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by ZHETRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by CHETRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (N) */ +/* > The vector X in the formula op(A) * diag(X). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > i > 0: The ith argument is invalid. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N). */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (N). */ +/* > Workspace. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16HEcomputational */ + +/* ===================================================================== */ +doublereal zla_hercond_x_(char *uplo, integer *n, doublecomplex *a, integer * + lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublecomplex * + x, integer *info, doublecomplex *work, doublereal *rwork) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4; + doublereal ret_val, d__1, d__2; + doublecomplex z__1, z__2; + + /* Local variables */ + integer kase, i__, j; + extern logical lsame_(char *, char *); + integer isave[3]; + doublereal anorm; + logical upper; + extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *, + doublecomplex *, doublereal *, integer *, integer *); + logical up; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal ainvnm; + extern /* Subroutine */ int zhetrs_(char *, integer *, integer *, + doublecomplex *, integer *, integer *, doublecomplex *, integer *, + integer *); + doublereal tmp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --ipiv; + --x; + --work; + --rwork; + + /* Function Body */ + ret_val = 0.; + + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*ldaf < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLA_HERCOND_X", &i__1, (ftnlen)13); + return ret_val; + } + up = FALSE_; + if (lsame_(uplo, "U")) { + up = TRUE_; + } + +/* Compute norm of op(A)*op2(C). */ + + anorm = 0.; + if (up) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + i__4 = j; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i, + z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4] + .r; + z__1.r = z__2.r, z__1.i = z__2.i; + tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), + abs(d__2)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + i__4 = j; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i, + z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4] + .r; + z__1.r = z__2.r, z__1.i = z__2.i; + tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), + abs(d__2)); + } + rwork[i__] = tmp; + anorm = f2cmax(anorm,tmp); + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + i__4 = j; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i, + z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4] + .r; + z__1.r = z__2.r, z__1.i = z__2.i; + tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), + abs(d__2)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + i__4 = j; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i, + z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4] + .r; + z__1.r = z__2.r, z__1.i = z__2.i; + tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), + abs(d__2)); + } + rwork[i__] = tmp; + anorm = f2cmax(anorm,tmp); + } + } + +/* Quick return if possible. */ + + if (*n == 0) { + ret_val = 1.; + return ret_val; + } else if (anorm == 0.) { + return ret_val; + } + +/* Estimate the norm of inv(op(A)). */ + + ainvnm = 0.; + + kase = 0; +L10: + zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == 2) { + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + + if (up) { + zhetrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } else { + zhetrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } + +/* Multiply by inv(X). */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + z_div(&z__1, &work[i__], &x[i__]); + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } else { + +/* Multiply by inv(X**H). */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + z_div(&z__1, &work[i__], &x[i__]); + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + + if (up) { + zhetrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } else { + zhetrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + ret_val = 1. / ainvnm; + } + + return ret_val; + +} /* zla_hercond_x__ */ + diff --git a/lapack-netlib/SRC/zla_herfsx_extended.c b/lapack-netlib/SRC/zla_herfsx_extended.c new file mode 100644 index 000000000..256b6517f --- /dev/null +++ b/lapack-netlib/SRC/zla_herfsx_extended.c @@ -0,0 +1,1141 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_HERFSX_EXTENDED improves the computed solution to a system of linear equations for Hermitia +n indefinite matrices by performing extra-precise iterative refinement and provides error bounds and b +ackward error estimates for the solution. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_HERFSX_EXTENDED + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLA_HERFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, */ +/* AF, LDAF, IPIV, COLEQU, C, B, LDB, */ +/* Y, LDY, BERR_OUT, N_NORMS, */ +/* ERR_BNDS_NORM, ERR_BNDS_COMP, RES, */ +/* AYB, DY, Y_TAIL, RCOND, ITHRESH, */ +/* RTHRESH, DZ_UB, IGNORE_CWISE, */ +/* INFO ) */ + +/* INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, */ +/* $ N_NORMS, ITHRESH */ +/* CHARACTER UPLO */ +/* LOGICAL COLEQU, IGNORE_CWISE */ +/* DOUBLE PRECISION RTHRESH, DZ_UB */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), */ +/* $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) */ +/* DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ), */ +/* $ ERR_BNDS_NORM( NRHS, * ), */ +/* $ ERR_BNDS_COMP( NRHS, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLA_HERFSX_EXTENDED improves the computed solution to a system of */ +/* > linear equations by performing extra-precise iterative refinement */ +/* > and provides error bounds and backward error estimates for the solution. */ +/* > This subroutine is called by ZHERFSX to perform iterative refinement. */ +/* > 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. Note that this */ +/* > subroutine is only resonsible for setting the second fields of */ +/* > ERR_BNDS_NORM and ERR_BNDS_COMP. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] PREC_TYPE */ +/* > \verbatim */ +/* > PREC_TYPE is INTEGER */ +/* > Specifies the intermediate precision to be used in refinement. */ +/* > The value is defined by ILAPREC(P) where P is a CHARACTER and P */ +/* > = 'S': Single */ +/* > = 'D': Double */ +/* > = 'I': Indigenous */ +/* > = 'X' or 'E': Extra */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right-hand-sides, i.e., the number of columns of the */ +/* > matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the N-by-N matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is COMPLEX*16 array, dimension (LDAF,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by ZHETRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by ZHETRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COLEQU */ +/* > \verbatim */ +/* > COLEQU is LOGICAL */ +/* > If .TRUE. then column equilibration was done to A before calling */ +/* > this routine. This is needed to compute the solution and error */ +/* > bounds correctly. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N) */ +/* > The column scale factors for A. If COLEQU = .FALSE., C */ +/* > is not accessed. 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 COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > The right-hand-side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is COMPLEX*16 array, dimension (LDY,NRHS) */ +/* > On entry, the solution matrix X, as computed by ZHETRS. */ +/* > On exit, the improved solution matrix Y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDY */ +/* > \verbatim */ +/* > LDY is INTEGER */ +/* > The leading dimension of the array Y. LDY >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR_OUT */ +/* > \verbatim */ +/* > BERR_OUT is DOUBLE PRECISION array, dimension (NRHS) */ +/* > On exit, BERR_OUT(j) contains the componentwise relative backward */ +/* > error for right-hand-side j from the formula */ +/* > f2cmax(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* > where abs(Z) is the componentwise absolute value of the matrix */ +/* > or vector Z. This is computed by ZLA_LIN_BERR. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N_NORMS */ +/* > \verbatim */ +/* > N_NORMS is INTEGER */ +/* > Determines which error bounds to return (see ERR_BNDS_NORM */ +/* > and ERR_BNDS_COMP). */ +/* > If N_NORMS >= 1 return normwise error bounds. */ +/* > If N_NORMS >= 2 return componentwise error bounds. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ERR_BNDS_NORM */ +/* > \verbatim */ +/* > ERR_BNDS_NORM is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > normwise relative error, which is defined as follows: */ +/* > */ +/* > Normwise relative error in the ith solution vector: */ +/* > max_j (abs(XTRUE(j,i) - X(j,i))) */ +/* > ------------------------------ */ +/* > max_j abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the type of error information as described */ +/* > below. There currently are up to three pieces of information */ +/* > returned. */ +/* > */ +/* > The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_NORM(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * 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. */ +/* > */ +/* > This subroutine is only responsible for setting the second field */ +/* > above. */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ERR_BNDS_COMP */ +/* > \verbatim */ +/* > ERR_BNDS_COMP is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > componentwise relative error, which is defined as follows: */ +/* > */ +/* > Componentwise relative error in the ith solution vector: */ +/* > abs(XTRUE(j,i) - X(j,i)) */ +/* > max_j ---------------------- */ +/* > abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the right-hand side i (on which the */ +/* > componentwise relative error depends), and the type of error */ +/* > information as described below. There currently are up to three */ +/* > pieces of information returned for each right-hand side. If */ +/* > componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ +/* > ERR_BNDS_COMP is not accessed. If N_ERR_BNDS < 3, then at most */ +/* > the first (:,N_ERR_BNDS) entries are returned. */ +/* > */ +/* > The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_COMP(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * 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. */ +/* > */ +/* > This subroutine is only responsible for setting the second field */ +/* > above. */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RES */ +/* > \verbatim */ +/* > RES is COMPLEX*16 array, dimension (N) */ +/* > Workspace to hold the intermediate residual. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AYB */ +/* > \verbatim */ +/* > AYB is DOUBLE PRECISION array, dimension (N) */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DY */ +/* > \verbatim */ +/* > DY is COMPLEX*16 array, dimension (N) */ +/* > Workspace to hold the intermediate solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Y_TAIL */ +/* > \verbatim */ +/* > Y_TAIL is COMPLEX*16 array, dimension (N) */ +/* > Workspace to hold the trailing bits of the intermediate solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > Reciprocal scaled condition number. This is an estimate of the */ +/* > reciprocal Skeel condition number of the matrix A after */ +/* > equilibration (if done). If this is less than the machine */ +/* > precision (in particular, if it is zero), the matrix is singular */ +/* > to working precision. Note that the error may still be small even */ +/* > if this number is very small and the matrix appears ill- */ +/* > conditioned. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ITHRESH */ +/* > \verbatim */ +/* > ITHRESH is INTEGER */ +/* > The maximum number of residual computations allowed for */ +/* > refinement. The default is 10. For '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. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RTHRESH */ +/* > \verbatim */ +/* > RTHRESH is DOUBLE PRECISION */ +/* > Determines when to stop refinement if the error estimate stops */ +/* > decreasing. Refinement will stop when the next solution no longer */ +/* > satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */ +/* > the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */ +/* > default value is 0.5. For 'aggressive' set to 0.9 to permit */ +/* > convergence on extremely ill-conditioned matrices. See LAWN 165 */ +/* > for more details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DZ_UB */ +/* > \verbatim */ +/* > DZ_UB is DOUBLE PRECISION */ +/* > Determines when to start considering componentwise convergence. */ +/* > Componentwise convergence is only considered after each component */ +/* > of the solution Y is stable, which we definte as the relative */ +/* > change in each component being less than DZ_UB. The default value */ +/* > is 0.25, requiring the first bit to be stable. See LAWN 165 for */ +/* > more details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IGNORE_CWISE */ +/* > \verbatim */ +/* > IGNORE_CWISE is LOGICAL */ +/* > If .TRUE. then ignore componentwise convergence. Default value */ +/* > is .FALSE.. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > < 0: if INFO = -i, the ith argument to ZLA_HERFSX_EXTENDED 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 complex16HEcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zla_herfsx_extended_(integer *prec_type__, char *uplo, + integer *n, integer *nrhs, doublecomplex *a, integer *lda, + doublecomplex *af, integer *ldaf, integer *ipiv, logical *colequ, + doublereal *c__, doublecomplex *b, integer *ldb, doublecomplex *y, + integer *ldy, doublereal *berr_out__, integer *n_norms__, doublereal * + err_bnds_norm__, doublereal *err_bnds_comp__, doublecomplex *res, + doublereal *ayb, doublecomplex *dy, doublecomplex *y_tail__, + doublereal *rcond, integer *ithresh, doublereal *rthresh, doublereal * + dz_ub__, logical *ignore_cwise__, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1, + y_offset, err_bnds_norm_dim1, err_bnds_norm_offset, + err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3, i__4; + doublereal d__1, d__2; + + /* Local variables */ + doublereal dx_x__, dz_z__, ymin; + extern /* Subroutine */ int zla_lin_berr_(integer *, integer *, integer * + , doublecomplex *, doublereal *, doublereal *); + doublereal dxratmax, dzratmax; + integer y_prec_state__; + extern /* Subroutine */ int blas_zhemv_x_(integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *, integer *) + ; + integer uplo2, i__, j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int blas_zhemv2_x_(integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *); + doublereal dxrat; + logical incr_prec__; + doublereal dzrat; + extern /* Subroutine */ int zla_heamv_(integer *, integer *, doublereal * + , doublecomplex *, integer *, doublecomplex *, integer *, + doublereal *, doublereal *, integer *), zhemv_(char *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + logical upper; + doublereal normx, normy; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *); + doublereal myhugeval, prev_dz_z__; + extern doublereal dlamch_(char *); + doublereal yk; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal final_dx_x__, final_dz_z__, normdx; + extern /* Subroutine */ int zhetrs_(char *, integer *, integer *, + doublecomplex *, integer *, integer *, doublecomplex *, integer *, + integer *), zla_wwaddw_(integer *, doublecomplex *, + doublecomplex *, doublecomplex *); + doublereal prevnormdx; + integer cnt; + doublereal dyk, eps; + extern integer ilauplo_(char *); + integer x_state__, z_state__; + doublereal incr_thresh__; + + +/* -- 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 */ + 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; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --ipiv; + --c__; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + y -= y_offset; + --berr_out__; + --res; + --ayb; + --dy; + --y_tail__; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } else if (*ldaf < f2cmax(1,*n)) { + *info = -8; + } else if (*ldb < f2cmax(1,*n)) { + *info = -13; + } else if (*ldy < f2cmax(1,*n)) { + *info = -15; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLA_HERFSX_EXTENDED", &i__1, (ftnlen)19); + return 0; + } + eps = dlamch_("Epsilon"); + myhugeval = dlamch_("Overflow"); +/* Force MYHUGEVAL to Inf */ + myhugeval *= myhugeval; +/* Using MYHUGEVAL may lead to spurious underflows. */ + incr_thresh__ = (doublereal) (*n) * eps; + if (lsame_(uplo, "L")) { + uplo2 = ilauplo_("L"); + } else { + uplo2 = ilauplo_("U"); + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + y_prec_state__ = 1; + if (y_prec_state__ == 2) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + y_tail__[i__3].r = 0., y_tail__[i__3].i = 0.; + } + } + dxrat = 0.; + dxratmax = 0.; + dzrat = 0.; + dzratmax = 0.; + final_dx_x__ = myhugeval; + final_dz_z__ = myhugeval; + prevnormdx = myhugeval; + prev_dz_z__ = myhugeval; + dz_z__ = myhugeval; + dx_x__ = myhugeval; + x_state__ = 1; + z_state__ = 0; + incr_prec__ = FALSE_; + i__2 = *ithresh; + for (cnt = 1; cnt <= i__2; ++cnt) { + +/* Compute residual RES = B_s - op(A_s) * Y, */ +/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ + + zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + if (y_prec_state__ == 0) { + zhemv_(uplo, n, &c_b14, &a[a_offset], lda, &y[j * y_dim1 + 1], + &c__1, &c_b15, &res[1], &c__1); + } else if (y_prec_state__ == 1) { + blas_zhemv_x__(&uplo2, n, &c_b14, &a[a_offset], lda, &y[j * + y_dim1 + 1], &c__1, &c_b15, &res[1], &c__1, + prec_type__); + } else { + blas_zhemv2_x__(&uplo2, n, &c_b14, &a[a_offset], lda, &y[j * + y_dim1 + 1], &y_tail__[1], &c__1, &c_b15, &res[1], & + c__1, prec_type__); + } +/* XXX: RES is no longer needed. */ + zcopy_(n, &res[1], &c__1, &dy[1], &c__1); + zhetrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &dy[1], n, + info); + +/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */ + + normx = 0.; + normy = 0.; + normdx = 0.; + dz_z__ = 0.; + ymin = myhugeval; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * y_dim1; + yk = (d__1 = y[i__4].r, abs(d__1)) + (d__2 = d_imag(&y[i__ + + j * y_dim1]), abs(d__2)); + i__4 = i__; + dyk = (d__1 = dy[i__4].r, abs(d__1)) + (d__2 = d_imag(&dy[i__] + ), abs(d__2)); + if (yk != 0.) { +/* Computing MAX */ + d__1 = dz_z__, d__2 = dyk / yk; + dz_z__ = f2cmax(d__1,d__2); + } else if (dyk != 0.) { + dz_z__ = myhugeval; + } + ymin = f2cmin(ymin,yk); + normy = f2cmax(normy,yk); + if (*colequ) { +/* Computing MAX */ + d__1 = normx, d__2 = yk * c__[i__]; + normx = f2cmax(d__1,d__2); +/* Computing MAX */ + d__1 = normdx, d__2 = dyk * c__[i__]; + normdx = f2cmax(d__1,d__2); + } else { + normx = normy; + normdx = f2cmax(normdx,dyk); + } + } + if (normx != 0.) { + dx_x__ = normdx / normx; + } else if (normdx == 0.) { + dx_x__ = 0.; + } else { + dx_x__ = myhugeval; + } + dxrat = normdx / prevnormdx; + dzrat = dz_z__ / prev_dz_z__; + +/* Check termination criteria. */ + + if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) { + incr_prec__ = TRUE_; + } + if (x_state__ == 3 && dxrat <= *rthresh) { + x_state__ = 1; + } + if (x_state__ == 1) { + if (dx_x__ <= eps) { + x_state__ = 2; + } else if (dxrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = TRUE_; + } else { + x_state__ = 3; + } + } else { + if (dxrat > dxratmax) { + dxratmax = dxrat; + } + } + if (x_state__ > 1) { + final_dx_x__ = dx_x__; + } + } + if (z_state__ == 0 && dz_z__ <= *dz_ub__) { + z_state__ = 1; + } + if (z_state__ == 3 && dzrat <= *rthresh) { + z_state__ = 1; + } + if (z_state__ == 1) { + if (dz_z__ <= eps) { + z_state__ = 2; + } else if (dz_z__ > *dz_ub__) { + z_state__ = 0; + dzratmax = 0.; + final_dz_z__ = myhugeval; + } else if (dzrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = TRUE_; + } else { + z_state__ = 3; + } + } else { + if (dzrat > dzratmax) { + dzratmax = dzrat; + } + } + if (z_state__ > 1) { + final_dz_z__ = dz_z__; + } + } + if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1)) { + goto L666; + } + if (incr_prec__) { + incr_prec__ = FALSE_; + ++y_prec_state__; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + y_tail__[i__4].r = 0., y_tail__[i__4].i = 0.; + } + } + prevnormdx = normdx; + prev_dz_z__ = dz_z__; + +/* Update soluton. */ + + if (y_prec_state__ < 2) { + zaxpy_(n, &c_b15, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1); + } else { + zla_wwaddw_(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]); + } + } +/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't CALL MYEXIT. */ +L666: + +/* Set final_* when cnt hits ithresh. */ + + if (x_state__ == 1) { + final_dx_x__ = dx_x__; + } + if (z_state__ == 1) { + final_dz_z__ = dz_z__; + } + +/* Compute error bounds. */ + + if (*n_norms__ >= 1) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / ( + 1 - dxratmax); + } + if (*n_norms__ >= 2) { + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / ( + 1 - dzratmax); + } + +/* Compute componentwise relative backward error from formula */ +/* f2cmax(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. */ + +/* Compute residual RES = B_s - op(A_s) * Y, */ +/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ + + zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + zhemv_(uplo, n, &c_b14, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1, + &c_b15, &res[1], &c__1); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + ayb[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__ + + j * b_dim1]), abs(d__2)); + } + +/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */ + + zla_heamv_(&uplo2, n, &c_b37, &a[a_offset], lda, &y[j * y_dim1 + 1], + &c__1, &c_b37, &ayb[1], &c__1); + zla_lin_berr_(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]); + +/* End of loop for each RHS. */ + + } + + return 0; +} /* zla_herfsx_extended__ */ + diff --git a/lapack-netlib/SRC/zla_herpvgrw.c b/lapack-netlib/SRC/zla_herpvgrw.c new file mode 100644 index 000000000..8b4ff9715 --- /dev/null +++ b/lapack-netlib/SRC/zla_herpvgrw.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 ZLA_HERPVGRW */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_HERPVGRW + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLA_HERPVGRW( UPLO, N, INFO, A, LDA, AF, */ +/* LDAF, IPIV, WORK ) */ + +/* CHARACTER*1 UPLO */ +/* INTEGER N, INFO, LDA, LDAF */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), AF( LDAF, * ) */ +/* DOUBLE PRECISION WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > */ +/* > ZLA_HERPVGRW computes the reciprocal pivot growth factor */ +/* > norm(A)/norm(U). The "f2cmax absolute element" norm is used. If this is */ +/* > much less than 1, 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. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > The value of INFO returned from ZHETRF, .i.e., the pivot in */ +/* > column INFO is exactly 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the N-by-N matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is COMPLEX*16 array, dimension (LDAF,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by ZHETRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by ZHETRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16HEcomputational */ + +/* ===================================================================== */ +doublereal zla_herpvgrw_(char *uplo, integer *n, integer *info, + doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, + integer *ipiv, doublereal *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3; + doublereal ret_val, d__1, d__2, d__3, d__4; + + /* Local variables */ + doublereal amax, umax; + integer i__, j, k; + extern logical lsame_(char *, char *); + integer ncols; + logical upper; + integer kp; + doublereal rpvgrw, tmp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --ipiv; + --work; + + /* Function Body */ + upper = lsame_("Upper", uplo); + if (*info == 0) { + if (upper) { + ncols = 1; + } else { + ncols = *n; + } + } else { + ncols = *info; + } + rpvgrw = 1.; + i__1 = *n << 1; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + +/* Find the f2cmax magnitude entry of each column of A. Compute the f2cmax */ +/* for all N columns so we can apply the pivot permutation while */ +/* looping below. Assume a full factorization is the common case. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ + j * a_dim1; + d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + + j * a_dim1]), abs(d__2)), d__4 = work[*n + i__]; + work[*n + i__] = f2cmax(d__3,d__4); +/* Computing MAX */ + i__3 = i__ + j * a_dim1; + d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + + j * a_dim1]), abs(d__2)), d__4 = work[*n + j]; + work[*n + j] = f2cmax(d__3,d__4); + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ + j * a_dim1; + d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + + j * a_dim1]), abs(d__2)), d__4 = work[*n + i__]; + work[*n + i__] = f2cmax(d__3,d__4); +/* Computing MAX */ + i__3 = i__ + j * a_dim1; + d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + + j * a_dim1]), abs(d__2)), d__4 = work[*n + j]; + work[*n + j] = f2cmax(d__3,d__4); + } + } + } + +/* Now find the f2cmax magnitude entry of each column of U or L. Also */ +/* permute the magnitudes of A above so they're in the same order as */ +/* the factor. */ + +/* The iteration orders and permutations were copied from zsytrs. */ +/* Calls to SSWAP would be severe overkill. */ + + if (upper) { + k = *n; + while(k < ncols && k > 0) { + if (ipiv[k] > 0) { +/* 1x1 pivot */ + kp = ipiv[k]; + if (kp != k) { + tmp = work[*n + k]; + work[*n + k] = work[*n + kp]; + work[*n + kp] = tmp; + } + i__1 = k; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + i__2 = i__ + k * af_dim1; + d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(& + af[i__ + k * af_dim1]), abs(d__2)), d__4 = work[k] + ; + work[k] = f2cmax(d__3,d__4); + } + --k; + } else { +/* 2x2 pivot */ + kp = -ipiv[k]; + tmp = work[*n + k - 1]; + work[*n + k - 1] = work[*n + kp]; + work[*n + kp] = tmp; + i__1 = k - 1; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + i__2 = i__ + k * af_dim1; + d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(& + af[i__ + k * af_dim1]), abs(d__2)), d__4 = work[k] + ; + work[k] = f2cmax(d__3,d__4); +/* Computing MAX */ + i__2 = i__ + (k - 1) * af_dim1; + d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(& + af[i__ + (k - 1) * af_dim1]), abs(d__2)), d__4 = + work[k - 1]; + work[k - 1] = f2cmax(d__3,d__4); + } +/* Computing MAX */ + i__1 = k + k * af_dim1; + d__3 = (d__1 = af[i__1].r, abs(d__1)) + (d__2 = d_imag(&af[k + + k * af_dim1]), abs(d__2)), d__4 = work[k]; + work[k] = f2cmax(d__3,d__4); + k += -2; + } + } + k = ncols; + while(k <= *n) { + if (ipiv[k] > 0) { + kp = ipiv[k]; + if (kp != k) { + tmp = work[*n + k]; + work[*n + k] = work[*n + kp]; + work[*n + kp] = tmp; + } + ++k; + } else { + kp = -ipiv[k]; + tmp = work[*n + k]; + work[*n + k] = work[*n + kp]; + work[*n + kp] = tmp; + k += 2; + } + } + } else { + k = 1; + while(k <= ncols) { + if (ipiv[k] > 0) { +/* 1x1 pivot */ + kp = ipiv[k]; + if (kp != k) { + tmp = work[*n + k]; + work[*n + k] = work[*n + kp]; + work[*n + kp] = tmp; + } + i__1 = *n; + for (i__ = k; i__ <= i__1; ++i__) { +/* Computing MAX */ + i__2 = i__ + k * af_dim1; + d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(& + af[i__ + k * af_dim1]), abs(d__2)), d__4 = work[k] + ; + work[k] = f2cmax(d__3,d__4); + } + ++k; + } else { +/* 2x2 pivot */ + kp = -ipiv[k]; + tmp = work[*n + k + 1]; + work[*n + k + 1] = work[*n + kp]; + work[*n + kp] = tmp; + i__1 = *n; + for (i__ = k + 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + i__2 = i__ + k * af_dim1; + d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(& + af[i__ + k * af_dim1]), abs(d__2)), d__4 = work[k] + ; + work[k] = f2cmax(d__3,d__4); +/* Computing MAX */ + i__2 = i__ + (k + 1) * af_dim1; + d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(& + af[i__ + (k + 1) * af_dim1]), abs(d__2)), d__4 = + work[k + 1]; + work[k + 1] = f2cmax(d__3,d__4); + } +/* Computing MAX */ + i__1 = k + k * af_dim1; + d__3 = (d__1 = af[i__1].r, abs(d__1)) + (d__2 = d_imag(&af[k + + k * af_dim1]), abs(d__2)), d__4 = work[k]; + work[k] = f2cmax(d__3,d__4); + k += 2; + } + } + k = ncols; + while(k >= 1) { + if (ipiv[k] > 0) { + kp = ipiv[k]; + if (kp != k) { + tmp = work[*n + k]; + work[*n + k] = work[*n + kp]; + work[*n + kp] = tmp; + } + --k; + } else { + kp = -ipiv[k]; + tmp = work[*n + k]; + work[*n + k] = work[*n + kp]; + work[*n + kp] = tmp; + k += -2; + } + } + } + +/* Compute the *inverse* of the f2cmax element growth factor. Dividing */ +/* by zero would imply the largest entry of the factor's column is */ +/* zero. Than can happen when either the column of A is zero or */ +/* massive pivots made the factor underflow to zero. Neither counts */ +/* as growth in itself, so simply ignore terms with zero */ +/* denominators. */ + + if (upper) { + i__1 = *n; + for (i__ = ncols; i__ <= i__1; ++i__) { + umax = work[i__]; + amax = work[*n + i__]; + if (umax != 0.) { +/* Computing MIN */ + d__1 = amax / umax; + rpvgrw = f2cmin(d__1,rpvgrw); + } + } + } else { + i__1 = ncols; + for (i__ = 1; i__ <= i__1; ++i__) { + umax = work[i__]; + amax = work[*n + i__]; + if (umax != 0.) { +/* Computing MIN */ + d__1 = amax / umax; + rpvgrw = f2cmin(d__1,rpvgrw); + } + } + } + ret_val = rpvgrw; + return ret_val; +} /* zla_herpvgrw__ */ + diff --git a/lapack-netlib/SRC/zla_lin_berr.c b/lapack-netlib/SRC/zla_lin_berr.c new file mode 100644 index 000000000..5f671507d --- /dev/null +++ b/lapack-netlib/SRC/zla_lin_berr.c @@ -0,0 +1,556 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_LIN_BERR computes a component-wise relative backward error. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_LIN_BERR + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLA_LIN_BERR ( N, NZ, NRHS, RES, AYB, BERR ) */ + +/* INTEGER N, NZ, NRHS */ +/* DOUBLE PRECISION AYB( N, NRHS ), BERR( NRHS ) */ +/* COMPLEX*16 RES( N, NRHS ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLA_LIN_BERR computes componentwise relative backward error from */ +/* > the formula */ +/* > f2cmax(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* > where abs(Z) is the componentwise absolute value of the matrix */ +/* > or vector Z. */ +/* > \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] NZ */ +/* > \verbatim */ +/* > NZ is INTEGER */ +/* > We add (NZ+1)*SLAMCH( 'Safe minimum' ) to R(i) in the numerator to */ +/* > guard against spuriously zero residuals. Default value is N. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right hand sides, i.e., the number of columns */ +/* > of the matrices AYB, RES, and BERR. NRHS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RES */ +/* > \verbatim */ +/* > RES is COMPLEX*16 array, dimension (N,NRHS) */ +/* > The residual matrix, i.e., the matrix R in the relative backward */ +/* > error formula above. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AYB */ +/* > \verbatim */ +/* > AYB is DOUBLE PRECISION array, dimension (N, NRHS) */ +/* > The denominator in the relative backward error formula above, i.e., */ +/* > the matrix abs(op(A_s))*abs(Y) + abs(B_s). The matrices A, Y, and B */ +/* > are from iterative refinement (see zla_gerfsx_extended.f). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR */ +/* > \verbatim */ +/* > BERR is DOUBLE PRECISION array, dimension (NRHS) */ +/* > The componentwise relative backward error from the formula above. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16OTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zla_lin_berr_(integer *n, integer *nz, integer *nrhs, + doublecomplex *res, doublereal *ayb, doublereal *berr) +{ + /* System generated locals */ + integer ayb_dim1, ayb_offset, res_dim1, res_offset, i__1, i__2, i__3, + i__4; + doublereal d__1, d__2, d__3; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + doublereal safe1; + integer i__, j; + extern doublereal dlamch_(char *); + doublereal tmp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2016 */ + + +/* ===================================================================== */ + + +/* Adding SAFE1 to the numerator guards against spuriously zero */ +/* residuals. A similar safeguard is in the CLA_yyAMV routine used */ +/* to compute AYB. */ + + /* Parameter adjustments */ + --berr; + ayb_dim1 = *n; + ayb_offset = 1 + ayb_dim1 * 1; + ayb -= ayb_offset; + res_dim1 = *n; + res_offset = 1 + res_dim1 * 1; + res -= res_offset; + + /* Function Body */ + safe1 = dlamch_("Safe minimum"); + safe1 = (*nz + 1) * safe1; + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + berr[j] = 0.; + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + if (ayb[i__ + j * ayb_dim1] != 0.) { + i__3 = i__ + j * res_dim1; + d__3 = (d__1 = res[i__3].r, abs(d__1)) + (d__2 = d_imag(&res[ + i__ + j * res_dim1]), abs(d__2)); + z__3.r = d__3, z__3.i = 0.; + z__2.r = safe1 + z__3.r, z__2.i = z__3.i; + i__4 = i__ + j * ayb_dim1; + z__1.r = z__2.r / ayb[i__4], z__1.i = z__2.i / ayb[i__4]; + tmp = z__1.r; +/* Computing MAX */ + d__1 = berr[j]; + berr[j] = f2cmax(d__1,tmp); + } + +/* If AYB is exactly 0.0 (and if computed by CLA_yyAMV), then we know */ +/* the true residual also must be exactly 0.0. */ + + } + } + return 0; +} /* zla_lin_berr__ */ + diff --git a/lapack-netlib/SRC/zla_porcond_c.c b/lapack-netlib/SRC/zla_porcond_c.c new file mode 100644 index 000000000..e8b099e2d --- /dev/null +++ b/lapack-netlib/SRC/zla_porcond_c.c @@ -0,0 +1,765 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_PORCOND_C computes the infinity norm condition number of op(A)*inv(diag(c)) for Hermitian p +ositive-definite matrices. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_PORCOND_C + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLA_PORCOND_C( UPLO, N, A, LDA, AF, */ +/* LDAF, C, CAPPLY, INFO, */ +/* WORK, RWORK ) */ + +/* CHARACTER UPLO */ +/* LOGICAL CAPPLY */ +/* INTEGER N, LDA, LDAF, INFO */ +/* COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ) */ +/* DOUBLE PRECISION C( * ), RWORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLA_PORCOND_C Computes the infinity norm condition number of */ +/* > op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the N-by-N matrix A */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is COMPLEX*16 array, dimension (LDAF,N) */ +/* > The triangular factor U or L from the Cholesky factorization */ +/* > A = U**H*U or A = L*L**H, as computed by ZPOTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N) */ +/* > The vector C in the formula op(A) * inv(diag(C)). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CAPPLY */ +/* > \verbatim */ +/* > CAPPLY is LOGICAL */ +/* > If .TRUE. then access the vector C in the formula above. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > i > 0: The ith argument is invalid. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N). */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (N). */ +/* > Workspace. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16POcomputational */ + +/* ===================================================================== */ +doublereal zla_porcond_c_(char *uplo, integer *n, doublecomplex *a, integer * + lda, doublecomplex *af, integer *ldaf, doublereal *c__, logical * + capply, integer *info, doublecomplex *work, doublereal *rwork) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4; + doublereal ret_val, d__1, d__2; + doublecomplex z__1; + + /* Local variables */ + integer kase, i__, j; + extern logical lsame_(char *, char *); + integer isave[3]; + doublereal anorm; + logical upper; + extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *, + doublecomplex *, doublereal *, integer *, integer *); + logical up; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal ainvnm; + extern /* Subroutine */ int zpotrs_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *); + doublereal tmp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --c__; + --work; + --rwork; + + /* Function Body */ + ret_val = 0.; + + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*ldaf < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLA_PORCOND_C", &i__1, (ftnlen)13); + return ret_val; + } + up = FALSE_; + if (lsame_(uplo, "U")) { + up = TRUE_; + } + +/* Compute norm of op(A)*op2(C). */ + + anorm = 0.; + if (up) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + if (*capply) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + j + i__ * a_dim1]), abs(d__2))) / c__[j]; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + i__ + j * a_dim1]), abs(d__2))) / c__[j]; + } + } else { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + j + i__ * a_dim1]), abs(d__2)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + i__ + j * a_dim1]), abs(d__2)); + } + } + rwork[i__] = tmp; + anorm = f2cmax(anorm,tmp); + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + if (*capply) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + i__ + j * a_dim1]), abs(d__2))) / c__[j]; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + j + i__ * a_dim1]), abs(d__2))) / c__[j]; + } + } else { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + i__ + j * a_dim1]), abs(d__2)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + j + i__ * a_dim1]), abs(d__2)); + } + } + rwork[i__] = tmp; + anorm = f2cmax(anorm,tmp); + } + } + +/* Quick return if possible. */ + + if (*n == 0) { + ret_val = 1.; + return ret_val; + } else if (anorm == 0.) { + return ret_val; + } + +/* Estimate the norm of inv(op(A)). */ + + ainvnm = 0.; + + kase = 0; +L10: + zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == 2) { + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + + if (up) { + zpotrs_("U", n, &c__1, &af[af_offset], ldaf, &work[1], n, + info); + } else { + zpotrs_("L", n, &c__1, &af[af_offset], ldaf, &work[1], n, + info); + } + +/* Multiply by inv(C). */ + + if (*capply) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = c__[i__4] * work[i__3].r, z__1.i = c__[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } + } else { + +/* Multiply by inv(C**H). */ + + if (*capply) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = c__[i__4] * work[i__3].r, z__1.i = c__[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } + + if (up) { + zpotrs_("U", n, &c__1, &af[af_offset], ldaf, &work[1], n, + info); + } else { + zpotrs_("L", n, &c__1, &af[af_offset], ldaf, &work[1], n, + info); + } + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + ret_val = 1. / ainvnm; + } + + return ret_val; + +} /* zla_porcond_c__ */ + diff --git a/lapack-netlib/SRC/zla_porcond_x.c b/lapack-netlib/SRC/zla_porcond_x.c new file mode 100644 index 000000000..2ad4b2b52 --- /dev/null +++ b/lapack-netlib/SRC/zla_porcond_x.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 ZLA_PORCOND_X computes the infinity norm condition number of op(A)*diag(x) for Hermitian positi +ve-definite matrices. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_PORCOND_X + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLA_PORCOND_X( UPLO, N, A, LDA, AF, */ +/* LDAF, X, INFO, WORK, */ +/* RWORK ) */ + +/* CHARACTER UPLO */ +/* INTEGER N, LDA, LDAF, INFO */ +/* COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) */ +/* DOUBLE PRECISION RWORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLA_PORCOND_X Computes the infinity norm condition number of */ +/* > op(A) * diag(X) where X is a COMPLEX*16 vector. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the N-by-N matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is COMPLEX*16 array, dimension (LDAF,N) */ +/* > The triangular factor U or L from the Cholesky factorization */ +/* > A = U**H*U or A = L*L**H, as computed by ZPOTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (N) */ +/* > The vector X in the formula op(A) * diag(X). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > i > 0: The ith argument is invalid. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N). */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (N). */ +/* > Workspace. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16POcomputational */ + +/* ===================================================================== */ +doublereal zla_porcond_x_(char *uplo, integer *n, doublecomplex *a, integer * + lda, doublecomplex *af, integer *ldaf, doublecomplex *x, integer * + info, doublecomplex *work, doublereal *rwork) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4; + doublereal ret_val, d__1, d__2; + doublecomplex z__1, z__2; + + /* Local variables */ + integer kase, i__, j; + extern logical lsame_(char *, char *); + integer isave[3]; + doublereal anorm; + logical upper; + extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *, + doublecomplex *, doublereal *, integer *, integer *); + logical up; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal ainvnm; + extern /* Subroutine */ int zpotrs_(char *, integer *, integer *, + doublecomplex *, integer *, doublecomplex *, integer *, integer *); + doublereal tmp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --x; + --work; + --rwork; + + /* Function Body */ + ret_val = 0.; + + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*ldaf < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLA_PORCOND_X", &i__1, (ftnlen)13); + return ret_val; + } + up = FALSE_; + if (lsame_(uplo, "U")) { + up = TRUE_; + } + +/* Compute norm of op(A)*op2(C). */ + + anorm = 0.; + if (up) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + i__4 = j; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i, + z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4] + .r; + z__1.r = z__2.r, z__1.i = z__2.i; + tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), + abs(d__2)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + i__4 = j; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i, + z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4] + .r; + z__1.r = z__2.r, z__1.i = z__2.i; + tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), + abs(d__2)); + } + rwork[i__] = tmp; + anorm = f2cmax(anorm,tmp); + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + i__4 = j; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i, + z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4] + .r; + z__1.r = z__2.r, z__1.i = z__2.i; + tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), + abs(d__2)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + i__4 = j; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i, + z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4] + .r; + z__1.r = z__2.r, z__1.i = z__2.i; + tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), + abs(d__2)); + } + rwork[i__] = tmp; + anorm = f2cmax(anorm,tmp); + } + } + +/* Quick return if possible. */ + + if (*n == 0) { + ret_val = 1.; + return ret_val; + } else if (anorm == 0.) { + return ret_val; + } + +/* Estimate the norm of inv(op(A)). */ + + ainvnm = 0.; + + kase = 0; +L10: + zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == 2) { + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + + if (up) { + zpotrs_("U", n, &c__1, &af[af_offset], ldaf, &work[1], n, + info); + } else { + zpotrs_("L", n, &c__1, &af[af_offset], ldaf, &work[1], n, + info); + } + +/* Multiply by inv(X). */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + z_div(&z__1, &work[i__], &x[i__]); + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } else { + +/* Multiply by inv(X**H). */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + z_div(&z__1, &work[i__], &x[i__]); + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + + if (up) { + zpotrs_("U", n, &c__1, &af[af_offset], ldaf, &work[1], n, + info); + } else { + zpotrs_("L", n, &c__1, &af[af_offset], ldaf, &work[1], n, + info); + } + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + ret_val = 1. / ainvnm; + } + + return ret_val; + +} /* zla_porcond_x__ */ + diff --git a/lapack-netlib/SRC/zla_porfsx_extended.c b/lapack-netlib/SRC/zla_porfsx_extended.c new file mode 100644 index 000000000..6a00bd909 --- /dev/null +++ b/lapack-netlib/SRC/zla_porfsx_extended.c @@ -0,0 +1,1110 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_PORFSX_EXTENDED improves the computed solution to a system of linear equations for symmetri +c or Hermitian positive-definite matrices by performing extra-precise iterative refinement and provide +s error bounds and backward error estimates fo */ +/* r the solution. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_PORFSX_EXTENDED + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLA_PORFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, */ +/* AF, LDAF, COLEQU, C, B, LDB, Y, */ +/* LDY, BERR_OUT, N_NORMS, */ +/* ERR_BNDS_NORM, ERR_BNDS_COMP, RES, */ +/* AYB, DY, Y_TAIL, RCOND, ITHRESH, */ +/* RTHRESH, DZ_UB, IGNORE_CWISE, */ +/* INFO ) */ + +/* INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, */ +/* $ N_NORMS, ITHRESH */ +/* CHARACTER UPLO */ +/* LOGICAL COLEQU, IGNORE_CWISE */ +/* DOUBLE PRECISION RTHRESH, DZ_UB */ +/* COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), */ +/* $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) */ +/* DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ), */ +/* $ ERR_BNDS_NORM( NRHS, * ), */ +/* $ ERR_BNDS_COMP( NRHS, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLA_PORFSX_EXTENDED improves the computed solution to a system of */ +/* > linear equations by performing extra-precise iterative refinement */ +/* > and provides error bounds and backward error estimates for the solution. */ +/* > This subroutine is called by ZPORFSX to perform iterative refinement. */ +/* > 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. Note that this */ +/* > subroutine is only resonsible for setting the second fields of */ +/* > ERR_BNDS_NORM and ERR_BNDS_COMP. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] PREC_TYPE */ +/* > \verbatim */ +/* > PREC_TYPE is INTEGER */ +/* > Specifies the intermediate precision to be used in refinement. */ +/* > The value is defined by ILAPREC(P) where P is a CHARACTER and P */ +/* > = 'S': Single */ +/* > = 'D': Double */ +/* > = 'I': Indigenous */ +/* > = 'X' or 'E': Extra */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right-hand-sides, i.e., the number of columns of the */ +/* > matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the N-by-N matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is COMPLEX*16 array, dimension (LDAF,N) */ +/* > The triangular factor U or L from the Cholesky factorization */ +/* > A = U**T*U or A = L*L**T, as computed by ZPOTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COLEQU */ +/* > \verbatim */ +/* > COLEQU is LOGICAL */ +/* > If .TRUE. then column equilibration was done to A before calling */ +/* > this routine. This is needed to compute the solution and error */ +/* > bounds correctly. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N) */ +/* > The column scale factors for A. If COLEQU = .FALSE., C */ +/* > is not accessed. 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 COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > The right-hand-side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is COMPLEX*16 array, dimension (LDY,NRHS) */ +/* > On entry, the solution matrix X, as computed by ZPOTRS. */ +/* > On exit, the improved solution matrix Y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDY */ +/* > \verbatim */ +/* > LDY is INTEGER */ +/* > The leading dimension of the array Y. LDY >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR_OUT */ +/* > \verbatim */ +/* > BERR_OUT is DOUBLE PRECISION array, dimension (NRHS) */ +/* > On exit, BERR_OUT(j) contains the componentwise relative backward */ +/* > error for right-hand-side j from the formula */ +/* > f2cmax(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* > where abs(Z) is the componentwise absolute value of the matrix */ +/* > or vector Z. This is computed by ZLA_LIN_BERR. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N_NORMS */ +/* > \verbatim */ +/* > N_NORMS is INTEGER */ +/* > Determines which error bounds to return (see ERR_BNDS_NORM */ +/* > and ERR_BNDS_COMP). */ +/* > If N_NORMS >= 1 return normwise error bounds. */ +/* > If N_NORMS >= 2 return componentwise error bounds. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ERR_BNDS_NORM */ +/* > \verbatim */ +/* > ERR_BNDS_NORM is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > normwise relative error, which is defined as follows: */ +/* > */ +/* > Normwise relative error in the ith solution vector: */ +/* > max_j (abs(XTRUE(j,i) - X(j,i))) */ +/* > ------------------------------ */ +/* > max_j abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the type of error information as described */ +/* > below. There currently are up to three pieces of information */ +/* > returned. */ +/* > */ +/* > The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_NORM(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * 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. */ +/* > */ +/* > This subroutine is only responsible for setting the second field */ +/* > above. */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ERR_BNDS_COMP */ +/* > \verbatim */ +/* > ERR_BNDS_COMP is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > componentwise relative error, which is defined as follows: */ +/* > */ +/* > Componentwise relative error in the ith solution vector: */ +/* > abs(XTRUE(j,i) - X(j,i)) */ +/* > max_j ---------------------- */ +/* > abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the right-hand side i (on which the */ +/* > componentwise relative error depends), and the type of error */ +/* > information as described below. There currently are up to three */ +/* > pieces of information returned for each right-hand side. If */ +/* > componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ +/* > ERR_BNDS_COMP is not accessed. If N_ERR_BNDS < 3, then at most */ +/* > the first (:,N_ERR_BNDS) entries are returned. */ +/* > */ +/* > The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_COMP(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * 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. */ +/* > */ +/* > This subroutine is only responsible for setting the second field */ +/* > above. */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RES */ +/* > \verbatim */ +/* > RES is COMPLEX*16 array, dimension (N) */ +/* > Workspace to hold the intermediate residual. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AYB */ +/* > \verbatim */ +/* > AYB is DOUBLE PRECISION array, dimension (N) */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DY */ +/* > \verbatim */ +/* > DY is COMPLEX*16 PRECISION array, dimension (N) */ +/* > Workspace to hold the intermediate solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Y_TAIL */ +/* > \verbatim */ +/* > Y_TAIL is COMPLEX*16 array, dimension (N) */ +/* > Workspace to hold the trailing bits of the intermediate solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > Reciprocal scaled condition number. This is an estimate of the */ +/* > reciprocal Skeel condition number of the matrix A after */ +/* > equilibration (if done). If this is less than the machine */ +/* > precision (in particular, if it is zero), the matrix is singular */ +/* > to working precision. Note that the error may still be small even */ +/* > if this number is very small and the matrix appears ill- */ +/* > conditioned. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ITHRESH */ +/* > \verbatim */ +/* > ITHRESH is INTEGER */ +/* > The maximum number of residual computations allowed for */ +/* > refinement. The default is 10. For '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. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RTHRESH */ +/* > \verbatim */ +/* > RTHRESH is DOUBLE PRECISION */ +/* > Determines when to stop refinement if the error estimate stops */ +/* > decreasing. Refinement will stop when the next solution no longer */ +/* > satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */ +/* > the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */ +/* > default value is 0.5. For 'aggressive' set to 0.9 to permit */ +/* > convergence on extremely ill-conditioned matrices. See LAWN 165 */ +/* > for more details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DZ_UB */ +/* > \verbatim */ +/* > DZ_UB is DOUBLE PRECISION */ +/* > Determines when to start considering componentwise convergence. */ +/* > Componentwise convergence is only considered after each component */ +/* > of the solution Y is stable, which we definte as the relative */ +/* > change in each component being less than DZ_UB. The default value */ +/* > is 0.25, requiring the first bit to be stable. See LAWN 165 for */ +/* > more details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IGNORE_CWISE */ +/* > \verbatim */ +/* > IGNORE_CWISE is LOGICAL */ +/* > If .TRUE. then ignore componentwise convergence. Default value */ +/* > is .FALSE.. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > < 0: if INFO = -i, the ith argument to ZPOTRS 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 complex16POcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zla_porfsx_extended_(integer *prec_type__, char *uplo, + integer *n, integer *nrhs, doublecomplex *a, integer *lda, + doublecomplex *af, integer *ldaf, logical *colequ, doublereal *c__, + doublecomplex *b, integer *ldb, doublecomplex *y, integer *ldy, + doublereal *berr_out__, integer *n_norms__, doublereal * + err_bnds_norm__, doublereal *err_bnds_comp__, doublecomplex *res, + doublereal *ayb, doublecomplex *dy, doublecomplex *y_tail__, + doublereal *rcond, integer *ithresh, doublereal *rthresh, doublereal * + dz_ub__, logical *ignore_cwise__, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1, + y_offset, err_bnds_norm_dim1, err_bnds_norm_offset, + err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3, i__4; + doublereal d__1, d__2; + + /* Local variables */ + doublereal dx_x__, dz_z__, ymin; + extern /* Subroutine */ int zla_lin_berr_(integer *, integer *, integer * + , doublecomplex *, doublereal *, doublereal *); + doublereal dxratmax, dzratmax; + integer y_prec_state__; + extern /* Subroutine */ int blas_zhemv_x_(integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *, integer *) + ; + integer uplo2, i__, j; + extern logical lsame_(char *, char *); + extern /* Subroutine */ int blas_zhemv2_x_(integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *); + doublereal dxrat; + logical incr_prec__; + doublereal dzrat; + extern /* Subroutine */ int zla_heamv_(integer *, integer *, doublereal * + , doublecomplex *, integer *, doublecomplex *, integer *, + doublereal *, doublereal *, integer *), zhemv_(char *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + doublereal normx, normy; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *); + doublereal myhugeval, prev_dz_z__; + extern doublereal dlamch_(char *); + doublereal yk, final_dx_x__, final_dz_z__, normdx; + extern /* Subroutine */ int zla_wwaddw_(integer *, doublecomplex *, + doublecomplex *, doublecomplex *), zpotrs_(char *, integer *, + integer *, doublecomplex *, integer *, doublecomplex *, integer *, + integer *); + doublereal prevnormdx; + integer cnt; + doublereal dyk, eps; + extern integer ilauplo_(char *); + integer x_state__, z_state__; + doublereal incr_thresh__; + + +/* -- 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 */ + 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; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --c__; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + y -= y_offset; + --berr_out__; + --res; + --ayb; + --dy; + --y_tail__; + + /* Function Body */ + if (*info != 0) { + return 0; + } + eps = dlamch_("Epsilon"); + myhugeval = dlamch_("Overflow"); +/* Force MYHUGEVAL to Inf */ + myhugeval *= myhugeval; +/* Using MYHUGEVAL may lead to spurious underflows. */ + incr_thresh__ = (doublereal) (*n) * eps; + if (lsame_(uplo, "L")) { + uplo2 = ilauplo_("L"); + } else { + uplo2 = ilauplo_("U"); + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + y_prec_state__ = 1; + if (y_prec_state__ == 2) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + y_tail__[i__3].r = 0., y_tail__[i__3].i = 0.; + } + } + dxrat = 0.; + dxratmax = 0.; + dzrat = 0.; + dzratmax = 0.; + final_dx_x__ = myhugeval; + final_dz_z__ = myhugeval; + prevnormdx = myhugeval; + prev_dz_z__ = myhugeval; + dz_z__ = myhugeval; + dx_x__ = myhugeval; + x_state__ = 1; + z_state__ = 0; + incr_prec__ = FALSE_; + i__2 = *ithresh; + for (cnt = 1; cnt <= i__2; ++cnt) { + +/* Compute residual RES = B_s - op(A_s) * Y, */ +/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ + + zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + if (y_prec_state__ == 0) { + zhemv_(uplo, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1], + &c__1, &c_b12, &res[1], &c__1); + } else if (y_prec_state__ == 1) { + blas_zhemv_x__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j * + y_dim1 + 1], &c__1, &c_b12, &res[1], &c__1, + prec_type__); + } else { + blas_zhemv2_x__(&uplo2, n, &c_b11, &a[a_offset], lda, &y[j * + y_dim1 + 1], &y_tail__[1], &c__1, &c_b12, &res[1], & + c__1, prec_type__); + } +/* XXX: RES is no longer needed. */ + zcopy_(n, &res[1], &c__1, &dy[1], &c__1); + zpotrs_(uplo, n, &c__1, &af[af_offset], ldaf, &dy[1], n, info); + +/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */ + + normx = 0.; + normy = 0.; + normdx = 0.; + dz_z__ = 0.; + ymin = myhugeval; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * y_dim1; + yk = (d__1 = y[i__4].r, abs(d__1)) + (d__2 = d_imag(&y[i__ + + j * y_dim1]), abs(d__2)); + i__4 = i__; + dyk = (d__1 = dy[i__4].r, abs(d__1)) + (d__2 = d_imag(&dy[i__] + ), abs(d__2)); + if (yk != 0.) { +/* Computing MAX */ + d__1 = dz_z__, d__2 = dyk / yk; + dz_z__ = f2cmax(d__1,d__2); + } else if (dyk != 0.) { + dz_z__ = myhugeval; + } + ymin = f2cmin(ymin,yk); + normy = f2cmax(normy,yk); + if (*colequ) { +/* Computing MAX */ + d__1 = normx, d__2 = yk * c__[i__]; + normx = f2cmax(d__1,d__2); +/* Computing MAX */ + d__1 = normdx, d__2 = dyk * c__[i__]; + normdx = f2cmax(d__1,d__2); + } else { + normx = normy; + normdx = f2cmax(normdx,dyk); + } + } + if (normx != 0.) { + dx_x__ = normdx / normx; + } else if (normdx == 0.) { + dx_x__ = 0.; + } else { + dx_x__ = myhugeval; + } + dxrat = normdx / prevnormdx; + dzrat = dz_z__ / prev_dz_z__; + +/* Check termination criteria. */ + + if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) { + incr_prec__ = TRUE_; + } + if (x_state__ == 3 && dxrat <= *rthresh) { + x_state__ = 1; + } + if (x_state__ == 1) { + if (dx_x__ <= eps) { + x_state__ = 2; + } else if (dxrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = TRUE_; + } else { + x_state__ = 3; + } + } else { + if (dxrat > dxratmax) { + dxratmax = dxrat; + } + } + if (x_state__ > 1) { + final_dx_x__ = dx_x__; + } + } + if (z_state__ == 0 && dz_z__ <= *dz_ub__) { + z_state__ = 1; + } + if (z_state__ == 3 && dzrat <= *rthresh) { + z_state__ = 1; + } + if (z_state__ == 1) { + if (dz_z__ <= eps) { + z_state__ = 2; + } else if (dz_z__ > *dz_ub__) { + z_state__ = 0; + dzratmax = 0.; + final_dz_z__ = myhugeval; + } else if (dzrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = TRUE_; + } else { + z_state__ = 3; + } + } else { + if (dzrat > dzratmax) { + dzratmax = dzrat; + } + } + if (z_state__ > 1) { + final_dz_z__ = dz_z__; + } + } + if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1)) { + goto L666; + } + if (incr_prec__) { + incr_prec__ = FALSE_; + ++y_prec_state__; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + y_tail__[i__4].r = 0., y_tail__[i__4].i = 0.; + } + } + prevnormdx = normdx; + prev_dz_z__ = dz_z__; + +/* Update soluton. */ + + if (y_prec_state__ < 2) { + zaxpy_(n, &c_b12, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1); + } else { + zla_wwaddw_(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]); + } + } +/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't CALL MYEXIT. */ +L666: + +/* Set final_* when cnt hits ithresh. */ + + if (x_state__ == 1) { + final_dx_x__ = dx_x__; + } + if (z_state__ == 1) { + final_dz_z__ = dz_z__; + } + +/* Compute error bounds. */ + + if (*n_norms__ >= 1) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / ( + 1 - dxratmax); + } + if (*n_norms__ >= 2) { + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / ( + 1 - dzratmax); + } + +/* Compute componentwise relative backward error from formula */ +/* f2cmax(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. */ + +/* Compute residual RES = B_s - op(A_s) * Y, */ +/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ + + zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + zhemv_(uplo, n, &c_b11, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1, + &c_b12, &res[1], &c__1); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + ayb[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__ + + j * b_dim1]), abs(d__2)); + } + +/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */ + + zla_heamv_(&uplo2, n, &c_b34, &a[a_offset], lda, &y[j * y_dim1 + 1], + &c__1, &c_b34, &ayb[1], &c__1); + zla_lin_berr_(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]); + +/* End of loop for each RHS. */ + + } + + return 0; +} /* zla_porfsx_extended__ */ + diff --git a/lapack-netlib/SRC/zla_porpvgrw.c b/lapack-netlib/SRC/zla_porpvgrw.c new file mode 100644 index 000000000..159fc362a --- /dev/null +++ b/lapack-netlib/SRC/zla_porpvgrw.c @@ -0,0 +1,630 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_PORPVGRW computes the reciprocal pivot growth factor norm(A)/norm(U) for a symmetric or Her +mitian positive-definite matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_PORPVGRW + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLA_PORPVGRW( UPLO, NCOLS, A, LDA, AF, */ +/* LDAF, WORK ) */ + +/* CHARACTER*1 UPLO */ +/* INTEGER NCOLS, LDA, LDAF */ +/* COMPLEX*16 A( LDA, * ), AF( LDAF, * ) */ +/* DOUBLE PRECISION WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > */ +/* > ZLA_PORPVGRW computes the reciprocal pivot growth factor */ +/* > norm(A)/norm(U). The "f2cmax absolute element" norm is used. If this is */ +/* > much less than 1, 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. */ +/* > \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] NCOLS */ +/* > \verbatim */ +/* > NCOLS is INTEGER */ +/* > The number of columns of the matrix A. NCOLS >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the N-by-N matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is COMPLEX*16 array, dimension (LDAF,N) */ +/* > The triangular factor U or L from the Cholesky factorization */ +/* > A = U**T*U or A = L*L**T, as computed by ZPOTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2016 */ + +/* > \ingroup complex16POcomputational */ + +/* ===================================================================== */ +doublereal zla_porpvgrw_(char *uplo, integer *ncols, doublecomplex *a, + integer *lda, doublecomplex *af, integer *ldaf, doublereal *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3; + doublereal ret_val, d__1, d__2, d__3, d__4; + + /* Local variables */ + doublereal amax, umax; + integer i__, j; + extern logical lsame_(char *, char *); + logical upper; + doublereal rpvgrw; + + +/* -- 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; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --work; + + /* Function Body */ + upper = lsame_("Upper", uplo); + +/* DPOTRF will have factored only the NCOLSxNCOLS leading minor, so */ +/* we restrict the growth search to that minor and use only the first */ +/* 2*NCOLS workspace entries. */ + + rpvgrw = 1.; + i__1 = *ncols << 1; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + +/* Find the f2cmax magnitude entry of each column. */ + + if (upper) { + i__1 = *ncols; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ + j * a_dim1; + d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + + j * a_dim1]), abs(d__2)), d__4 = work[*ncols + j]; + work[*ncols + j] = f2cmax(d__3,d__4); + } + } + } else { + i__1 = *ncols; + for (j = 1; j <= i__1; ++j) { + i__2 = *ncols; + for (i__ = j; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ + j * a_dim1; + d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + + j * a_dim1]), abs(d__2)), d__4 = work[*ncols + j]; + work[*ncols + j] = f2cmax(d__3,d__4); + } + } + } + +/* Now find the f2cmax magnitude entry of each column of the factor in */ +/* AF. No pivoting, so no permutations. */ + + if (lsame_("Upper", uplo)) { + i__1 = *ncols; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ + j * af_dim1; + d__3 = (d__1 = af[i__3].r, abs(d__1)) + (d__2 = d_imag(&af[ + i__ + j * af_dim1]), abs(d__2)), d__4 = work[j]; + work[j] = f2cmax(d__3,d__4); + } + } + } else { + i__1 = *ncols; + for (j = 1; j <= i__1; ++j) { + i__2 = *ncols; + for (i__ = j; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ + j * af_dim1; + d__3 = (d__1 = af[i__3].r, abs(d__1)) + (d__2 = d_imag(&af[ + i__ + j * af_dim1]), abs(d__2)), d__4 = work[j]; + work[j] = f2cmax(d__3,d__4); + } + } + } + +/* Compute the *inverse* of the f2cmax element growth factor. Dividing */ +/* by zero would imply the largest entry of the factor's column is */ +/* zero. Than can happen when either the column of A is zero or */ +/* massive pivots made the factor underflow to zero. Neither counts */ +/* as growth in itself, so simply ignore terms with zero */ +/* denominators. */ + + if (lsame_("Upper", uplo)) { + i__1 = *ncols; + for (i__ = 1; i__ <= i__1; ++i__) { + umax = work[i__]; + amax = work[*ncols + i__]; + if (umax != 0.) { +/* Computing MIN */ + d__1 = amax / umax; + rpvgrw = f2cmin(d__1,rpvgrw); + } + } + } else { + i__1 = *ncols; + for (i__ = 1; i__ <= i__1; ++i__) { + umax = work[i__]; + amax = work[*ncols + i__]; + if (umax != 0.) { +/* Computing MIN */ + d__1 = amax / umax; + rpvgrw = f2cmin(d__1,rpvgrw); + } + } + } + ret_val = rpvgrw; + return ret_val; +} /* zla_porpvgrw__ */ + diff --git a/lapack-netlib/SRC/zla_syamv.c b/lapack-netlib/SRC/zla_syamv.c new file mode 100644 index 000000000..6e41f5e17 --- /dev/null +++ b/lapack-netlib/SRC/zla_syamv.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 ZLA_SYAMV computes a matrix-vector product using a symmetric indefinite matrix to calculate err +or bounds. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_SYAMV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLA_SYAMV( UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, */ +/* INCY ) */ + +/* DOUBLE PRECISION ALPHA, BETA */ +/* INTEGER INCX, INCY, LDA, N */ +/* INTEGER UPLO */ +/* COMPLEX*16 A( LDA, * ), X( * ) */ +/* DOUBLE PRECISION Y( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLA_SYAMV performs the matrix-vector operation */ +/* > */ +/* > y := alpha*abs(A)*abs(x) + beta*abs(y), */ +/* > */ +/* > where alpha and beta are scalars, x and y are vectors and A is an */ +/* > n by n symmetric matrix. */ +/* > */ +/* > This function is primarily used in calculating error bounds. */ +/* > To protect against underflow during evaluation, components in */ +/* > the resulting vector are perturbed away from zero by (N+1) */ +/* > times the underflow threshold. To prevent unnecessarily large */ +/* > errors for block-structure embedded in general matrices, */ +/* > "symbolically" zero components are not perturbed. A zero */ +/* > entry is considered "symbolic" if all multiplications involved */ +/* > in computing that entry have at least one zero multiplicand. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is INTEGER */ +/* > On entry, UPLO specifies whether the upper or lower */ +/* > triangular part of the array A is to be referenced as */ +/* > follows: */ +/* > */ +/* > UPLO = BLAS_UPPER Only the upper triangular part of A */ +/* > is to be referenced. */ +/* > */ +/* > UPLO = BLAS_LOWER Only the lower triangular part of A */ +/* > is to be referenced. */ +/* > */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > On entry, N specifies the number of columns of the matrix A. */ +/* > 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. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension ( LDA, n ). */ +/* > Before entry, the leading m by n part of the array A must */ +/* > contain the matrix of coefficients. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > On entry, LDA specifies the first dimension of A as declared */ +/* > in the calling (sub) program. LDA must be at least */ +/* > f2cmax( 1, n ). */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension at least */ +/* > ( 1 + ( n - 1 )*abs( INCX ) ) */ +/* > Before entry, the incremented array X must contain the */ +/* > vector x. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > On entry, INCX specifies the increment for the elements of */ +/* > X. INCX must not be zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] BETA */ +/* > \verbatim */ +/* > BETA is DOUBLE PRECISION . */ +/* > On entry, BETA specifies the scalar beta. When BETA is */ +/* > supplied as zero then Y need not be set on input. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is DOUBLE PRECISION array, dimension */ +/* > ( 1 + ( n - 1 )*abs( INCY ) ) */ +/* > Before entry with BETA non-zero, the incremented array Y */ +/* > must contain the vector y. On exit, Y is overwritten by the */ +/* > updated vector y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCY */ +/* > \verbatim */ +/* > INCY is INTEGER */ +/* > On entry, INCY specifies the increment for the elements of */ +/* > Y. INCY must not be zero. */ +/* > Unchanged on exit. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup complex16SYcomputational */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > Level 2 Blas routine. */ +/* > */ +/* > -- Written on 22-October-1986. */ +/* > Jack Dongarra, Argonne National Lab. */ +/* > Jeremy Du Croz, Nag Central Office. */ +/* > Sven Hammarling, Nag Central Office. */ +/* > Richard Hanson, Sandia National Labs. */ +/* > -- Modified for the absolute-value product, April 2006 */ +/* > Jason Riedy, UC Berkeley */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zla_syamv_(integer *uplo, integer *n, doublereal *alpha, + doublecomplex *a, integer *lda, doublecomplex *x, integer *incx, + doublereal *beta, doublereal *y, integer *incy) +{ + /* System generated locals */ + integer a_dim1, a_offset, i__1, i__2, i__3; + doublereal d__1, d__2; + + /* Local variables */ + integer info; + doublereal temp, safe1; + integer i__, j; + logical symb_zero__; + extern doublereal dlamch_(char *); + integer iy, jx, kx, ky; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + extern integer ilauplo_(char *); + + +/* -- 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; + --x; + --y; + + /* Function Body */ + info = 0; + if (*uplo != ilauplo_("U") && *uplo != ilauplo_("L") + ) { + info = 1; + } else if (*n < 0) { + info = 2; + } else if (*lda < f2cmax(1,*n)) { + info = 5; + } else if (*incx == 0) { + info = 7; + } else if (*incy == 0) { + info = 10; + } + if (info != 0) { + xerbla_("ZLA_SYAMV", &info, (ftnlen)9); + return 0; + } + +/* Quick return if possible. */ + + if (*n == 0 || *alpha == 0. && *beta == 1.) { + return 0; + } + +/* Set up the start points in X and Y. */ + + if (*incx > 0) { + kx = 1; + } else { + kx = 1 - (*n - 1) * *incx; + } + if (*incy > 0) { + ky = 1; + } else { + ky = 1 - (*n - 1) * *incy; + } + +/* Set SAFE1 essentially to be the underflow threshold times the */ +/* number of additions in each row. */ + + safe1 = dlamch_("Safe minimum"); + safe1 = (*n + 1) * safe1; + +/* Form y := alpha*abs(A)*abs(x) + beta*abs(y). */ + +/* The O(N^2) SYMB_ZERO tests could be replaced by O(N) queries to */ +/* the inexact flag. Still doesn't help change the iteration order */ +/* to per-column. */ + + iy = ky; + if (*incx == 1) { + if (*uplo == ilauplo_("U")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + if (*alpha != 0.) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag( + &a[j + i__ * a_dim1]), abs(d__2)); + i__3 = j; + symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ + i__3].i == 0. || temp == 0.); + i__3 = j; + y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&x[j]), abs(d__2))) * temp; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag( + &a[i__ + j * a_dim1]), abs(d__2)); + i__3 = j; + symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ + i__3].i == 0. || temp == 0.); + i__3 = j; + y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&x[j]), abs(d__2))) * temp; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + if (*alpha != 0.) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag( + &a[i__ + j * a_dim1]), abs(d__2)); + i__3 = j; + symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ + i__3].i == 0. || temp == 0.); + i__3 = j; + y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&x[j]), abs(d__2))) * temp; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag( + &a[j + i__ * a_dim1]), abs(d__2)); + i__3 = j; + symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ + i__3].i == 0. || temp == 0.); + i__3 = j; + y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&x[j]), abs(d__2))) * temp; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } + } else { + if (*uplo == ilauplo_("U")) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + jx = kx; + if (*alpha != 0.) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag( + &a[j + i__ * a_dim1]), abs(d__2)); + i__3 = j; + symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ + i__3].i == 0. || temp == 0.); + i__3 = jx; + y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&x[jx]), abs(d__2))) * temp; + jx += *incx; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag( + &a[i__ + j * a_dim1]), abs(d__2)); + i__3 = j; + symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ + i__3].i == 0. || temp == 0.); + i__3 = jx; + y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&x[jx]), abs(d__2))) * temp; + jx += *incx; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + if (*beta == 0.) { + symb_zero__ = TRUE_; + y[iy] = 0.; + } else if (y[iy] == 0.) { + symb_zero__ = TRUE_; + } else { + symb_zero__ = FALSE_; + y[iy] = *beta * (d__1 = y[iy], abs(d__1)); + } + jx = kx; + if (*alpha != 0.) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag( + &a[i__ + j * a_dim1]), abs(d__2)); + i__3 = j; + symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ + i__3].i == 0. || temp == 0.); + i__3 = jx; + y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&x[jx]), abs(d__2))) * temp; + jx += *incx; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + temp = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag( + &a[j + i__ * a_dim1]), abs(d__2)); + i__3 = j; + symb_zero__ = symb_zero__ && (x[i__3].r == 0. && x[ + i__3].i == 0. || temp == 0.); + i__3 = jx; + y[iy] += *alpha * ((d__1 = x[i__3].r, abs(d__1)) + ( + d__2 = d_imag(&x[jx]), abs(d__2))) * temp; + jx += *incx; + } + } + if (! symb_zero__) { + y[iy] += d_sign(&safe1, &y[iy]); + } + iy += *incy; + } + } + } + + return 0; + +/* End of ZLA_SYAMV */ + +} /* zla_syamv__ */ + diff --git a/lapack-netlib/SRC/zla_syrcond_c.c b/lapack-netlib/SRC/zla_syrcond_c.c new file mode 100644 index 000000000..ac73669f9 --- /dev/null +++ b/lapack-netlib/SRC/zla_syrcond_c.c @@ -0,0 +1,776 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_SYRCOND_C computes the infinity norm condition number of op(A)*inv(diag(c)) for symmetric i +ndefinite matrices. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_SYRCOND_C + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLA_SYRCOND_C( UPLO, N, A, LDA, AF, */ +/* LDAF, IPIV, C, CAPPLY, */ +/* INFO, WORK, RWORK ) */ + +/* CHARACTER UPLO */ +/* LOGICAL CAPPLY */ +/* INTEGER N, LDA, LDAF, INFO */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ) */ +/* DOUBLE PRECISION C( * ), RWORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLA_SYRCOND_C Computes the infinity norm condition number of */ +/* > op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the N-by-N matrix A */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is COMPLEX*16 array, dimension (LDAF,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by ZSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by ZSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N) */ +/* > The vector C in the formula op(A) * inv(diag(C)). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] CAPPLY */ +/* > \verbatim */ +/* > CAPPLY is LOGICAL */ +/* > If .TRUE. then access the vector C in the formula above. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > i > 0: The ith argument is invalid. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N). */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (N). */ +/* > Workspace. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16SYcomputational */ + +/* ===================================================================== */ +doublereal zla_syrcond_c_(char *uplo, integer *n, doublecomplex *a, integer * + lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublereal *c__, + logical *capply, integer *info, doublecomplex *work, doublereal * + rwork) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4; + doublereal ret_val, d__1, d__2; + doublecomplex z__1; + + /* Local variables */ + integer kase, i__, j; + extern logical lsame_(char *, char *); + integer isave[3]; + doublereal anorm; + logical upper; + extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *, + doublecomplex *, doublereal *, integer *, integer *); + logical up; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal ainvnm; + extern /* Subroutine */ int zsytrs_(char *, integer *, integer *, + doublecomplex *, integer *, integer *, doublecomplex *, integer *, + integer *); + doublereal tmp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --ipiv; + --c__; + --work; + --rwork; + + /* Function Body */ + ret_val = 0.; + + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*ldaf < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLA_SYRCOND_C", &i__1, (ftnlen)13); + return ret_val; + } + up = FALSE_; + if (lsame_(uplo, "U")) { + up = TRUE_; + } + +/* Compute norm of op(A)*op2(C). */ + + anorm = 0.; + if (up) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + if (*capply) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + j + i__ * a_dim1]), abs(d__2))) / c__[j]; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + i__ + j * a_dim1]), abs(d__2))) / c__[j]; + } + } else { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + j + i__ * a_dim1]), abs(d__2)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + i__ + j * a_dim1]), abs(d__2)); + } + } + rwork[i__] = tmp; + anorm = f2cmax(anorm,tmp); + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + if (*capply) { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + i__ + j * a_dim1]), abs(d__2))) / c__[j]; + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + tmp += ((d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + j + i__ * a_dim1]), abs(d__2))) / c__[j]; + } + } else { + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + i__ + j * a_dim1]), abs(d__2)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + tmp += (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[ + j + i__ * a_dim1]), abs(d__2)); + } + } + rwork[i__] = tmp; + anorm = f2cmax(anorm,tmp); + } + } + +/* Quick return if possible. */ + + if (*n == 0) { + ret_val = 1.; + return ret_val; + } else if (anorm == 0.) { + return ret_val; + } + +/* Estimate the norm of inv(op(A)). */ + + ainvnm = 0.; + + kase = 0; +L10: + zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == 2) { + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + + if (up) { + zsytrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } else { + zsytrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } + +/* Multiply by inv(C). */ + + if (*capply) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = c__[i__4] * work[i__3].r, z__1.i = c__[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } + } else { + +/* Multiply by inv(C**T). */ + + if (*capply) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = c__[i__4] * work[i__3].r, z__1.i = c__[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } + + if (up) { + zsytrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } else { + zsytrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + ret_val = 1. / ainvnm; + } + + return ret_val; + +} /* zla_syrcond_c__ */ + diff --git a/lapack-netlib/SRC/zla_syrcond_x.c b/lapack-netlib/SRC/zla_syrcond_x.c new file mode 100644 index 000000000..7ec9ed3af --- /dev/null +++ b/lapack-netlib/SRC/zla_syrcond_x.c @@ -0,0 +1,748 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_SYRCOND_X computes the infinity norm condition number of op(A)*diag(x) for symmetric indefi +nite matrices. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_SYRCOND_X + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLA_SYRCOND_X( UPLO, N, A, LDA, AF, */ +/* LDAF, IPIV, X, INFO, */ +/* WORK, RWORK ) */ + +/* CHARACTER UPLO */ +/* INTEGER N, LDA, LDAF, INFO */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * ) */ +/* DOUBLE PRECISION RWORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLA_SYRCOND_X Computes the infinity norm condition number of */ +/* > op(A) * diag(X) where X is a COMPLEX*16 vector. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the N-by-N matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is COMPLEX*16 array, dimension (LDAF,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by ZSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by ZSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (N) */ +/* > The vector X in the formula op(A) * diag(X). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > i > 0: The ith argument is invalid. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is COMPLEX*16 array, dimension (2*N). */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] RWORK */ +/* > \verbatim */ +/* > RWORK is DOUBLE PRECISION array, dimension (N). */ +/* > Workspace. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16SYcomputational */ + +/* ===================================================================== */ +doublereal zla_syrcond_x_(char *uplo, integer *n, doublecomplex *a, integer * + lda, doublecomplex *af, integer *ldaf, integer *ipiv, doublecomplex * + x, integer *info, doublecomplex *work, doublereal *rwork) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3, i__4; + doublereal ret_val, d__1, d__2; + doublecomplex z__1, z__2; + + /* Local variables */ + integer kase, i__, j; + extern logical lsame_(char *, char *); + integer isave[3]; + doublereal anorm; + logical upper; + extern /* Subroutine */ int zlacn2_(integer *, doublecomplex *, + doublecomplex *, doublereal *, integer *, integer *); + logical up; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal ainvnm; + extern /* Subroutine */ int zsytrs_(char *, integer *, integer *, + doublecomplex *, integer *, integer *, doublecomplex *, integer *, + integer *); + doublereal tmp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --ipiv; + --x; + --work; + --rwork; + + /* Function Body */ + ret_val = 0.; + + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -1; + } else if (*n < 0) { + *info = -2; + } else if (*lda < f2cmax(1,*n)) { + *info = -4; + } else if (*ldaf < f2cmax(1,*n)) { + *info = -6; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLA_SYRCOND_X", &i__1, (ftnlen)13); + return ret_val; + } + up = FALSE_; + if (lsame_(uplo, "U")) { + up = TRUE_; + } + +/* Compute norm of op(A)*op2(C). */ + + anorm = 0.; + if (up) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + i__4 = j; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i, + z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4] + .r; + z__1.r = z__2.r, z__1.i = z__2.i; + tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), + abs(d__2)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + i__4 = j; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i, + z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4] + .r; + z__1.r = z__2.r, z__1.i = z__2.i; + tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), + abs(d__2)); + } + rwork[i__] = tmp; + anorm = f2cmax(anorm,tmp); + } + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + tmp = 0.; + i__2 = i__; + for (j = 1; j <= i__2; ++j) { + i__3 = i__ + j * a_dim1; + i__4 = j; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i, + z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4] + .r; + z__1.r = z__2.r, z__1.i = z__2.i; + tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), + abs(d__2)); + } + i__2 = *n; + for (j = i__ + 1; j <= i__2; ++j) { + i__3 = j + i__ * a_dim1; + i__4 = j; + z__2.r = a[i__3].r * x[i__4].r - a[i__3].i * x[i__4].i, + z__2.i = a[i__3].r * x[i__4].i + a[i__3].i * x[i__4] + .r; + z__1.r = z__2.r, z__1.i = z__2.i; + tmp += (d__1 = z__1.r, abs(d__1)) + (d__2 = d_imag(&z__1), + abs(d__2)); + } + rwork[i__] = tmp; + anorm = f2cmax(anorm,tmp); + } + } + +/* Quick return if possible. */ + + if (*n == 0) { + ret_val = 1.; + return ret_val; + } else if (anorm == 0.) { + return ret_val; + } + +/* Estimate the norm of inv(op(A)). */ + + ainvnm = 0.; + + kase = 0; +L10: + zlacn2_(n, &work[*n + 1], &work[1], &ainvnm, &kase, isave); + if (kase != 0) { + if (kase == 2) { + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + + if (up) { + zsytrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } else { + zsytrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } + +/* Multiply by inv(X). */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + z_div(&z__1, &work[i__], &x[i__]); + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } else { + +/* Multiply by inv(X**T). */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + z_div(&z__1, &work[i__], &x[i__]); + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + + if (up) { + zsytrs_("U", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } else { + zsytrs_("L", n, &c__1, &af[af_offset], ldaf, &ipiv[1], &work[ + 1], n, info); + } + +/* Multiply by R. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + i__4 = i__; + z__1.r = rwork[i__4] * work[i__3].r, z__1.i = rwork[i__4] * + work[i__3].i; + work[i__2].r = z__1.r, work[i__2].i = z__1.i; + } + } + goto L10; + } + +/* Compute the estimate of the reciprocal condition number. */ + + if (ainvnm != 0.) { + ret_val = 1. / ainvnm; + } + + return ret_val; + +} /* zla_syrcond_x__ */ + diff --git a/lapack-netlib/SRC/zla_syrfsx_extended.c b/lapack-netlib/SRC/zla_syrfsx_extended.c new file mode 100644 index 000000000..31fb90fd9 --- /dev/null +++ b/lapack-netlib/SRC/zla_syrfsx_extended.c @@ -0,0 +1,1140 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_SYRFSX_EXTENDED improves the computed solution to a system of linear equations for symmetri +c indefinite matrices by performing extra-precise iterative refinement and provides error bounds and b +ackward error estimates for the solution. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_SYRFSX_EXTENDED + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLA_SYRFSX_EXTENDED( PREC_TYPE, UPLO, N, NRHS, A, LDA, */ +/* AF, LDAF, IPIV, COLEQU, C, B, LDB, */ +/* Y, LDY, BERR_OUT, N_NORMS, */ +/* ERR_BNDS_NORM, ERR_BNDS_COMP, RES, */ +/* AYB, DY, Y_TAIL, RCOND, ITHRESH, */ +/* RTHRESH, DZ_UB, IGNORE_CWISE, */ +/* INFO ) */ + +/* INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE, */ +/* $ N_NORMS, ITHRESH */ +/* CHARACTER UPLO */ +/* LOGICAL COLEQU, IGNORE_CWISE */ +/* DOUBLE PRECISION RTHRESH, DZ_UB */ +/* INTEGER IPIV( * ) */ +/* COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ), */ +/* $ Y( LDY, * ), RES( * ), DY( * ), Y_TAIL( * ) */ +/* DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ), */ +/* $ ERR_BNDS_NORM( NRHS, * ), */ +/* $ ERR_BNDS_COMP( NRHS, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLA_SYRFSX_EXTENDED improves the computed solution to a system of */ +/* > linear equations by performing extra-precise iterative refinement */ +/* > and provides error bounds and backward error estimates for the solution. */ +/* > This subroutine is called by ZSYRFSX to perform iterative refinement. */ +/* > 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. Note that this */ +/* > subroutine is only resonsible for setting the second fields of */ +/* > ERR_BNDS_NORM and ERR_BNDS_COMP. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] PREC_TYPE */ +/* > \verbatim */ +/* > PREC_TYPE is INTEGER */ +/* > Specifies the intermediate precision to be used in refinement. */ +/* > The value is defined by ILAPREC(P) where P is a CHARACTER and P */ +/* > = 'S': Single */ +/* > = 'D': Double */ +/* > = 'I': Indigenous */ +/* > = 'X' or 'E': Extra */ +/* > \endverbatim */ +/* > */ +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NRHS */ +/* > \verbatim */ +/* > NRHS is INTEGER */ +/* > The number of right-hand-sides, i.e., the number of columns of the */ +/* > matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the N-by-N matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is COMPLEX*16 array, dimension (LDAF,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by ZSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by ZSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] COLEQU */ +/* > \verbatim */ +/* > COLEQU is LOGICAL */ +/* > If .TRUE. then column equilibration was done to A before calling */ +/* > this routine. This is needed to compute the solution and error */ +/* > bounds correctly. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] C */ +/* > \verbatim */ +/* > C is DOUBLE PRECISION array, dimension (N) */ +/* > The column scale factors for A. If COLEQU = .FALSE., C */ +/* > is not accessed. 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 COMPLEX*16 array, dimension (LDB,NRHS) */ +/* > The right-hand-side matrix B. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDB */ +/* > \verbatim */ +/* > LDB is INTEGER */ +/* > The leading dimension of the array B. LDB >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is COMPLEX*16 array, dimension (LDY,NRHS) */ +/* > On entry, the solution matrix X, as computed by ZSYTRS. */ +/* > On exit, the improved solution matrix Y. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDY */ +/* > \verbatim */ +/* > LDY is INTEGER */ +/* > The leading dimension of the array Y. LDY >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] BERR_OUT */ +/* > \verbatim */ +/* > BERR_OUT is DOUBLE PRECISION array, dimension (NRHS) */ +/* > On exit, BERR_OUT(j) contains the componentwise relative backward */ +/* > error for right-hand-side j from the formula */ +/* > f2cmax(i) ( abs(RES(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* > where abs(Z) is the componentwise absolute value of the matrix */ +/* > or vector Z. This is computed by ZLA_LIN_BERR. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N_NORMS */ +/* > \verbatim */ +/* > N_NORMS is INTEGER */ +/* > Determines which error bounds to return (see ERR_BNDS_NORM */ +/* > and ERR_BNDS_COMP). */ +/* > If N_NORMS >= 1 return normwise error bounds. */ +/* > If N_NORMS >= 2 return componentwise error bounds. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ERR_BNDS_NORM */ +/* > \verbatim */ +/* > ERR_BNDS_NORM is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > normwise relative error, which is defined as follows: */ +/* > */ +/* > Normwise relative error in the ith solution vector: */ +/* > max_j (abs(XTRUE(j,i) - X(j,i))) */ +/* > ------------------------------ */ +/* > max_j abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the type of error information as described */ +/* > below. There currently are up to three pieces of information */ +/* > returned. */ +/* > */ +/* > The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_NORM(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * 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. */ +/* > */ +/* > This subroutine is only responsible for setting the second field */ +/* > above. */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] ERR_BNDS_COMP */ +/* > \verbatim */ +/* > ERR_BNDS_COMP is DOUBLE PRECISION array, dimension (NRHS, N_ERR_BNDS) */ +/* > For each right-hand side, this array contains information about */ +/* > various error bounds and condition numbers corresponding to the */ +/* > componentwise relative error, which is defined as follows: */ +/* > */ +/* > Componentwise relative error in the ith solution vector: */ +/* > abs(XTRUE(j,i) - X(j,i)) */ +/* > max_j ---------------------- */ +/* > abs(X(j,i)) */ +/* > */ +/* > The array is indexed by the right-hand side i (on which the */ +/* > componentwise relative error depends), and the type of error */ +/* > information as described below. There currently are up to three */ +/* > pieces of information returned for each right-hand side. If */ +/* > componentwise accuracy is not requested (PARAMS(3) = 0.0), then */ +/* > ERR_BNDS_COMP is not accessed. If N_ERR_BNDS < 3, then at most */ +/* > the first (:,N_ERR_BNDS) entries are returned. */ +/* > */ +/* > The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */ +/* > right-hand side. */ +/* > */ +/* > The second index in ERR_BNDS_COMP(:,err) contains the following */ +/* > three fields: */ +/* > err = 1 "Trust/don't trust" boolean. Trust the answer if the */ +/* > reciprocal condition number is less than the threshold */ +/* > sqrt(n) * 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. */ +/* > */ +/* > This subroutine is only responsible for setting the second field */ +/* > above. */ +/* > See Lapack Working Note 165 for further details and extra */ +/* > cautions. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RES */ +/* > \verbatim */ +/* > RES is COMPLEX*16 array, dimension (N) */ +/* > Workspace to hold the intermediate residual. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AYB */ +/* > \verbatim */ +/* > AYB is DOUBLE PRECISION array, dimension (N) */ +/* > Workspace. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DY */ +/* > \verbatim */ +/* > DY is COMPLEX*16 array, dimension (N) */ +/* > Workspace to hold the intermediate solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] Y_TAIL */ +/* > \verbatim */ +/* > Y_TAIL is COMPLEX*16 array, dimension (N) */ +/* > Workspace to hold the trailing bits of the intermediate solution. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RCOND */ +/* > \verbatim */ +/* > RCOND is DOUBLE PRECISION */ +/* > Reciprocal scaled condition number. This is an estimate of the */ +/* > reciprocal Skeel condition number of the matrix A after */ +/* > equilibration (if done). If this is less than the machine */ +/* > precision (in particular, if it is zero), the matrix is singular */ +/* > to working precision. Note that the error may still be small even */ +/* > if this number is very small and the matrix appears ill- */ +/* > conditioned. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] ITHRESH */ +/* > \verbatim */ +/* > ITHRESH is INTEGER */ +/* > The maximum number of residual computations allowed for */ +/* > refinement. The default is 10. For '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. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] RTHRESH */ +/* > \verbatim */ +/* > RTHRESH is DOUBLE PRECISION */ +/* > Determines when to stop refinement if the error estimate stops */ +/* > decreasing. Refinement will stop when the next solution no longer */ +/* > satisfies norm(dx_{i+1}) < RTHRESH * norm(dx_i) where norm(Z) is */ +/* > the infinity norm of Z. RTHRESH satisfies 0 < RTHRESH <= 1. The */ +/* > default value is 0.5. For 'aggressive' set to 0.9 to permit */ +/* > convergence on extremely ill-conditioned matrices. See LAWN 165 */ +/* > for more details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] DZ_UB */ +/* > \verbatim */ +/* > DZ_UB is DOUBLE PRECISION */ +/* > Determines when to start considering componentwise convergence. */ +/* > Componentwise convergence is only considered after each component */ +/* > of the solution Y is stable, which we definte as the relative */ +/* > change in each component being less than DZ_UB. The default value */ +/* > is 0.25, requiring the first bit to be stable. See LAWN 165 for */ +/* > more details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IGNORE_CWISE */ +/* > \verbatim */ +/* > IGNORE_CWISE is LOGICAL */ +/* > If .TRUE. then ignore componentwise convergence. Default value */ +/* > is .FALSE.. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: Successful exit. */ +/* > < 0: if INFO = -i, the ith argument to ZLA_HERFSX_EXTENDED 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 complex16SYcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zla_syrfsx_extended_(integer *prec_type__, char *uplo, + integer *n, integer *nrhs, doublecomplex *a, integer *lda, + doublecomplex *af, integer *ldaf, integer *ipiv, logical *colequ, + doublereal *c__, doublecomplex *b, integer *ldb, doublecomplex *y, + integer *ldy, doublereal *berr_out__, integer *n_norms__, doublereal * + err_bnds_norm__, doublereal *err_bnds_comp__, doublecomplex *res, + doublereal *ayb, doublecomplex *dy, doublecomplex *y_tail__, + doublereal *rcond, integer *ithresh, doublereal *rthresh, doublereal * + dz_ub__, logical *ignore_cwise__, integer *info) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, y_dim1, + y_offset, err_bnds_norm_dim1, err_bnds_norm_offset, + err_bnds_comp_dim1, err_bnds_comp_offset, i__1, i__2, i__3, i__4; + doublereal d__1, d__2; + + /* Local variables */ + doublereal dx_x__, dz_z__, ymin; + extern /* Subroutine */ int zla_lin_berr_(integer *, integer *, integer * + , doublecomplex *, doublereal *, doublereal *); + doublereal dxratmax, dzratmax; + integer y_prec_state__, uplo2, i__, j; + extern /* Subroutine */ int blas_zsymv_x_(integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *, integer *) + ; + extern logical lsame_(char *, char *); + doublereal dxrat; + logical incr_prec__; + doublereal dzrat; + logical upper; + extern /* Subroutine */ int blas_zsymv2_x_(integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, doublecomplex *, + integer *, integer *); + doublereal normx, normy; + extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *, + doublecomplex *, integer *), zaxpy_(integer *, doublecomplex *, + doublecomplex *, integer *, doublecomplex *, integer *); + doublereal myhugeval, prev_dz_z__; + extern /* Subroutine */ int zla_syamv_(integer *, integer *, doublereal * + , doublecomplex *, integer *, doublecomplex *, integer *, + doublereal *, doublereal *, integer *), zsymv_(char *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *); + extern doublereal dlamch_(char *); + doublereal yk; + extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen); + doublereal final_dx_x__, final_dz_z__, normdx; + extern /* Subroutine */ int zla_wwaddw_(integer *, doublecomplex *, + doublecomplex *, doublecomplex *), zsytrs_(char *, integer *, + integer *, doublecomplex *, integer *, integer *, doublecomplex *, + integer *, integer *); + doublereal prevnormdx; + integer cnt; + doublereal dyk, eps; + extern integer ilauplo_(char *); + integer x_state__, z_state__; + doublereal incr_thresh__; + + +/* -- 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 */ + 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; + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --ipiv; + --c__; + b_dim1 = *ldb; + b_offset = 1 + b_dim1 * 1; + b -= b_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + y -= y_offset; + --berr_out__; + --res; + --ayb; + --dy; + --y_tail__; + + /* Function Body */ + *info = 0; + upper = lsame_(uplo, "U"); + if (! upper && ! lsame_(uplo, "L")) { + *info = -2; + } else if (*n < 0) { + *info = -3; + } else if (*nrhs < 0) { + *info = -4; + } else if (*lda < f2cmax(1,*n)) { + *info = -6; + } else if (*ldaf < f2cmax(1,*n)) { + *info = -8; + } else if (*ldb < f2cmax(1,*n)) { + *info = -13; + } else if (*ldy < f2cmax(1,*n)) { + *info = -15; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("ZLA_HERFSX_EXTENDED", &i__1, (ftnlen)19); + return 0; + } + eps = dlamch_("Epsilon"); + myhugeval = dlamch_("Overflow"); +/* Force MYHUGEVAL to Inf */ + myhugeval *= myhugeval; +/* Using MYHUGEVAL may lead to spurious underflows. */ + incr_thresh__ = (doublereal) (*n) * eps; + if (lsame_(uplo, "L")) { + uplo2 = ilauplo_("L"); + } else { + uplo2 = ilauplo_("U"); + } + i__1 = *nrhs; + for (j = 1; j <= i__1; ++j) { + y_prec_state__ = 1; + if (y_prec_state__ == 2) { + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__; + y_tail__[i__3].r = 0., y_tail__[i__3].i = 0.; + } + } + dxrat = 0.; + dxratmax = 0.; + dzrat = 0.; + dzratmax = 0.; + final_dx_x__ = myhugeval; + final_dz_z__ = myhugeval; + prevnormdx = myhugeval; + prev_dz_z__ = myhugeval; + dz_z__ = myhugeval; + dx_x__ = myhugeval; + x_state__ = 1; + z_state__ = 0; + incr_prec__ = FALSE_; + i__2 = *ithresh; + for (cnt = 1; cnt <= i__2; ++cnt) { + +/* Compute residual RES = B_s - op(A_s) * Y, */ +/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ + + zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + if (y_prec_state__ == 0) { + zsymv_(uplo, n, &c_b14, &a[a_offset], lda, &y[j * y_dim1 + 1], + &c__1, &c_b15, &res[1], &c__1); + } else if (y_prec_state__ == 1) { + blas_zsymv_x__(&uplo2, n, &c_b14, &a[a_offset], lda, &y[j * + y_dim1 + 1], &c__1, &c_b15, &res[1], &c__1, + prec_type__); + } else { + blas_zsymv2_x__(&uplo2, n, &c_b14, &a[a_offset], lda, &y[j * + y_dim1 + 1], &y_tail__[1], &c__1, &c_b15, &res[1], & + c__1, prec_type__); + } +/* XXX: RES is no longer needed. */ + zcopy_(n, &res[1], &c__1, &dy[1], &c__1); + zsytrs_(uplo, n, &c__1, &af[af_offset], ldaf, &ipiv[1], &dy[1], n, + info); + +/* Calculate relative changes DX_X, DZ_Z and ratios DXRAT, DZRAT. */ + + normx = 0.; + normy = 0.; + normdx = 0.; + dz_z__ = 0.; + ymin = myhugeval; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__ + j * y_dim1; + yk = (d__1 = y[i__4].r, abs(d__1)) + (d__2 = d_imag(&y[i__ + + j * y_dim1]), abs(d__2)); + i__4 = i__; + dyk = (d__1 = dy[i__4].r, abs(d__1)) + (d__2 = d_imag(&dy[i__] + ), abs(d__2)); + if (yk != 0.) { +/* Computing MAX */ + d__1 = dz_z__, d__2 = dyk / yk; + dz_z__ = f2cmax(d__1,d__2); + } else if (dyk != 0.) { + dz_z__ = myhugeval; + } + ymin = f2cmin(ymin,yk); + normy = f2cmax(normy,yk); + if (*colequ) { +/* Computing MAX */ + d__1 = normx, d__2 = yk * c__[i__]; + normx = f2cmax(d__1,d__2); +/* Computing MAX */ + d__1 = normdx, d__2 = dyk * c__[i__]; + normdx = f2cmax(d__1,d__2); + } else { + normx = normy; + normdx = f2cmax(normdx,dyk); + } + } + if (normx != 0.) { + dx_x__ = normdx / normx; + } else if (normdx == 0.) { + dx_x__ = 0.; + } else { + dx_x__ = myhugeval; + } + dxrat = normdx / prevnormdx; + dzrat = dz_z__ / prev_dz_z__; + +/* Check termination criteria. */ + + if (ymin * *rcond < incr_thresh__ * normy && y_prec_state__ < 2) { + incr_prec__ = TRUE_; + } + if (x_state__ == 3 && dxrat <= *rthresh) { + x_state__ = 1; + } + if (x_state__ == 1) { + if (dx_x__ <= eps) { + x_state__ = 2; + } else if (dxrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = TRUE_; + } else { + x_state__ = 3; + } + } else { + if (dxrat > dxratmax) { + dxratmax = dxrat; + } + } + if (x_state__ > 1) { + final_dx_x__ = dx_x__; + } + } + if (z_state__ == 0 && dz_z__ <= *dz_ub__) { + z_state__ = 1; + } + if (z_state__ == 3 && dzrat <= *rthresh) { + z_state__ = 1; + } + if (z_state__ == 1) { + if (dz_z__ <= eps) { + z_state__ = 2; + } else if (dz_z__ > *dz_ub__) { + z_state__ = 0; + dzratmax = 0.; + final_dz_z__ = myhugeval; + } else if (dzrat > *rthresh) { + if (y_prec_state__ != 2) { + incr_prec__ = TRUE_; + } else { + z_state__ = 3; + } + } else { + if (dzrat > dzratmax) { + dzratmax = dzrat; + } + } + if (z_state__ > 1) { + final_dz_z__ = dz_z__; + } + } + if (x_state__ != 1 && (*ignore_cwise__ || z_state__ != 1)) { + goto L666; + } + if (incr_prec__) { + incr_prec__ = FALSE_; + ++y_prec_state__; + i__3 = *n; + for (i__ = 1; i__ <= i__3; ++i__) { + i__4 = i__; + y_tail__[i__4].r = 0., y_tail__[i__4].i = 0.; + } + } + prevnormdx = normdx; + prev_dz_z__ = dz_z__; + +/* Update soluton. */ + + if (y_prec_state__ < 2) { + zaxpy_(n, &c_b15, &dy[1], &c__1, &y[j * y_dim1 + 1], &c__1); + } else { + zla_wwaddw_(n, &y[j * y_dim1 + 1], &y_tail__[1], &dy[1]); + } + } +/* Target of "IF (Z_STOP .AND. X_STOP)". Sun's f77 won't CALL MYEXIT. */ +L666: + +/* Set final_* when cnt hits ithresh. */ + + if (x_state__ == 1) { + final_dx_x__ = dx_x__; + } + if (z_state__ == 1) { + final_dz_z__ = dz_z__; + } + +/* Compute error bounds. */ + + if (*n_norms__ >= 1) { + err_bnds_norm__[j + (err_bnds_norm_dim1 << 1)] = final_dx_x__ / ( + 1 - dxratmax); + } + if (*n_norms__ >= 2) { + err_bnds_comp__[j + (err_bnds_comp_dim1 << 1)] = final_dz_z__ / ( + 1 - dzratmax); + } + +/* Compute componentwise relative backward error from formula */ +/* f2cmax(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) ) */ +/* where abs(Z) is the componentwise absolute value of the matrix */ +/* or vector Z. */ + +/* Compute residual RES = B_s - op(A_s) * Y, */ +/* op(A) = A, A**T, or A**H depending on TRANS (and type). */ + + zcopy_(n, &b[j * b_dim1 + 1], &c__1, &res[1], &c__1); + zsymv_(uplo, n, &c_b14, &a[a_offset], lda, &y[j * y_dim1 + 1], &c__1, + &c_b15, &res[1], &c__1); + i__2 = *n; + for (i__ = 1; i__ <= i__2; ++i__) { + i__3 = i__ + j * b_dim1; + ayb[i__] = (d__1 = b[i__3].r, abs(d__1)) + (d__2 = d_imag(&b[i__ + + j * b_dim1]), abs(d__2)); + } + +/* Compute abs(op(A_s))*abs(Y) + abs(B_s). */ + + zla_syamv_(&uplo2, n, &c_b37, &a[a_offset], lda, &y[j * y_dim1 + 1], + &c__1, &c_b37, &ayb[1], &c__1); + zla_lin_berr_(n, n, &c__1, &res[1], &ayb[1], &berr_out__[j]); + +/* End of loop for each RHS. */ + + } + + return 0; +} /* zla_syrfsx_extended__ */ + diff --git a/lapack-netlib/SRC/zla_syrpvgrw.c b/lapack-netlib/SRC/zla_syrpvgrw.c new file mode 100644 index 000000000..02bef8fac --- /dev/null +++ b/lapack-netlib/SRC/zla_syrpvgrw.c @@ -0,0 +1,783 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_SYRPVGRW computes the reciprocal pivot growth factor norm(A)/norm(U) for a symmetric indefi +nite matrix. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_SYRPVGRW + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* DOUBLE PRECISION FUNCTION ZLA_SYRPVGRW( UPLO, N, INFO, A, LDA, AF, */ +/* LDAF, IPIV, WORK ) */ + +/* CHARACTER*1 UPLO */ +/* INTEGER N, INFO, LDA, LDAF */ +/* COMPLEX*16 A( LDA, * ), AF( LDAF, * ) */ +/* DOUBLE PRECISION WORK( * ) */ +/* INTEGER IPIV( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > */ +/* > ZLA_SYRPVGRW computes the reciprocal pivot growth factor */ +/* > norm(A)/norm(U). The "f2cmax absolute element" norm is used. If this is */ +/* > much less than 1, 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. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] UPLO */ +/* > \verbatim */ +/* > UPLO is CHARACTER*1 */ +/* > = 'U': Upper triangle of A is stored; */ +/* > = 'L': Lower triangle of A is stored. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of linear equations, i.e., the order of the */ +/* > matrix A. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > The value of INFO returned from ZSYTRF, .i.e., the pivot in */ +/* > column INFO is exactly 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the N-by-N matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] AF */ +/* > \verbatim */ +/* > AF is COMPLEX*16 array, dimension (LDAF,N) */ +/* > The block diagonal matrix D and the multipliers used to */ +/* > obtain the factor U or L as computed by ZSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDAF */ +/* > \verbatim */ +/* > LDAF is INTEGER */ +/* > The leading dimension of the array AF. LDAF >= f2cmax(1,N). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] IPIV */ +/* > \verbatim */ +/* > IPIV is INTEGER array, dimension (N) */ +/* > Details of the interchanges and the block structure of D */ +/* > as determined by ZSYTRF. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (2*N) */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16SYcomputational */ + +/* ===================================================================== */ +doublereal zla_syrpvgrw_(char *uplo, integer *n, integer *info, + doublecomplex *a, integer *lda, doublecomplex *af, integer *ldaf, + integer *ipiv, doublereal *work) +{ + /* System generated locals */ + integer a_dim1, a_offset, af_dim1, af_offset, i__1, i__2, i__3; + doublereal ret_val, d__1, d__2, d__3, d__4; + + /* Local variables */ + doublereal amax, umax; + integer i__, j, k; + extern logical lsame_(char *, char *); + integer ncols; + logical upper; + integer kp; + doublereal rpvgrw, tmp; + + +/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* December 2016 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + af_dim1 = *ldaf; + af_offset = 1 + af_dim1 * 1; + af -= af_offset; + --ipiv; + --work; + + /* Function Body */ + upper = lsame_("Upper", uplo); + if (*info == 0) { + if (upper) { + ncols = 1; + } else { + ncols = *n; + } + } else { + ncols = *info; + } + rpvgrw = 1.; + i__1 = *n << 1; + for (i__ = 1; i__ <= i__1; ++i__) { + work[i__] = 0.; + } + +/* Find the f2cmax magnitude entry of each column of A. Compute the f2cmax */ +/* for all N columns so we can apply the pivot permutation while */ +/* looping below. Assume a full factorization is the common case. */ + + if (upper) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = j; + for (i__ = 1; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ + j * a_dim1; + d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + + j * a_dim1]), abs(d__2)), d__4 = work[*n + i__]; + work[*n + i__] = f2cmax(d__3,d__4); +/* Computing MAX */ + i__3 = i__ + j * a_dim1; + d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + + j * a_dim1]), abs(d__2)), d__4 = work[*n + j]; + work[*n + j] = f2cmax(d__3,d__4); + } + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + i__2 = *n; + for (i__ = j; i__ <= i__2; ++i__) { +/* Computing MAX */ + i__3 = i__ + j * a_dim1; + d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + + j * a_dim1]), abs(d__2)), d__4 = work[*n + i__]; + work[*n + i__] = f2cmax(d__3,d__4); +/* Computing MAX */ + i__3 = i__ + j * a_dim1; + d__3 = (d__1 = a[i__3].r, abs(d__1)) + (d__2 = d_imag(&a[i__ + + j * a_dim1]), abs(d__2)), d__4 = work[*n + j]; + work[*n + j] = f2cmax(d__3,d__4); + } + } + } + +/* Now find the f2cmax magnitude entry of each column of U or L. Also */ +/* permute the magnitudes of A above so they're in the same order as */ +/* the factor. */ + +/* The iteration orders and permutations were copied from zsytrs. */ +/* Calls to SSWAP would be severe overkill. */ + + if (upper) { + k = *n; + while(k < ncols && k > 0) { + if (ipiv[k] > 0) { +/* 1x1 pivot */ + kp = ipiv[k]; + if (kp != k) { + tmp = work[*n + k]; + work[*n + k] = work[*n + kp]; + work[*n + kp] = tmp; + } + i__1 = k; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + i__2 = i__ + k * af_dim1; + d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(& + af[i__ + k * af_dim1]), abs(d__2)), d__4 = work[k] + ; + work[k] = f2cmax(d__3,d__4); + } + --k; + } else { +/* 2x2 pivot */ + kp = -ipiv[k]; + tmp = work[*n + k - 1]; + work[*n + k - 1] = work[*n + kp]; + work[*n + kp] = tmp; + i__1 = k - 1; + for (i__ = 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + i__2 = i__ + k * af_dim1; + d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(& + af[i__ + k * af_dim1]), abs(d__2)), d__4 = work[k] + ; + work[k] = f2cmax(d__3,d__4); +/* Computing MAX */ + i__2 = i__ + (k - 1) * af_dim1; + d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(& + af[i__ + (k - 1) * af_dim1]), abs(d__2)), d__4 = + work[k - 1]; + work[k - 1] = f2cmax(d__3,d__4); + } +/* Computing MAX */ + i__1 = k + k * af_dim1; + d__3 = (d__1 = af[i__1].r, abs(d__1)) + (d__2 = d_imag(&af[k + + k * af_dim1]), abs(d__2)), d__4 = work[k]; + work[k] = f2cmax(d__3,d__4); + k += -2; + } + } + k = ncols; + while(k <= *n) { + if (ipiv[k] > 0) { + kp = ipiv[k]; + if (kp != k) { + tmp = work[*n + k]; + work[*n + k] = work[*n + kp]; + work[*n + kp] = tmp; + } + ++k; + } else { + kp = -ipiv[k]; + tmp = work[*n + k]; + work[*n + k] = work[*n + kp]; + work[*n + kp] = tmp; + k += 2; + } + } + } else { + k = 1; + while(k <= ncols) { + if (ipiv[k] > 0) { +/* 1x1 pivot */ + kp = ipiv[k]; + if (kp != k) { + tmp = work[*n + k]; + work[*n + k] = work[*n + kp]; + work[*n + kp] = tmp; + } + i__1 = *n; + for (i__ = k; i__ <= i__1; ++i__) { +/* Computing MAX */ + i__2 = i__ + k * af_dim1; + d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(& + af[i__ + k * af_dim1]), abs(d__2)), d__4 = work[k] + ; + work[k] = f2cmax(d__3,d__4); + } + ++k; + } else { +/* 2x2 pivot */ + kp = -ipiv[k]; + tmp = work[*n + k + 1]; + work[*n + k + 1] = work[*n + kp]; + work[*n + kp] = tmp; + i__1 = *n; + for (i__ = k + 1; i__ <= i__1; ++i__) { +/* Computing MAX */ + i__2 = i__ + k * af_dim1; + d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(& + af[i__ + k * af_dim1]), abs(d__2)), d__4 = work[k] + ; + work[k] = f2cmax(d__3,d__4); +/* Computing MAX */ + i__2 = i__ + (k + 1) * af_dim1; + d__3 = (d__1 = af[i__2].r, abs(d__1)) + (d__2 = d_imag(& + af[i__ + (k + 1) * af_dim1]), abs(d__2)), d__4 = + work[k + 1]; + work[k + 1] = f2cmax(d__3,d__4); + } +/* Computing MAX */ + i__1 = k + k * af_dim1; + d__3 = (d__1 = af[i__1].r, abs(d__1)) + (d__2 = d_imag(&af[k + + k * af_dim1]), abs(d__2)), d__4 = work[k]; + work[k] = f2cmax(d__3,d__4); + k += 2; + } + } + k = ncols; + while(k >= 1) { + if (ipiv[k] > 0) { + kp = ipiv[k]; + if (kp != k) { + tmp = work[*n + k]; + work[*n + k] = work[*n + kp]; + work[*n + kp] = tmp; + } + --k; + } else { + kp = -ipiv[k]; + tmp = work[*n + k]; + work[*n + k] = work[*n + kp]; + work[*n + kp] = tmp; + k += -2; + } + } + } + +/* Compute the *inverse* of the f2cmax element growth factor. Dividing */ +/* by zero would imply the largest entry of the factor's column is */ +/* zero. Than can happen when either the column of A is zero or */ +/* massive pivots made the factor underflow to zero. Neither counts */ +/* as growth in itself, so simply ignore terms with zero */ +/* denominators. */ + + if (upper) { + i__1 = *n; + for (i__ = ncols; i__ <= i__1; ++i__) { + umax = work[i__]; + amax = work[*n + i__]; + if (umax != 0.) { +/* Computing MIN */ + d__1 = amax / umax; + rpvgrw = f2cmin(d__1,rpvgrw); + } + } + } else { + i__1 = ncols; + for (i__ = 1; i__ <= i__1; ++i__) { + umax = work[i__]; + amax = work[*n + i__]; + if (umax != 0.) { +/* Computing MIN */ + d__1 = amax / umax; + rpvgrw = f2cmin(d__1,rpvgrw); + } + } + } + ret_val = rpvgrw; + return ret_val; +} /* zla_syrpvgrw__ */ + diff --git a/lapack-netlib/SRC/zla_wwaddw.c b/lapack-netlib/SRC/zla_wwaddw.c new file mode 100644 index 000000000..96af861d9 --- /dev/null +++ b/lapack-netlib/SRC/zla_wwaddw.c @@ -0,0 +1,518 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLA_WWADDW adds a vector into a doubled-single vector. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLA_WWADDW + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLA_WWADDW( N, X, Y, W ) */ + +/* INTEGER N */ +/* COMPLEX*16 X( * ), Y( * ), W( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLA_WWADDW adds a vector W into a doubled-single vector (X, Y). */ +/* > */ +/* > This works for all extant IBM's hex and binary floating point */ +/* > arithmetic, but not for decimal. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The length of vectors X, Y, and W. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (N) */ +/* > The first part of the doubled-single accumulation vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] Y */ +/* > \verbatim */ +/* > Y is COMPLEX*16 array, dimension (N) */ +/* > The second part of the doubled-single accumulation vector. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] W */ +/* > \verbatim */ +/* > W is COMPLEX*16 array, dimension (N) */ +/* > The vector to be added. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERcomputational */ + +/* ===================================================================== */ +/* Subroutine */ int zla_wwaddw_(integer *n, doublecomplex *x, doublecomplex + *y, doublecomplex *w) +{ + /* System generated locals */ + integer i__1, i__2, i__3, i__4, i__5; + doublecomplex z__1, z__2, z__3; + + /* Local variables */ + integer i__; + doublecomplex s; + + +/* -- 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 */ + --w; + --y; + --x; + + /* Function Body */ + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + i__3 = i__; + z__1.r = x[i__2].r + w[i__3].r, z__1.i = x[i__2].i + w[i__3].i; + s.r = z__1.r, s.i = z__1.i; + z__2.r = s.r + s.r, z__2.i = s.i + s.i; + z__1.r = z__2.r - s.r, z__1.i = z__2.i - s.i; + s.r = z__1.r, s.i = z__1.i; + i__2 = i__; + i__3 = i__; + z__3.r = x[i__3].r - s.r, z__3.i = x[i__3].i - s.i; + i__4 = i__; + z__2.r = z__3.r + w[i__4].r, z__2.i = z__3.i + w[i__4].i; + i__5 = i__; + z__1.r = z__2.r + y[i__5].r, z__1.i = z__2.i + y[i__5].i; + y[i__2].r = z__1.r, y[i__2].i = z__1.i; + i__2 = i__; + x[i__2].r = s.r, x[i__2].i = s.i; +/* L10: */ + } + return 0; +} /* zla_wwaddw__ */ + diff --git a/lapack-netlib/SRC/zlabrd.c b/lapack-netlib/SRC/zlabrd.c new file mode 100644 index 000000000..6ea4ff8f5 --- /dev/null +++ b/lapack-netlib/SRC/zlabrd.c @@ -0,0 +1,954 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLABRD + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y, */ +/* LDY ) */ + +/* INTEGER LDA, LDX, LDY, M, N, NB */ +/* DOUBLE PRECISION D( * ), E( * ) */ +/* COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ), */ +/* $ Y( LDY, * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLABRD reduces the first NB rows and columns of a complex general */ +/* > m by n matrix A to upper or lower real bidiagonal form by a unitary */ +/* > transformation Q**H * A * P, and returns the matrices X and Y which */ +/* > are needed to apply the transformation to the unreduced part of A. */ +/* > */ +/* > If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower */ +/* > bidiagonal form. */ +/* > */ +/* > This is an auxiliary routine called by ZGEBRD */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] M */ +/* > \verbatim */ +/* > M is INTEGER */ +/* > The number of rows in the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The number of columns in the matrix A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] NB */ +/* > \verbatim */ +/* > NB is INTEGER */ +/* > The number of leading rows and columns of A to be reduced. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] A */ +/* > \verbatim */ +/* > A is COMPLEX*16 array, dimension (LDA,N) */ +/* > On entry, the m by n general matrix to be reduced. */ +/* > On exit, the first NB rows and columns of the matrix are */ +/* > overwritten; the rest of the array is unchanged. */ +/* > If m >= n, elements on and below the diagonal in the first NB */ +/* > columns, with the array TAUQ, represent the unitary */ +/* > matrix Q as a product of elementary reflectors; and */ +/* > elements above the diagonal in the first NB rows, with the */ +/* > array TAUP, represent the unitary matrix P as a product */ +/* > of elementary reflectors. */ +/* > If m < n, elements below the diagonal in the first NB */ +/* > columns, with the array TAUQ, represent the unitary */ +/* > matrix Q as a product of elementary reflectors, and */ +/* > elements on and above the diagonal in the first NB rows, */ +/* > with the array TAUP, represent the unitary matrix P as */ +/* > a product of elementary reflectors. */ +/* > See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDA */ +/* > \verbatim */ +/* > LDA is INTEGER */ +/* > The leading dimension of the array A. LDA >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (NB) */ +/* > The diagonal elements of the first NB rows and columns of */ +/* > the reduced matrix. D(i) = A(i,i). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (NB) */ +/* > The off-diagonal elements of the first NB rows and columns of */ +/* > the reduced matrix. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUQ */ +/* > \verbatim */ +/* > TAUQ is COMPLEX*16 array, dimension (NB) */ +/* > The scalar factors of the elementary reflectors which */ +/* > represent the unitary matrix Q. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] TAUP */ +/* > \verbatim */ +/* > TAUP is COMPLEX*16 array, dimension (NB) */ +/* > The scalar factors of the elementary reflectors which */ +/* > represent the unitary matrix P. See Further Details. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension (LDX,NB) */ +/* > The m-by-nb matrix X required to update the unreduced part */ +/* > of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDX */ +/* > \verbatim */ +/* > LDX is INTEGER */ +/* > The leading dimension of the array X. LDX >= f2cmax(1,M). */ +/* > \endverbatim */ +/* > */ +/* > \param[out] Y */ +/* > \verbatim */ +/* > Y is COMPLEX*16 array, dimension (LDY,NB) */ +/* > The n-by-nb matrix Y required to update the unreduced part */ +/* > of A. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LDY */ +/* > \verbatim */ +/* > LDY is INTEGER */ +/* > The leading dimension of the array Y. LDY >= f2cmax(1,N). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date June 2017 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* > \par Further Details: */ +/* ===================== */ +/* > */ +/* > \verbatim */ +/* > */ +/* > The matrices Q and P are represented as products of elementary */ +/* > reflectors: */ +/* > */ +/* > Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb) */ +/* > */ +/* > Each H(i) and G(i) has the form: */ +/* > */ +/* > H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H */ +/* > */ +/* > where tauq and taup are complex scalars, and v and u are complex */ +/* > vectors. */ +/* > */ +/* > If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in */ +/* > A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in */ +/* > A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */ +/* > */ +/* > If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in */ +/* > A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in */ +/* > A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i). */ +/* > */ +/* > The elements of the vectors v and u together form the m-by-nb matrix */ +/* > V and the nb-by-n matrix U**H which are needed, with X and Y, to apply */ +/* > the transformation to the unreduced part of the matrix, using a block */ +/* > update of the form: A := A - V*Y**H - X*U**H. */ +/* > */ +/* > The contents of A on exit are illustrated by the following examples */ +/* > with nb = 2: */ +/* > */ +/* > m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n): */ +/* > */ +/* > ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 ) */ +/* > ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 ) */ +/* > ( v1 v2 a a a ) ( v1 1 a a a a ) */ +/* > ( v1 v2 a a a ) ( v1 v2 a a a a ) */ +/* > ( v1 v2 a a a ) ( v1 v2 a a a a ) */ +/* > ( v1 v2 a a a ) */ +/* > */ +/* > where a denotes an element of the original matrix which is unchanged, */ +/* > vi denotes an element of the vector defining H(i), and ui an element */ +/* > of the vector defining G(i). */ +/* > \endverbatim */ +/* > */ +/* ===================================================================== */ +/* Subroutine */ int zlabrd_(integer *m, integer *n, integer *nb, + doublecomplex *a, integer *lda, doublereal *d__, doublereal *e, + doublecomplex *tauq, doublecomplex *taup, doublecomplex *x, integer * + ldx, doublecomplex *y, integer *ldy) +{ + /* System generated locals */ + integer a_dim1, a_offset, x_dim1, x_offset, y_dim1, y_offset, i__1, i__2, + i__3; + doublecomplex z__1; + + /* Local variables */ + integer i__; + doublecomplex alpha; + extern /* Subroutine */ int zscal_(integer *, doublecomplex *, + doublecomplex *, integer *), zgemv_(char *, integer *, integer *, + doublecomplex *, doublecomplex *, integer *, doublecomplex *, + integer *, doublecomplex *, doublecomplex *, integer *), + zlarfg_(integer *, doublecomplex *, doublecomplex *, integer *, + doublecomplex *), zlacgv_(integer *, doublecomplex *, integer *); + + +/* -- LAPACK auxiliary routine (version 3.7.1) -- */ +/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ +/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ +/* June 2017 */ + + +/* ===================================================================== */ + + +/* Quick return if possible */ + + /* Parameter adjustments */ + a_dim1 = *lda; + a_offset = 1 + a_dim1 * 1; + a -= a_offset; + --d__; + --e; + --tauq; + --taup; + x_dim1 = *ldx; + x_offset = 1 + x_dim1 * 1; + x -= x_offset; + y_dim1 = *ldy; + y_offset = 1 + y_dim1 * 1; + y -= y_offset; + + /* Function Body */ + if (*m <= 0 || *n <= 0) { + return 0; + } + + if (*m >= *n) { + +/* Reduce to upper bidiagonal form */ + + i__1 = *nb; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Update A(i:m,i) */ + + i__2 = i__ - 1; + zlacgv_(&i__2, &y[i__ + y_dim1], ldy); + i__2 = *m - i__ + 1; + i__3 = i__ - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + a_dim1], lda, + &y[i__ + y_dim1], ldy, &c_b2, &a[i__ + i__ * a_dim1], & + c__1); + i__2 = i__ - 1; + zlacgv_(&i__2, &y[i__ + y_dim1], ldy); + i__2 = *m - i__ + 1; + i__3 = i__ - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__2, &i__3, &z__1, &x[i__ + x_dim1], ldx, + &a[i__ * a_dim1 + 1], &c__1, &c_b2, &a[i__ + i__ * + a_dim1], &c__1); + +/* Generate reflection Q(i) to annihilate A(i+1:m,i) */ + + i__2 = i__ + i__ * a_dim1; + alpha.r = a[i__2].r, alpha.i = a[i__2].i; + i__2 = *m - i__ + 1; +/* Computing MIN */ + i__3 = i__ + 1; + zlarfg_(&i__2, &alpha, &a[f2cmin(i__3,*m) + i__ * a_dim1], &c__1, & + tauq[i__]); + i__2 = i__; + d__[i__2] = alpha.r; + if (i__ < *n) { + i__2 = i__ + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + +/* Compute Y(i+1:n,i) */ + + i__2 = *m - i__ + 1; + i__3 = *n - i__; + zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + ( + i__ + 1) * a_dim1], lda, &a[i__ + i__ * a_dim1], & + c__1, &c_b1, &y[i__ + 1 + i__ * y_dim1], &c__1); + i__2 = *m - i__ + 1; + i__3 = i__ - 1; + zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + + a_dim1], lda, &a[i__ + i__ * a_dim1], &c__1, &c_b1, & + y[i__ * y_dim1 + 1], &c__1); + i__2 = *n - i__; + i__3 = i__ - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__2, &i__3, &z__1, &y[i__ + 1 + + y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b2, &y[ + i__ + 1 + i__ * y_dim1], &c__1); + i__2 = *m - i__ + 1; + i__3 = i__ - 1; + zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &x[i__ + + x_dim1], ldx, &a[i__ + i__ * a_dim1], &c__1, &c_b1, & + y[i__ * y_dim1 + 1], &c__1); + i__2 = i__ - 1; + i__3 = *n - i__; + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &a[(i__ + + 1) * a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, & + c_b2, &y[i__ + 1 + i__ * y_dim1], &c__1); + i__2 = *n - i__; + zscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); + +/* Update A(i,i+1:n) */ + + i__2 = *n - i__; + zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); + zlacgv_(&i__, &a[i__ + a_dim1], lda); + i__2 = *n - i__; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__2, &i__, &z__1, &y[i__ + 1 + + y_dim1], ldy, &a[i__ + a_dim1], lda, &c_b2, &a[i__ + ( + i__ + 1) * a_dim1], lda); + zlacgv_(&i__, &a[i__ + a_dim1], lda); + i__2 = i__ - 1; + zlacgv_(&i__2, &x[i__ + x_dim1], ldx); + i__2 = i__ - 1; + i__3 = *n - i__; + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &a[(i__ + + 1) * a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b2, & + a[i__ + (i__ + 1) * a_dim1], lda); + i__2 = i__ - 1; + zlacgv_(&i__2, &x[i__ + x_dim1], ldx); + +/* Generate reflection P(i) to annihilate A(i,i+2:n) */ + + i__2 = i__ + (i__ + 1) * a_dim1; + alpha.r = a[i__2].r, alpha.i = a[i__2].i; + i__2 = *n - i__; +/* Computing MIN */ + i__3 = i__ + 2; + zlarfg_(&i__2, &alpha, &a[i__ + f2cmin(i__3,*n) * a_dim1], lda, & + taup[i__]); + i__2 = i__; + e[i__2] = alpha.r; + i__2 = i__ + (i__ + 1) * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + +/* Compute X(i+1:m,i) */ + + i__2 = *m - i__; + i__3 = *n - i__; + zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + (i__ + + 1) * a_dim1], lda, &a[i__ + (i__ + 1) * a_dim1], + lda, &c_b1, &x[i__ + 1 + i__ * x_dim1], &c__1); + i__2 = *n - i__; + zgemv_("Conjugate transpose", &i__2, &i__, &c_b2, &y[i__ + 1 + + y_dim1], ldy, &a[i__ + (i__ + 1) * a_dim1], lda, & + c_b1, &x[i__ * x_dim1 + 1], &c__1); + i__2 = *m - i__; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__2, &i__, &z__1, &a[i__ + 1 + + a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[ + i__ + 1 + i__ * x_dim1], &c__1); + i__2 = i__ - 1; + i__3 = *n - i__; + zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[(i__ + 1) * + a_dim1 + 1], lda, &a[i__ + (i__ + 1) * a_dim1], lda, & + c_b1, &x[i__ * x_dim1 + 1], &c__1); + i__2 = *m - i__; + i__3 = i__ - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__2, &i__3, &z__1, &x[i__ + 1 + + x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[ + i__ + 1 + i__ * x_dim1], &c__1); + i__2 = *m - i__; + zscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1); + i__2 = *n - i__; + zlacgv_(&i__2, &a[i__ + (i__ + 1) * a_dim1], lda); + } +/* L10: */ + } + } else { + +/* Reduce to lower bidiagonal form */ + + i__1 = *nb; + for (i__ = 1; i__ <= i__1; ++i__) { + +/* Update A(i,i:n) */ + + i__2 = *n - i__ + 1; + zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda); + i__2 = i__ - 1; + zlacgv_(&i__2, &a[i__ + a_dim1], lda); + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__2, &i__3, &z__1, &y[i__ + y_dim1], ldy, + &a[i__ + a_dim1], lda, &c_b2, &a[i__ + i__ * a_dim1], + lda); + i__2 = i__ - 1; + zlacgv_(&i__2, &a[i__ + a_dim1], lda); + i__2 = i__ - 1; + zlacgv_(&i__2, &x[i__ + x_dim1], ldx); + i__2 = i__ - 1; + i__3 = *n - i__ + 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &i__2, &i__3, &z__1, &a[i__ * + a_dim1 + 1], lda, &x[i__ + x_dim1], ldx, &c_b2, &a[i__ + + i__ * a_dim1], lda); + i__2 = i__ - 1; + zlacgv_(&i__2, &x[i__ + x_dim1], ldx); + +/* Generate reflection P(i) to annihilate A(i,i+1:n) */ + + i__2 = i__ + i__ * a_dim1; + alpha.r = a[i__2].r, alpha.i = a[i__2].i; + i__2 = *n - i__ + 1; +/* Computing MIN */ + i__3 = i__ + 1; + zlarfg_(&i__2, &alpha, &a[i__ + f2cmin(i__3,*n) * a_dim1], lda, & + taup[i__]); + i__2 = i__; + d__[i__2] = alpha.r; + if (i__ < *m) { + i__2 = i__ + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + +/* Compute X(i+1:m,i) */ + + i__2 = *m - i__; + i__3 = *n - i__ + 1; + zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + i__ * + a_dim1], lda, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[ + i__ + 1 + i__ * x_dim1], &c__1); + i__2 = *n - i__ + 1; + i__3 = i__ - 1; + zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &y[i__ + + y_dim1], ldy, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[ + i__ * x_dim1 + 1], &c__1); + i__2 = *m - i__; + i__3 = i__ - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + 1 + + a_dim1], lda, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[ + i__ + 1 + i__ * x_dim1], &c__1); + i__2 = i__ - 1; + i__3 = *n - i__ + 1; + zgemv_("No transpose", &i__2, &i__3, &c_b2, &a[i__ * a_dim1 + + 1], lda, &a[i__ + i__ * a_dim1], lda, &c_b1, &x[i__ * + x_dim1 + 1], &c__1); + i__2 = *m - i__; + i__3 = i__ - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__2, &i__3, &z__1, &x[i__ + 1 + + x_dim1], ldx, &x[i__ * x_dim1 + 1], &c__1, &c_b2, &x[ + i__ + 1 + i__ * x_dim1], &c__1); + i__2 = *m - i__; + zscal_(&i__2, &taup[i__], &x[i__ + 1 + i__ * x_dim1], &c__1); + i__2 = *n - i__ + 1; + zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda); + +/* Update A(i+1:m,i) */ + + i__2 = i__ - 1; + zlacgv_(&i__2, &y[i__ + y_dim1], ldy); + i__2 = *m - i__; + i__3 = i__ - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__2, &i__3, &z__1, &a[i__ + 1 + + a_dim1], lda, &y[i__ + y_dim1], ldy, &c_b2, &a[i__ + + 1 + i__ * a_dim1], &c__1); + i__2 = i__ - 1; + zlacgv_(&i__2, &y[i__ + y_dim1], ldy); + i__2 = *m - i__; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__2, &i__, &z__1, &x[i__ + 1 + + x_dim1], ldx, &a[i__ * a_dim1 + 1], &c__1, &c_b2, &a[ + i__ + 1 + i__ * a_dim1], &c__1); + +/* Generate reflection Q(i) to annihilate A(i+2:m,i) */ + + i__2 = i__ + 1 + i__ * a_dim1; + alpha.r = a[i__2].r, alpha.i = a[i__2].i; + i__2 = *m - i__; +/* Computing MIN */ + i__3 = i__ + 2; + zlarfg_(&i__2, &alpha, &a[f2cmin(i__3,*m) + i__ * a_dim1], &c__1, + &tauq[i__]); + i__2 = i__; + e[i__2] = alpha.r; + i__2 = i__ + 1 + i__ * a_dim1; + a[i__2].r = 1., a[i__2].i = 0.; + +/* Compute Y(i+1:n,i) */ + + i__2 = *m - i__; + i__3 = *n - i__; + zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + + (i__ + 1) * a_dim1], lda, &a[i__ + 1 + i__ * a_dim1] + , &c__1, &c_b1, &y[i__ + 1 + i__ * y_dim1], &c__1); + i__2 = *m - i__; + i__3 = i__ - 1; + zgemv_("Conjugate transpose", &i__2, &i__3, &c_b2, &a[i__ + 1 + + a_dim1], lda, &a[i__ + 1 + i__ * a_dim1], &c__1, & + c_b1, &y[i__ * y_dim1 + 1], &c__1); + i__2 = *n - i__; + i__3 = i__ - 1; + z__1.r = -1., z__1.i = 0.; + zgemv_("No transpose", &i__2, &i__3, &z__1, &y[i__ + 1 + + y_dim1], ldy, &y[i__ * y_dim1 + 1], &c__1, &c_b2, &y[ + i__ + 1 + i__ * y_dim1], &c__1); + i__2 = *m - i__; + zgemv_("Conjugate transpose", &i__2, &i__, &c_b2, &x[i__ + 1 + + x_dim1], ldx, &a[i__ + 1 + i__ * a_dim1], &c__1, & + c_b1, &y[i__ * y_dim1 + 1], &c__1); + i__2 = *n - i__; + z__1.r = -1., z__1.i = 0.; + zgemv_("Conjugate transpose", &i__, &i__2, &z__1, &a[(i__ + 1) + * a_dim1 + 1], lda, &y[i__ * y_dim1 + 1], &c__1, & + c_b2, &y[i__ + 1 + i__ * y_dim1], &c__1); + i__2 = *n - i__; + zscal_(&i__2, &tauq[i__], &y[i__ + 1 + i__ * y_dim1], &c__1); + } else { + i__2 = *n - i__ + 1; + zlacgv_(&i__2, &a[i__ + i__ * a_dim1], lda); + } +/* L20: */ + } + } + return 0; + +/* End of ZLABRD */ + +} /* zlabrd_ */ + diff --git a/lapack-netlib/SRC/zlacgv.c b/lapack-netlib/SRC/zlacgv.c new file mode 100644 index 000000000..cc51a852e --- /dev/null +++ b/lapack-netlib/SRC/zlacgv.c @@ -0,0 +1,512 @@ +/* f2c.h -- Standard Fortran to C header file */ + +/** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed." + + - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */ + +#ifndef F2C_INCLUDE +#define F2C_INCLUDE + +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +typedef int integer; +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} +static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;} +static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} +#define pCf(z) (*_pCf(z)) +#define pCd(z) (*_pCd(z)) +typedef int logical; +typedef short int shortlogical; +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define c_abs(z) (cabsf(Cf(z))) +#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } +#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} +#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} +#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} +#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} +#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} +//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} +#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } +#define r_cnjg(R, Z) { pCf(R) = conj(Cf(Z)); } +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_imag(z) (cimag(Cd(z))) +#define r_imag(z) (cimag(Cf(z))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} +#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} +#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +static char junk[] = "\n@(#)LIBF77 VERSION 19990503\n"; +#define z_abs(z) (cabs(Cd(z))) +#define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} +#define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* procedure parameter types for -A and -C++ */ + +#define F2C_proc_par_types 1 +#ifdef __cplusplus +typedef logical (*L_fp)(...); +#else +typedef logical (*L_fp)(); +#endif + +static float spow_ui(float x, integer n) { + float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static double dpow_ui(double x, integer n) { + double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex float cpow_ui(_Complex float x, integer n) { + _Complex float pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static _Complex double zpow_ui(_Complex double x, integer n) { + _Complex double pow=1.0; unsigned long int u; + if(n != 0) { + if(n < 0) n = -n, x = 1/x; + for(u = n; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer pow_ii(integer x, integer n) { + integer pow; unsigned long int u; + if (n <= 0) { + if (n == 0 || x == 1) pow = 1; + else if (x != -1) pow = x == 0 ? 1/x : 0; + else n = -n; + } + if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { + u = n; + for(pow = 1; ; ) { + if(u & 01) pow *= x; + if(u >>= 1) x *= x; + else break; + } + } + return pow; +} +static integer dmaxloc_(double *w, integer s, integer e, integer *n) +{ + double m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static integer smaxloc_(float *w, integer s, integer e, integer *n) +{ + float m; integer i, mi; + for(m=w[s-1], mi=s, i=s+1; i<=e; i++) + if (w[i-1]>m) mi=i ,m=w[i-1]; + return mi-s+1; +} +static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { + integer n = *n_, incx = *incx_, incy = *incy_, i; + _Complex float zdotc = 0.0; + if (incx == 1 && incy == 1) { + for (i=0;i \brief \b ZLACGV conjugates a complex vector. */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* > \htmlonly */ +/* > Download ZLACGV + dependencies */ +/* > */ +/* > [TGZ] */ +/* > */ +/* > [ZIP] */ +/* > */ +/* > [TXT] */ +/* > \endhtmlonly */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE ZLACGV( N, X, INCX ) */ + +/* INTEGER INCX, N */ +/* COMPLEX*16 X( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > ZLACGV conjugates a complex vector of length N. */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The length of the vector X. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] X */ +/* > \verbatim */ +/* > X is COMPLEX*16 array, dimension */ +/* > (1+(N-1)*abs(INCX)) */ +/* > On entry, the vector of length N to be conjugated. */ +/* > On exit, X is overwritten with conjg(X). */ +/* > \endverbatim */ +/* > */ +/* > \param[in] INCX */ +/* > \verbatim */ +/* > INCX is INTEGER */ +/* > The spacing between successive elements of X. */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \date December 2016 */ + +/* > \ingroup complex16OTHERauxiliary */ + +/* ===================================================================== */ +/* Subroutine */ int zlacgv_(integer *n, doublecomplex *x, integer *incx) +{ + /* System generated locals */ + integer i__1, i__2; + doublecomplex z__1; + + /* Local variables */ + integer ioff, 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 */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --x; + + /* Function Body */ + if (*incx == 1) { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = i__; + d_cnjg(&z__1, &x[i__]); + x[i__2].r = z__1.r, x[i__2].i = z__1.i; +/* L10: */ + } + } else { + ioff = 1; + if (*incx < 0) { + ioff = 1 - (*n - 1) * *incx; + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + i__2 = ioff; + d_cnjg(&z__1, &x[ioff]); + x[i__2].r = z__1.r, x[i__2].i = z__1.i; + ioff += *incx; +/* L20: */ + } + } + return 0; + +/* End of ZLACGV */ + +} /* zlacgv_ */ +